package LIMS::Model::Request;

use Moose;
extends 'LIMS::Model::Base';
with (
    'LIMS::Model::Roles::Query',
	'LIMS::Model::Roles::RequestUpdate',
	'LIMS::Model::Roles::ScreenUpdate',  # auto_screen
	'LIMS::Model::Roles::HistoryAction',
);
use namespace::clean -except => 'meta';

has frozen_data => ( is => 'rw', isa => 'HashRef');
has form_data => ( is => 'rw', isa => 'HashRef', default => sub { {} } );

has archive => (
    is      => 'ro',
    isa     => 'ArrayRef[HashRef]',
    default => sub { [] },
    lazy    => 1,
	traits  => ['Array'],
	handles => {
		add_to_archive => 'push',
		archived_data  => 'elements',
	},
);

has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
	for qw(
		specimen_map
        referral_type_map
        specimen_lab_test_map
        request_status_options_map
    );

__PACKAGE__->meta->make_immutable;

use Data::Dumper;
use LIMS::Local::Utils;

#-------------------------------------------------------------------------------
sub new_request {
	my $self = shift;
	my $data = shift; # warn Dumper $data; # return;

    my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	# extract request, options & consent data from $data:
	my $request_data = $self->_get_request_data($data);
	my $trial_data   = $self->_get_clinical_trial_data($data);

	# get specimens table iterator:
	my $specimen = LIMS::DB::Specimen::Manager
		->get_specimens_iterator(sort_by => 'sample_code');

	# get specimen -> lab_test map (for any auto-generated lab tests):
	my $specimen_lab_test_map = $self->specimen_lab_test_map;

	# get consent_options iterator:
	my $consent_options = LIMS::DB::ConsentOption::Manager
		->get_consent_options_iterator();

	# get additional_options table iterator:
	my $request_options = LIMS::DB::AdditionalOption::Manager
		->get_additional_options_iterator();

	# extract specimens from $data->{specimen}:
    my $specimens = LIMS::Local::Utils::get_specimens($data->{specimen}); # warn Dumper $specimens;

    # have rare instances of no entry in request_specimen table (solved 3/1/13 - BMAT.PB & RDBO <0.802):
	if (@$specimens) { # if any entry in @$specimens doesn't exist in specimens_map:
		my $map = $self->specimen_map;
		$map->{$_} || die "cannot find id for $_" for @$specimens; # cannot find id for BMAT.PB - 3/1/13
	} # warn Dumper \@$specimens;
	else { # will also capture undef $data->{specimen} - which should be impossible
		die sprintf q!cannot parse specimen entry '%s'!, $data->{specimen};
	}

	my $user_id = $self->user_profile->{id};

	# create new request in transaction:
	my $new_request = sub {
		# save request_data to request table 1st so we can get request.id:
        my $request = LIMS::DB::Request->new(%$request_data);

        # if auto-incrementing lab-number settings active:
        unless ($request->request_number) {
            # need to do sql query not supported by RDBO (will be NULL if 1st of yr):
			my @args = ('requests', 'MAX(request_number)');
			# ignore year if unique request number required:
			unless ( $self->lims_cfg->{settings}->{unique_request_number} ) {
                my $year = LIMS::Local::Utils::this_year;
				push @args, { year => $year };
            }
            my $n = $self->lims_dbix->select(@args)->list || 0; # warn $n;
            $data->{request_number} = ++$n; # initialise entry for downstream actions
            $request->request_number($n); # warn Dumper $request->as_tree;
        }

        $request->save;

		# request_history:
        $self->add_to_actions('registered');

		# cycle specimens iterator, adding specimen_id to request_specimen table:
		my @specimen_ids;
		while ( my $o = $specimen->next ) {
			next unless grep { $o->sample_code eq $_ } @$specimens; # DEBUG $o->sample_code;
			push @specimen_ids, $o->id;

			LIMS::DB::RequestSpecimen->new(
				request_id  => $request->id,
				specimen_id => $o->id,
			)->save;
		}
		{ # add new lab-tests if specimen requires:
            my %h = (
                request_id  => $request->id,
                specimen_id => \@specimen_ids,
            );
            $self->do_specimen_associated_lab_tests(\%h); # M::R::LabTestUpdate
		}
		# clinical trial:
		if ( my $trial_id = $trial_data->{trial_id} ) {
			LIMS::DB::RequestTrial->new(
				trial_id   => $trial_id,
				request_id => $request->id,
			)->save;
			# trial_number - should not be submitted without trial_id:
			if ( my $trial_number = $trial_data->{trial_number} ) {
				# update existing or create new patient trial data:
				LIMS::DB::PatientTrial->new(
					patient_id   => $trial_data->{patient_id},
					trial_number => $trial_number,
					trial_id     => $trial_id,
				)->insert_or_update;
			}
		}

		# consent data:
		while ( my $o = $consent_options->next ) {
			my $option_name = $o->consent_name;
			next unless $data->{$option_name};

			LIMS::DB::RequestConsent->new(
				status     => $data->{$option_name},
				request_id => $request->id,
				consent_id => $o->id,
			)->save;
		}

		# error codes:
		if ( my $error_code_id = $data->{error_code_id} ) {
			my %data = (
				request_id => $request->id,
				user_id    => $user_id,
			);

			# get error_code_ids as an arrayref (if not already):
			my $codes = ref $error_code_id eq 'ARRAY'
				? $error_code_id : [ $error_code_id ];

			my %err_codes_map = do {
				my $o = LIMS::DB::ErrorCode::Manager->get_error_codes;
				map +($_->id => $_->code), @$o;
			}; # warn Dumper \%err_codes_map;

			for my $code(@$codes) {
				$data{error_code_id} = $code;
				LIMS::DB::RequestErrorCode->new(%data)->save;
				my $msg = 'recorded error code '. uc $err_codes_map{$code};
				$self->add_to_actions($msg);
			}
		}

		# cycle request_options iterator, adding additional_option_id to request_options table:
		while ( my $o = $request_options->next ) {
			my $option_name = $o->option_name;
			next unless $data->{$option_name};

			LIMS::DB::RequestOption->new(
				request_id => $request->id,
				option_id  => $o->id,
			)->save;
		}

		# external_reference:
		if ( my $ref = $data->{external_reference} ) {
			LIMS::DB::RequestExternalRef->new(
				request_id  => $request->id,
				external_reference => $ref,
			)->save;
		}

		# specimen taken date:
		if ( $data->{year} ) { # dd, mm & yyyy already validated
			my %h = (
				year  => $data->{year},
				month => $data->{month},
				day   => $data->{day},
			);
			# add hr & min if provided:
			map { $h{$_} = $data->{$_} } grep $data->{$_}, qw(hour minute);
			LIMS::DB::RequestSpecimenDetail->new(
				request_id    => $request->id,
				specimen_date => DateTime->new(%h),
			)->save;
		}

        $data->{_request_id} = $request->id;
        $self->form_data($data); # save form_data for ScreenUpdate & HistoryAction Role methods

        # auto-screen (if configured):
        if ($data->{auto_screen_config}) { # warn Dumper $data->{auto_screen_config};
            $self->do_auto_screen() # Roles::ScreenUpdate
        }

        $self->do_request_history(); # commit actions to request_history table
    };

    # do_transaction() returns true if succeeds; sets $db->error on failure:
    my $ok = $db->do_transaction($new_request);

    return $ok ? 0 : 'new_request() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub get_request_form {
	my ($self, $id) = @_;

    my $o = LIMS::DB::RequestForm->new(id => $id)->load_speculative; # in case hand-typed
    return $o;
}

