• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Model::Request;

use Moose;
extends 'LIMS::Model::Base';
with (
    'LIMS::Model::Roles::Query',
    'LIMS::Model::Roles::DBIxSimple',
	'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);
        $request->save;

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

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

			LIMS::DB::RequestSpecimen->new(
				request_id  => $request->id,
				specimen_id => $o->id,
			)->save;
			
            # add new lab-tests if specimen requires:
            my %data = (
                request_id => $request->id,
                specimen   => $o,
            );
            $self->do_specimen_associated_lab_tests(\%data); # 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;			
		}
		
        $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}) {
            $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_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 $formatted_args
		= $self->get_args_for_requests_count($search_constraints); # warn Dumper $formatted_args;
		
#$self->set_rose_debug(1);	
    my $total = LIMS::DB::Request::Manager->get_requests_count(%$formatted_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;
}

#-------------------------------------------------------------------------------
# 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
		request_external_ref
		hospital_departments
		request_general_notes
		request_initial_screen
		request_gross_description
	);

	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)
	
	# require data from these tables:
	my @tables = qw( patients diagnoses );
	
	my $relationships = $self->get_relationships(\@tables);
	
	my %params = (
		query => [ %$args ],
		require_objects => $relationships,
		sort_by => 'year DESC, request_number DESC',
		nested_joins => 0,
	);
	
	my $records = LIMS::DB::Request::Manager->get_requests_iterator(%params);
	
	return $records;
}

#-------------------------------------------------------------------------------
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_report_diagnosis {
	my ($self, $request_id) = @_; # warn $request_id;

	my %args = (
		query => [ request_id => $request_id ],
		require_objects => 'request_report.diagnosis',
	);
	
	my $request_diagnosis =
		ref $request_id eq 'ARRAY' # can handle either single or list
			? LIMS::DB::Request::Manager->get_requests(%args)
			: LIMS::DB::Request->new(request_id => $request_id)
				->load(with => 'request_report.diagnosis');
			
	return $request_diagnosis;
}

#-------------------------------------------------------------------------------
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 ],
		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;
	
	my %args = ( _request_id => $data->{request_id} ); # do_request_error_code() format

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

	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 $duration = $args->{duration};
	my $org_code = $args->{org_code}; # optional - not supplied for 'all locations'
    
	my $delta =
		$self->time_now->subtract( days => $duration )->truncate( to => 'day' );
	
	# set status level required for displaying reports:
	my $report_status = $self->does_authorisation() ? 'authorised' : 'reported';

    my @query = (
		'request_report.status'	 => { ne => 'default' },
		'request_history.time'   => { ge => $delta },
		'request_history.action' => $report_status, # reported or authorised        
    );
    push @query, ( parent_code => $org_code ) if $org_code; # ie not 'all locations'
    
	my @tables = qw( patients diagnoses parent_organisations request_history );
	my $relationships = $self->get_relationships(\@tables);
	
	my @params = (
		query => \@query,
		require_objects => $relationships,
		sort_by => 'created_at', # _has_ to be a t1 col if using require_objects
	);
	
	my $cases = LIMS::DB::Request::Manager->get_requests(@params);	
	return $cases;
}

#-------------------------------------------------------------------------------
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 {
	my ($self, $form_data) = @_; # use Data::Dumper; # warn Dumper $form_data;
	
	# get original data from session (and store it in $self->frozen_data):
	my $original_data = $self->_get_original_data;
	
    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";
		}
		# 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 unlock_request {
	my ($self, $request_id) = @_;
	
	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);
		
		LIMS::DB::RequestHistory->new(
			request_id => $request_id,
			user_id    => $self->user_profile->{id},
			action     => 'unlocked record',
		)->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;			
		}

		LIMS::DB::Request->new(id => $request_id)->delete;
			# (cascade => 'delete'); using ON DELETE CASCADE in sql
		
	};
#$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 ' (%s, %s, %s)',
					$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;
	
	# get original data from session (and store it in $self->frozen_data):
	my $original_data = $self->_get_original_data; # 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 => $form_data->{_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 = shift;
	
	# put original data into frozen_data():
	my $original_data = $self->session_data('_request_edit_data');
	$self->frozen_data($original_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 $original_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;

__END__
multi_many_ok is used to suppress:
WARNING: Fetching sub-objects via more than one "one to many" relationship in a
single query may produce many redundant rows, and the query may be slow. If
you're sure you want to do this, you can silence this warning by using the
"multi_many_ok" parameter