#-------------------------------------------------------------------------------
sub request_form_import { # updates request_form.imported - doesn't matter if re-scanned
	my ($self, $id) = @_;

    my $o = LIMS::DB::RequestForm->new(id => $id)->load;
    $o->imported(LIMS::Local::Utils::time_now); # won't accept 'NOW()' ??
    $o->save(changes_only => 1);
}

#-------------------------------------------------------------------------------
sub get_requests_count {
	my $self = shift;

	my ($request_number, $year) = @_;

	my %args = (
		query => [
	        request_number => $request_number,
            year => $year || DateTime->now->year,
		],
	);

	my $total = LIMS::DB::Request::Manager->get_requests_count(%args);

    return $total;
}

#-------------------------------------------------------------------------------
sub count_biohazard_records {
    my ($self, $args) = @_; # warn Dumper $args; # hashref

	my %args = (
		query => [ # any other doi's:
			'option_name' => 'doi',
			'patient_case.patient_id' => $args->{patient_id},
		],
        require_objects => [ 'patient_case', 'request_option.option' ],
	);

	my $i = LIMS::DB::Request::Manager->get_requests_count(%args);
	return $i;
}

#-------------------------------------------------------------------------------
sub get_previous_diagnoses {
    my ($self, $request_id) = @_;

	my %args = (
		query => [ request_id => $request_id ],
        require_objects => [ 'user', 'diagnosis', 'option' ],
        sort_by => 'time',
	);

	my $o = LIMS::DB::RequestDiagnosisHistory::Manager
		->get_request_diagnosis_histories(%args);

	return $o;
}

#-------------------------------------------------------------------------------
# gets request.id if $n == 1:
sub get_request_id {
    my ($self, $search_constraints) = @_;

	my $formatted_args = $self->get_args_for_request_id($search_constraints);

    my $request = LIMS::DB::Request::Manager->get_requests(%$formatted_args);

    my $request_id;
    eval { # should never fail, but JIC
        $request_id = $request->[0]->id;
    }; warn 'request_id is undefined' unless $request_id; # happened once when request_specimen empty - how???
    return $request_id; # will return undef if $request is empty arrayref
}

#-------------------------------------------------------------------------------
# called by Search::do_search() to find number of requests matching search criteria:
sub search_requests_count {
    my ($self, $search_constraints) = @_; # warn Dumper $search_constraints;

	my $args = $self->get_args_for_requests_count($search_constraints);
    # some params (eg results_summary & specimen) involve >1 1-to-many relationships:
    $args->{multi_many_ok} = 1; # warn Dumper $args;

#$self->set_rose_debug(1);
    my $total = LIMS::DB::Request::Manager->get_requests_count(%$args);
#$self->set_rose_debug(0);
    return $total;
}

#-------------------------------------------------------------------------------
# called by Search::do_search() to retrieve records matching search criteria for n > 1:
sub find_requests {
	my $self = shift;
	my $args = shift; # hashref with keys = 'search_constraints' & 'args_for_search'

	# get query, with_objects, require_objects, etc from $args:
	my $formatted_args = $self->get_args_for_find_requests($args); # warn Dumper $formatted_args;

#$self->set_rose_debug(1);
    my $requests = LIMS::DB::Request::Manager->get_requests(%$formatted_args);
#$self->set_rose_debug(0);
    return $requests;
}

#-------------------------------------------------------------------------------
sub general_notes { # uses Role::RequestUpdate::update_general_notes() method:
	my $self = shift;
	my $data = shift;

	$self->form_data($data);

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
		$self->update_general_notes($data);
        $self->do_request_history;
	};

	# do it as transaction to use Role::RequestUpdate method & capture any errs:
	my $ok = $db->do_transaction( $update );

	return $ok ? 0 : 'update_general_notes() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
# accepts request.id & returns all required request data:
sub get_single_request {
	my ($self, $request_id) = @_; # warn $request_id;

	# check it exists 1st (in case user input of request_id into url):
	$self->_verify_request_exists($request_id) || return 0;

	# require data from these tables:
	my @tables = qw(
		patients
		referrers
		diagnoses
        patient_notes
		status_options
		clinical_trials
		referral_sources
		secondary_diagnosis
		request_external_ref
		hospital_departments
		request_general_notes
		request_initial_screen
		request_specimen_detail
	);

	my $relationships = $self->get_relationships(\@tables);

#$self->set_rose_debug(1);
    my $request
		= LIMS::DB::Request->new(id => $request_id)->load(with => $relationships);
#$self->set_rose_debug(0);

    return $request;
}

#-------------------------------------------------------------------------------
# get request_id's from yy_nnnnn formatted lab numbers:
sub get_request_id_from_lab_number {
	my ($self, $ref) = @_; # arrayref of lab_numbers

	# reject any lab_numbers not nn_nnnnn format (don't expect any):
	my @lab_numbers = grep $_ =~ /\d{2}_\d{5}/, @$ref; # warn Dumper @lab_numbers;

	# need to do sql query not supported by RDBO:
	my $dbix = $self->lims_dbix;

	# to search for, and retrieve, using nn_nnnnn format:
	my $cws = q!CONCAT_WS( '_', RIGHT(year, 2), LPAD(request_number, 5, 0) )!;

#	SELECT CONCAT_WS( '_', RIGHT(year, 2), LPAD(request_number, 5, 0) ), id
#	FROM requests WHERE CONCAT_WS( '_', RIGHT(year, 2), LPAD(request_number, 5, 0) )
#	IN (??)
	my %where = ( $cws => { in => \@lab_numbers } );
	my $data = $dbix->select('requests', [$cws, 'id'], \%where)->map; # warn Dumper $data;
	return $data;
}

#-------------------------------------------------------------------------------
# finds previous requests on current request nhs_number or patient id:
sub get_previous_requests {
	my $self = shift;
	my $args = shift; # hashref of args for query (eg nhs_number => 123, etc)

	my @inner_joins = qw( patients request_specimens );
	my @left_joins  = qw( authorised_reports ); # left join for non-auth'd requests

	my $required = $self->get_relationships(\@inner_joins); # warn Dumper $required;
	my $optional = $self->get_relationships(\@left_joins);  # warn Dumper $optional;
    my @sort_by  = ( # doesn't work having DATE(t1.col) - causes t1.id to go 1st
        'DATE(requests.created_at) DESC',
        'requests.year DESC',
        'requests.request_number DESC',
    );
	my %params = (
		query => [ %$args ],
		require_objects => $required,
		with_objects => $optional,
		# sort_by => ( join ',', @sort_by), # doesn't work - alawys get t1.id 1st!!
		nested_joins => 0,
	); # warn Dumper \%params;
	my $o = LIMS::DB::Request::Manager->get_objects(%params);

    # sort by date then lab-number (can't do this in query - see above):
    my @data = sort date_lab_number_order @$o; # warn $_->id for @data;
	return \@data;
}

#-------------------------------------------------------------------------------
sub date_lab_number_order {
    my $date_order = sub { LIMS::Local::Utils::check_chronological_order(@_) };
    my $date_time  = sub { LIMS::Local::Utils::to_datetime_using_dateparse(@_) };

    my $date_a = &$date_time($a->created_at);
    my $date_b = &$date_time($b->created_at);

    return
        # DateTime->compare( &$dt($b->created_at), &$dt($a->created_at) ) ||
        &$date_order($date_b, $date_a)  || # does same as above
        $b->year           <=> $a->year ||
        $b->request_number <=> $a->request_number;
}

#-------------------------------------------------------------------------------
sub get_request_options {
	my ($self, $request_id) = @_; # warn $request_id;

	my %args = (
		query => [ request_id => $request_id ],
		require_objects => 'option',
	);

	my $request_options
		= LIMS::DB::RequestOption::Manager->get_request_options(%args);

	return $request_options;
}

#-------------------------------------------------------------------------------
sub get_request_consent {
	my ($self, $request_id) = @_; # warn $request_id;

	my %args = (
		query => [ request_id => $request_id ],
		require_objects => 'consent',
	);

	my $request_consent
		= LIMS::DB::RequestConsent::Manager->get_request_consents(%args);

	return $request_consent;
}

=begin #------------------------------------------------------------------------
sub get_referrer_department { # was used by mail_reports.pl - ? remove if not used
 	my ($self, $request_id) = @_; # warn $request_id;

    my @rels = qw(
        referrer_department.referrer
        referrer_department.hospital_department
    );

    my $request
        = LIMS::DB::Request->new(id => $request_id)->load(with => \@rels);
    return $request->as_tree;
}
=cut

#-------------------------------------------------------------------------------
sub get_request_errors {
	my ($self, $request_id) = @_; # warn $request_id;

	my %args = (
		query => [ request_id => $request_id ],
        with_objects => 'error_detail',
		require_objects => [ 'error_code', 'user' ],
	);

	my $request_errors
		= LIMS::DB::RequestErrorCode::Manager->get_request_error_codes(%args);

	return $request_errors;
}

#-------------------------------------------------------------------------------
sub get_request_error_code {
	my ($self, $id) = @_; # warn $id;

    my $err = LIMS::DB::RequestErrorCode->new(id => $id)
        ->load(with => [ 'error_code', 'user' ]);
    return $err;
}

#-------------------------------------------------------------------------------
sub delete_request_error_code {
	my ($self, $id) = @_; # warn $id;

  	my $delete = sub {
        my $o = LIMS::DB::RequestErrorCode->new(id => $id)
            ->load( with => 'error_code' );
        my $request_id = $o->request_id;
        $o->delete;

        $self->add_to_actions('deleted error code ' . uc $o->error_code->code);
        $self->do_history_log({ _request_id => $request_id });
    };

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

    my $result = $db->do_transaction( $delete );

	# don't need return value unless error:
    return $result ? 0 : 'error in delete_request_error_code() - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub request_error_code {
	my $self = shift;
	my $data = shift; # warn Dumper $data;

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	$data->{_request_id} = $data->{request_id}; # do_request_error_code() format

	my $error = sub {
		$self->do_request_error_code($data);
		if ( $data->{LIC} ) {
			$self->add_to_actions('completed LIC');
		}
		# log history:
		$self->do_history_log($data);
	};

	my $result = $db->do_transaction( $error );

	# don't need return value unless error:
    return $result ? 0 : 'error in new_request_error() - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub edit_request_error_code {
	my $self = shift;
	my $data = shift; # warn Dumper $data;

    my $error_code_id = $data->{error_code_id};

	# get error_code object:
	my $error_code = LIMS::DB::ErrorCode->new(id => $error_code_id)->load;

    # edit request_error_code entry:
    my $edit = sub {
        my $o = LIMS::DB::RequestErrorCode->new(id => $data->{id})
            ->load( with => 'error_code' );
        # add to actions for history log:
        my $msg = sprintf 'updated error code %s to %s',
            uc $o->error_code->code, uc $error_code->code; # old -> new
        $self->add_to_actions($msg);

        $o->error_code_id($error_code_id); # change it
        $o->save(changes_only => 1); # save it

        $self->do_history_log({ _request_id => $o->request_id }); # log it
    };

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

    my $result = $db->do_transaction( $edit );

	# don't need return value unless error:
    return $result ? 0 : 'error in edit_request_error_code() - ' . $db->error;
}

#-------------------------------------------------------------------------------
# basic version of get_single_request() - just gets request & patient data:
sub get_patient_and_request_data {
	my ($self, $param) = @_; # warn $param;

	my @args =
		ref $param eq 'ARRAY'
			? @$param # eg request_number => nn, year => yyyy
			: (id => $param); # assume request.id passed if $param is scalar

	my $data
		= LIMS::DB::Request->new(@args)->load(with => 'patient_case.patient');

	return $data;
}

#-------------------------------------------------------------------------------
# gets basic request summary data (req, patient, referral) for multiple request_ids:
sub requests_summary_data {
	my ($self, $request_ids) = @_; # arrayref

	my @tables = # for packs & letters dispatches
        qw( referral_sources patient_practices outreach_pack_dispatches );
	my $relationships = $self->get_relationships(\@tables);

    my @args = (
        query => [ id => $request_ids ],
        require_objects => $relationships,
    );

    my $data = LIMS::DB::Request::Manager->get_requests(@args);
    return $data;
}

#-------------------------------------------------------------------------------
sub get_section_notes {
	my ($self, $request_id) = @_;

	my %args = (
		query => [ request_id => $request_id ],
	);

	my $section_notes = LIMS::DB::RequestLabSectionNote::Manager
		->get_request_lab_section_notes(%args);

	return $section_notes;
}

#-------------------------------------------------------------------------------
sub get_laboratory_number {
	my ($self, $request_id) = @_;

	my $request = LIMS::DB::Request->new(id => $request_id)->load;

	my $lab_number = join '/',
		$request->request_number,
		sprintf '%02d', $request->year - 2000;

	return $lab_number;
}

#-------------------------------------------------------------------------------
sub get_request {
	my ($self, $request_id) = @_;

	my $request = LIMS::DB::Request->new(id => $request_id)->load;

	return $request;
}

#-------------------------------------------------------------------------------
sub get_requests {
	my ($self, $request_id) = @_; # arrayref

	my $requests = LIMS::DB::Request::Manager->get_requests(
		query => [ id => $request_id ] );
	return $requests;
}

#-------------------------------------------------------------------------------
sub get_request_dispatch_logs {
	my ($self, $request_id) = @_;

	my $logs = LIMS::DB::RequestDispatchLog::Manager->get_request_dispatch_logs(
		query => [ request_id => $request_id ]
	);

	return $logs;
}

#-------------------------------------------------------------------------------
# how many requests 'have' this patient_case.id ?
sub get_patient_case_requests_count {
    my $self    = shift;
    my $case_id = shift;

    my $requests_count = LIMS::DB::Request::Manager->get_requests_count(
		query => [ patient_case_id => $case_id ],
	);

    return $requests_count;
}

#-------------------------------------------------------------------------------
sub get_new_and_relapsed_cases {
	my $self = shift;
	my $args = shift; # warn Dumper $args;

    my $all_cases = $args->{all_cases}; # optional form param
	my $org_code  = $args->{org_code}; # optional - not supplied for 'all locations'
	my $days      = $args->{duration};

	my $delta = $self->time_now->subtract(days => $days)->truncate(to => 'day');

	# set status level required for displaying reports:
	my $report_status = $self->does_authorisation() ? 'authorised' : 'reported';

    my @query = (
		'request_history.time'   => { ge => $delta },
		'request_history.action' => $report_status, # reported or authorised
    );
    unless ($all_cases) { # don't restrict on status:
        push @query, ( 'request_report.status' => { ne => 'default' } );
    }
    push @query, ( parent_code => $org_code ) if $org_code; # ie not 'all locations'

    # have split this into 2 queries as original was far too slow - up to 30 secs !!
	my @tables = qw( request_report parent_organisations request_history );
	my $relationships = $self->get_relationships(\@tables);

	my @params = (
        select => 'id', # only need request.id - used in 2nd query
		query => \@query,
		require_objects => $relationships,
	);

	my $cases = LIMS::DB::Request::Manager->get_requests(@params);
	return undef unless @$cases; # warn Dumper $_->as_tree for @$cases;

    {
        my @request_ids = map +($_->id), @$cases; # warn Dumper \@request_ids;
        my @tables = qw( patients referral_sources diagnoses request_status );
        my $relationships = $self->get_relationships(\@tables);
        my @query = (
            id => \@request_ids,
            'request_status.status_option.description' => $report_status,
        );
        my @params = (
            query => \@query,
            require_objects => $relationships,
#            sort_by => 'created_at', # _has_ to be a t1 col if using require_objects
        );

        my $data = LIMS::DB::Request::Manager->get_requests(@params);
        return $data;
    }
}

#-------------------------------------------------------------------------------
sub update_request_dispatch_log {
    my $self = shift;
    my $data = shift;

    my $request_id = $data->{request_id};
    my $recipient  = $data->{recipient};
    my $action     = 'dispatched report to ' . $recipient;

    my $server_name = $self->lims_cfg->{settings}->{server_username};

    # get username of server:
    my $user_id = LIMS::DB::User->new(username => $server_name)->load->id;

    my $update = sub {
        LIMS::DB::RequestDispatchLog->new(
            request_id => $request_id,
            recipient  => $recipient,
        )->save;
        LIMS::DB::RequestHistory->new(
            request_id => $request_id,
            user_id    => $user_id,
            action     => $action,
        )->save;
    };

    my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

    my $ok = $db->do_transaction($update);
	# don't need return value unless error:
    return $ok ? 0 : 'update_request_dispatch_log() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub update_request_diagnosis_history {
    my $self = shift;
    my $data = shift; # $self->debug( $data );

	my $o = LIMS::DB::RequestDiagnosisHistory->new(id => $data->{id})
		->load(with => 'option');

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $action = 'updated diagnosis error code ' . $o->option->option_name;

    $self->add_to_actions($action);
    { # for do_request_history, just needs _request_id:
        my %h = ( _request_id => $o->request_id );
        $self->form_data(\%h);
    }

	my $update = sub {
		$o->option_id($data->{option_id});
		$o->save;
		$self->do_request_history();
	};
	my $ok = $db->do_transaction($update);

	# don't need return value unless error:
    return $ok ? 0 : 'update_request_diagnosis_history() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub update_request {
	my ($self, $form_data) = @_; # use Data::Dumper; # warn Dumper $form_data;

	# get original data from session (and store it in $self->frozen_data):
	my $request_id = $form_data->{_request_id};
	my $original_data = $self->_get_original_data($request_id);

    my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update_request = sub {
		# referrer_code (only submitted if field edited):
		if ( $form_data->{referrer_code} ) {
			my $original_referrer_code = $self->frozen_data->{referrer_code};

			if ( $form_data->{referrer_code} ne $original_referrer_code ) {
				$self->do_referrer_update($form_data);
			} # warn "$form_data->{referrer_code} ne $original_referrer_code";
		}
		# specimen_code (always submitted):
		{
			my $original_specimen_code = $self->frozen_data->{specimen_code};

			if ( $form_data->{specimen_code} ne $original_specimen_code ) {
				$self->do_specimen_code_update($form_data);
			} # warn "$form_data->{specimen_code} ne $original_specimen_code";
		}
        { # specimen taken date:
			no warnings 'uninitialized'; # either original or form params can be undef
            my $original = $self->frozen_data->{specimen_date};

            my @params = qw(year month day hour minute);
            if ( grep { $form_data->{$_} != $original->{$_} } @params ) {
                $self->do_specimen_date_update($form_data);
                # warn Dumper [$form_data, $original];
            }
        }
		# clinical trial:
		{
			no warnings 'uninitialized'; # either original or form params can be undef
			my $original_trial_id = $self->frozen_data->{trial_id};

			if ( $form_data->{trial_id} != $original_trial_id ) {
				$self->do_clinical_trial_update($form_data);
			}
		}
		# external reference:
		{
			no warnings 'uninitialized'; # either original or form param can be undef
			my $original_external_ref = $self->frozen_data->{external_reference};

			if ( $form_data->{external_reference} ne $original_external_ref ) {
				$self->do_external_ref_update($form_data);
			}
		}
		# trial number:
		{
			no warnings 'uninitialized'; # either original or form params can be undef
			my $original_trial_number = $self->frozen_data->{trial_number};

			if ( $form_data->{trial_number} ne $original_trial_number ) {
				$self->do_trial_number_update($form_data);
			}
		}
		# request_options:
		{
			no warnings 'uninitialized'; # any of form params or original data can be undef
			# get list of all additional options:
			my $request_options
				= LIMS::DB::AdditionalOption::Manager->get_additional_options;

			my $frozen = $self->frozen_data; # warn Dumper $frozen;

			# hash for new request options:
			my %new_request_options = ();

			foreach (@$request_options) {
				my $option   = $_->option_name; # warn Dumper $option;
				my $original = $frozen->{$option} || '';

				$new_request_options{$_->id}{new}  = $form_data->{$option}; # 1 or undef
				$new_request_options{$_->id}{old}  = $original; # old value
				$new_request_options{$_->id}{name} = $option;
			} # warn Dumper \%new_request_options;

			if (%new_request_options) {
				$self->do_request_options_update($form_data, \%new_request_options);
			}
		}
		# request_consent:
		{
			no warnings 'uninitialized'; # any of form params or original data can be undef
			# get list of all additional options:
			my $request_consent
				= LIMS::DB::ConsentOption::Manager->get_consent_options;

			my $frozen = $self->frozen_data; # warn Dumper $frozen;

			# hash for new request consent:
			my %new_request_consent = ();

			foreach (@$request_consent) {
				my $consent_name = $_->consent_name;

				$new_request_consent{$_->id}{new}  = $form_data->{$consent_name}; # yes, no or undef
				$new_request_consent{$_->id}{old}  = $frozen->{$consent_name}; # old value
				$new_request_consent{$_->id}{name} = $consent_name;
			} # warn Dumper \%new_request_consent;

			if (%new_request_consent) {
				$self->do_request_consent_update($form_data, \%new_request_consent);
			}
		}

		# update error code & history log:
		$self->do_request_error_code($form_data);
		$self->do_history_log($form_data);
	};

#$self->set_rose_debug(1);
	my $ok = $db->do_transaction( $update_request );
#$self->set_rose_debug(0);

	# return value needs to match format in update_patient_case():
    return $ok
        ? { success => $ok }
        : { error   => 'update_request() error - ' . $db->error };
}

#-------------------------------------------------------------------------------
sub auto_unlock { return shift->unlock_request(@_, 1) } # from storage module

#-------------------------------------------------------------------------------
sub unlock_request {
	my ($self, $request_id, $auto) = @_; # auto is optional - from auto_unlock()

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $unlock = sub {
		my $o = LIMS::DB::Request->new(id => $request_id)->load;

=begin # would need to manually reset status to locked, reverted to timestamp:
		# update request_status:
		my $status_otions_map = $self->request_status_options_map;

		my $status_option_id
			= $status_otions_map->{authorised}->{is_active} eq 'yes'
			? $status_otions_map->{authorised}->{id}
			: $status_otions_map->{reported}->{id};

		$o->status_option_id($status_option_id);
=cut
		$o->updated_at($self->time_now);
		$o->save(changes_only => 1);

		my $action = $auto # from storage module
			? 'auto-unlocked record'
			: 'unlocked record';

		LIMS::DB::RequestHistory->new(
			request_id => $request_id,
			user_id    => $self->user_profile->{id},
			action     => $action,
		)->save;
	};

#$self->set_rose_debug(1);
	my $ok = $db->do_transaction($unlock);
#$self->set_rose_debug(0);

	# don't need return value unless error:
    return $ok ? 0 : 'unlock_request() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub delete_request {
	my $self = shift;
	my $data = shift; # $self->debug($data); # return;

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $request_id = $data->{request_id};

	my $request = LIMS::DB::Request->new(id => $request_id)
		->load(with => ['patient_case.patient', 'request_report.diagnosis']);

	my %current_action = (
		user_id => $self->user_profile->{id},
		time 	=> $self->time_now(),
		action 	=> sprintf 'deleted record (%s)', $data->{reason},
	);

	my $delete = sub {
		# retrieve all history data for archiving before cascade delete:
		$self->_archive_request_history($request); # warn Dumper $self->archive;
		# add current  action (delete):
		$self->add_to_archive(\%current_action);

		# sort archive into datetime order:
		my @chronological = sort {
			DateTime->compare($a->{time}, $b->{time})
		} $self->archived_data; # warn Dumper \@chronological;

		# save to deleted_requests table:
		for my $entry (@chronological) { # warn Dumper $data;
			LIMS::DB::DeletedRequest->new(
				request_id 		=> $request_id,
				request_number 	=> $request->request_number,
				year 			=> $request->year,
				action 			=> $entry->{action},
				user_id 		=> $entry->{user_id},
				time 			=> $entry->{time},
			)->save;
		}
		# delete patient records also - not yet implemented due to pateint_demograhics, outreach, etc
		if ( $data->{delete_patient_record_DISABLED} ) { # delete patient also:
			my $patient_case_id = $request->patient_case_id;
			my $patient_id      = $request->patient_case->patient_id;
			# co-deletes request during cascade:
			LIMS::DB::PatientCase->new(id => $patient_case_id)->delete(cascade => 1);
			LIMS::DB::Patient->new(id => $patient_id)->delete(cascade => 1);
		}
		else {
			LIMS::DB::Request->new(id => $request_id)->delete;
			# (cascade => 'delete'); using ON DELETE CASCADE in sql (but doesn't actually do it)
		}
	};
#$self->set_rose_debug(1);
	my $ok = $db->do_transaction($delete);
#$self->set_rose_debug(0);

	# don't need return value unless error:
    return $ok ? 0 : 'delete_request() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub _archive_request_history {
	my ($self, $request) = @_;

	# common to all queries:
	my %args = ( query => [ request_id => $request->id ] );

	{ # request error_code:
		local $args{require_objects} = 'error_code'; # warn Dumper \%args;

		my $o = LIMS::DB::RequestErrorCode::Manager->get_request_error_codes(%args);
		for (@$o) { # warn Dumper $_->as_tree;
			my $data = $self->_format_data_for_archive($_);
			# format action:
			$data->{action} = 'recorded error code ' . $_->error_code->code;
			$self->add_to_archive($data);
		}
	}
	{ # request_history:
		my $o = LIMS::DB::RequestHistory::Manager->get_request_histories(%args);
		for (@$o) {
			my $data = $self->_format_data_for_archive($_);
			# format action:
			my $action = $_->action; # warn Dumper $data;
			if ($action eq 'reported') { # get diagnosis:
				$action .= sprintf ' (diagnosis = %s)',
					$request->request_report->diagnosis->name;
			}
			elsif ($action eq 'registered') {
				my $patient = $request->patient_case->patient;
				$action .= sprintf ' (H%s/%s, %s, %s, %s)',
					$request->request_number,
					$request->year - 2000,
					$patient->last_name,
					$patient->first_name,
					$patient->dob ? $patient->dob->ymd : 'NULL';
			}
			$data->{action} = $action;
			$self->add_to_archive($data);
		}
	}
	{ # request_diagnosis_history:
		local $args{require_objects} = [ qw(diagnosis option) ];

		my $o = LIMS::DB::RequestDiagnosisHistory::Manager
			->get_request_diagnosis_histories(%args);

		for (@$o) {
			my $data = $self->_format_data_for_archive($_);
			# format action:
			$data->{action} = sprintf 'amended diagnosis = %s; reason = %s',
				$_->diagnosis->name, $_->option->option_name;
			$self->add_to_archive($data);
		}
	}
	{ # request_phonelog:
		my $o = LIMS::DB::RequestPhoneLog::Manager->get_request_phone_log(%args);
		for (@$o) {
			my $data = $self->_format_data_for_archive($_);
			# format action:
			$data->{action} = join '; ', $_->status, $_->contact, $_->details;
			$self->add_to_archive($data);
		}
	}
}

#-------------------------------------------------------------------------------
# returns common data items user_id & time:
sub _format_data_for_archive {
	my $self = shift;
	my $data = shift;

	my %data = (
		user_id => $data->user_id,
		time    => $data->time,
	);
	return \%data;
}

#-------------------------------------------------------------------------------
sub update_patient_case {
=begin # how it works:
scope determines whether to apply change to single record (default) or to all records.

1) Get a new patient_case.id - 'use_patient_case_id' param if submitted, otherwise
find existing combination of submitted patient_id, referral_source_id & unit_number
in patient_case table, or create a new patient_case.

2) If scope = all (or if only 1 record attached to patient_case), change all
instances of requests.patient_case_id to new value & delete old patient_case entry

3) If scope = single record, just change patient_case_id for single request.id

4) If referral_source is changed, requests.referrer_department_id may be incorrect,
so unless parent_organisation is same as old, requests.referrer_department_id
is updated to a new one if found, or to the entry corresponding to unknown referrer
(clinician or gp, if not already), pending referrer change.
=cut
	my ($self, $form_data) = @_; # warn 'form_data:'; warn Dumper $form_data; # return;

	my $request_id = $form_data->{_request_id};

	# get original data from session (and store it in $self->frozen_data):
	my $original_data = $self->_get_original_data($request_id); # warn 'orginal_data:'; warn Dumper $original_data;

    my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $i = 0; # successful updates counter

	my $update_patient_case = sub {
		# get new patient_case_id:
		my $new_patient_case_id = $self->_get_new_patient_case_id($form_data)
		|| die 'no patient_case_id returned by _get_new_patient_case_id()';

		# protect against old patient_case_id == new patient_case_id, where 'old'
		# patient_case gets deleted if scope set to 'all':
		return 0 unless $new_patient_case_id != $original_data->{patient_case_id};

		if ($form_data->{scope} eq 'all') { # warn 'all';
			{ # update requests table:
				my %args = (
					set   => { patient_case_id => $new_patient_case_id },
					where => [ patient_case_id => $original_data->{patient_case_id} ],
				);
				$i += LIMS::DB::Request::Manager->update_requests(%args);
			}
			{ # delete old patient_case:
				my $patient_case_id = $original_data->{patient_case_id};
				LIMS::DB::PatientCase->new(id => $patient_case_id)->delete();
			}
		}
		else { # just update single record:
			my $o = LIMS::DB::Request->new(id => $request_id)->load;
			$o->patient_case_id($new_patient_case_id); # warn 'one';
			$i += 1 if $o->save(changes_only => 1); # $i gets memory address on success ??
		}

		# might need to update referrer department if new referral source submitted:
		if ( my $new_referral_source_id = $form_data->{referral_source_id} ) {
			if ( $new_referral_source_id != $original_data->{referral_source_id} ) {
				$self->do_referrer_department_update($form_data);
			}
		}

		$self->do_patient_case_history($form_data);
	};

#$self->set_rose_debug(1);
	my $ok = $db->do_transaction($update_patient_case); # warn $i; # warn Dumper $db->error;
    # or can do: $db->do_transaction( sub { $result = $update_patient_case->() } );
#$self->set_rose_debug(0);

	# return hashref of db error (if any), or numerical value of success (updates count):
	return $ok
        ? { success => $i }
        : { error   => 'update_patient_case() error - ' . $db->error };
}

#-------------------------------------------------------------------------------
sub get_first_request_date {
	my $self = shift;

    my $first_request = LIMS::DB::Request->new(id => 1)->load(speculative => 1);
    $first_request->created_at if $first_request;
}

#-------------------------------------------------------------------------------
sub _get_new_patient_case_id {
	my ($self, $form_data) = @_;

	# patient_case_id might be submitted by 'use this' radio button:
	my $patient_case_id = $form_data->{use_patient_case_id} || '';

	# if $form_data patient_case_id used, original values are submitted in form
	# fields so need to get new values into $form_data to replace original ones:
	if ($patient_case_id) {
		my $patient_case = LIMS::DB::PatientCase->new(id => $patient_case_id)
			->load(with => 'referral_source');

		map {
			$form_data->{$_} = $patient_case->$_;
		} qw(unit_number referral_source_id);

		$form_data->{_location_name} = $patient_case->referral_source->display_name;
	}
	# if we don't already have a patient_case_id, go and get one:
	else {
		# find matching patient_case, or create new:
		my $patient_case = $self->get_patient_case($form_data);
		$patient_case_id = $patient_case->id;
	}

	return $patient_case_id;
}

#-------------------------------------------------------------------------------
sub _get_original_data {
	my ($self, $this_request_id) = @_;

	my $lab_no = sub { # to retrieve lab number if request id's don't match
		my $r = LIMS::DB::Request->new(id => shift)->load;
		join '/', $r->request_number, sprintf '%.02d', $r->year - 2000;
	};

	# retrieve original data from session:
	my $session_data = $self->session_data('_request_edit_data'); # warn Dumper $original_data;

	# check original request_id matches submitted request_id (in case 2nd tab
	# used between 1st & 2nd part of update procedure):
	my $session_request_id = $session_data->{request_id};
        # warn Dumper [$session_request_id, $this_request_id ];
	unless ( $session_request_id == $this_request_id ) {
		my $retrieved_lab_number = &$lab_no($session_request_id);
		my $expected_lab_number  = &$lab_no($this_request_id);
		my $msg = sprintf 'session data belongs to a different request '
		. '(expected %s, retrieved %s). Has a 2nd tab been used for '
		. 'update? Please restart request edit for %s ***from the beginning***',
			$expected_lab_number, $retrieved_lab_number, $expected_lab_number;
		die $msg;
	}
	# put original data into frozen_data():
	$self->frozen_data($session_data); # warn Dumper $original_data->{_data};

=begin # don't do this - causes fatal error if back button used & then data resubmitted
	# clear session data (not required as it's overwritten anyway, but tidier):
	# $self->clear_data('_request_edit_data');
=cut
	return $session_data;
}

#-------------------------------------------------------------------------------
sub _verify_request_exists {
	my ($self, $request_id) = @_; # warn $request_id;

	my @q = (id => $request_id);
	return LIMS::DB::Request::Manager->get_requests_count( query => \@q );
}

#-------------------------------------------------------------------------------
sub _get_request_data {
	my $self = shift;
	my $data = shift;

    # get referrer_department.id for supplied referral source & referrer code:
    my $referrer_department = $self->_get_referrer_department($data);
	$data->{referrer_department_id} = $referrer_department->id;

	my %request_data = map {
		$_ => $data->{$_};
	} qw( request_number patient_case_id referrer_department_id );

	# current year:
    # $request_data{year} = DateTime->now->year; # done by DB::Request meta data - nope:
    $request_data{year} = LIMS::Local::Utils::this_year(); # DB classes only loaded once

=begin # not using this method anymore
	{ # check for previously deleted request_number/year combination, if so use request.id:
		my %args = (
			request_number => $data->{request_number},
			year => DateTime->now->year,
		);
#$self->set_rose_debug(1);
		my $deleted_request
			= LIMS::DB::DeletedRequest->new(%args)->load(speculative => 1);
#$self->set_rose_debug(0);
		if ($deleted_request) {
			$request_data{id} = $deleted_request->request_id;
		}
	}
=cut
	return \%request_data;
}

#-------------------------------------------------------------------------------
sub _get_referrer_department {
	my $self = shift;
	my $data = shift; # warn Dumper $data;

	my $referrer
		= LIMS::DB::Referrer->new(national_code => $data->{referrer_code})->load;

	my $referral_source
		= LIMS::DB::ReferralSource->new(id => $data->{referral_source_id})
			->load(with => 'referral_type'); # get referral_type for possible use later;

    # get referrer_department for supplied referral source & referrer code:
	my %args = (
		referrer_id => $referrer->id,
		parent_organisation_id => $referral_source->parent_organisation_id,
	);

	my $referrer_department
		= LIMS::DB::ReferrerDepartment->new(%args)->load(speculative => 1);

	# if no $referrer_department, get referrer_department.id for unknown referrer of correct type:
	if (! $referrer_department ) { # warn 'here';
		# get map between referral_type.id & referrer_department.id for unknown locations:
		my $referral_type_map = $self->referral_type_map; # warn Dumper $referral_type_map;

		# get id of default referrer_department for this location type (hospital or practice):
		my $referrer_department_id
			= $referral_type_map->{$referral_source->referral_type_id};

		$referrer_department = LIMS::DB::ReferrerDepartment
			->new(id => $referrer_department_id)->load; # warn Dumper $referrer_department->as_tree;
    }

	return $referrer_department;
}

#-------------------------------------------------------------------------------
sub _build_request_status_options_map {
	my $self = shift;

	my $status_options = LIMS::DB::StatusOption::Manager->get_status_options;

	my %map = map {
		$_->description => $_->as_tree;
	} @$status_options; # warn Dumper \%map;

	return \%map;
}

#-------------------------------------------------------------------------------
# creates map between referral_type.id and referrer_department.id for unknown locations:
sub _build_referral_type_map {
	my $self = shift;

	my %args = ( # using 2 custom relationships in ReferralType & ParentOrg classes:
		require_objects => 'unknown_parent_org.unknown_referrer_department',
	);

	# get referral_types:
	my $referral_types
		= LIMS::DB::ReferralType::Manager->get_referral_types(%args);

=begin # effective sql for ReferralType::Manager->get_referral_types():
SELECT
  t1.id as 'referral_type_id',
  t3.id as 'referrer_department_id'
FROM
  referral_types t1
  JOIN parent_organisations t2 ON (t1.default_unknown = t2.parent_code)
  JOIN referrer_department t3 ON (t2.id = t3.parent_organisation_id)
=cut

	# create map:
	my %referral_type_map = map {
		$_->id => $_->unknown_parent_org->unknown_referrer_department->id;
	} @$referral_types; # warn Dumper \%referral_type_map;

	return \%referral_type_map;
}

#-------------------------------------------------------------------------------
# warning: method of same name exists in C::Roles::DataMap
# returns hash of arrayrefs
sub _build_specimen_lab_test_map {
	my $self = shift;

	my $o = $self->get_objects('SpecimenLabTest');

	my %map;

	for (@$o) {
		my $specimen_id = $_->specimen_id; # warn $specimen_id;
		my $lab_test_id = $_->lab_test_id; # warn $lab_test_id;

		push @{ $map{$specimen_id} }, $lab_test_id;
	} # warn Dumper \%map;

	return \%map;
}

#-------------------------------------------------------------------------------
# only need this in new_request() to see why rare null request_specimen entry
sub _build_specimen_map {
	my $self = shift;
	my $o = $self->get_objects('Specimen');
	my %h = map { $_->sample_code => $_->id } @$o; # need LC for input matching
	return \%h;
}

#-------------------------------------------------------------------------------
# *** method of similar name in Role::RequestUpdate ***
sub _get_clinical_trial_data {
	my $self = shift;
	my $data = shift;

	# no need for db access if no trial_id:
	return unless $data->{trial_id};

	my $patient_case = LIMS::DB::PatientCase->new(
		id => $data->{patient_case_id}
	)->load;

	my %trial_data = (
		trial_id     => $data->{trial_id},
		trial_number => $data->{trial_number},
		patient_id   => $patient_case->patient_id,
	);

	return \%trial_data;
}

1;
