• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Model::Request;

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

has frozen_data => ( is => 'rw', isa => 'HashRef');
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(	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; # DEBUG $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();

	# split specimens on comma and/or space(s):
    my @specimens = split /\,\s?|\s+/, $data->{specimen}; # DEBUG \@specimens;

	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;

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

			LIMS::DB::RequestSpecimen->new(
				request_id  => $request->id,
				specimen_id => $o->id,
			)->save;
			
			# any auto-generated specimen-associated lab-tests ?
			if ( my $lab_test_ref = $specimen_lab_test_map->{$o->id} ) { 
				map { # generate lab-test request(s):
					$self->do_new_lab_test({ 
						_request_id  => $request->id, # method required underscored var
						lab_test_id => $_,
					});
				} @$lab_test_ref;
			}
		}

		# 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 ];
				
			for (@$codes) {
				$data{error_code_id} = $_;
				LIMS::DB::RequestErrorCode->new(%data)->save;	
			}
		}
		
		# 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;			
		}
		
		# request_history:
		LIMS::DB::RequestHistory->new(
            request_id  => $request->id,
            user_id     => $user_id,
            action      => 'registered',
        )->save;
    };

    # 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 get_previous_diagnosis_count {
    my ($self, $request_id) = @_;
	
	my %args = (
		query => [ request_id => $request_id ],
	);
	
	my $count = LIMS::DB::RequestDiagnosisHistory::Manager
		->get_request_diagnosis_histories_count(%args);
		
	return $count;
}

#-------------------------------------------------------------------------------
# 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);

    return $request->[0]->id;
}

#-------------------------------------------------------------------------------
# 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);
	
#$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
		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;
}

#-------------------------------------------------------------------------------
# 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;
}

#-------------------------------------------------------------------------------
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 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;	
}

#-------------------------------------------------------------------------------
# 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;
}

#-------------------------------------------------------------------------------
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_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 $org_code = $args->{org_code};
	
	# need org_code = 'xxxxx' OR org_code like 'xxx%':
	my $org_code_expr = length($org_code) < 5
		? { like => $org_code . '%' } # '%%' ok for wild-card
		: $org_code; # ie look for specific location
	
	my $days_ago =
		$self->time_now
			->subtract( days => $args->{duration} )
			->truncate( to => 'day' );
	
	my @tables = qw( patients diagnoses referral_sources request_history );
	
	my $relationships = $self->get_relationships(\@tables);
	
	my $option_authorised
		= LIMS::DB::StatusOption->new(description => 'authorised')->load;

	# set status level required for displaying reports:
	my $report_status = $option_authorised->is_active eq 'yes'
		? 'authorised'
		: 'reported';

	my @params = (
		query => [
			'request_report.status'	 => { ne => 'default' },
			'request_history.time'   => { ge => $days_ago },
			'request_history.action' => $report_status, # reported or authorised
			'referral_sources.organisation_code' => $org_code_expr,
		],
		require_objects => $relationships,
		# sort_by => 'request_history.time', # doesn't work as t1.id gets priority
	);
	
	my $cases = LIMS::DB::Request::Manager->get_requests(@params);
	
	return $cases;
}

#-------------------------------------------------------------------------------
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;
			}
			
			if (%new_request_options) { # warn Dumper \%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;
			
			# 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;
			}
			
			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 $result = $db->do_transaction( $update_request );
#$self->set_rose_debug(0);

	# return value needs to match format in update_patient_case():
	return {
		error   => $db->error ? 'update_request() error - ' . $db->error : undef,
		success => $result, # true on success, false on failure ( & will set $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;
		
		$o->updated_at($self->time_now);
=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->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 get_print_run_request_ids {
	my ($self, $start, $end) = @_;	# start & end datetimes

	my $option_authorised
		= LIMS::DB::StatusOption->new(description => 'authorised')->load;

	# set status level required for printing reports:
	my $status = $option_authorised->is_active eq 'yes'
		? 'authorised'
		: 'reported';

	# get all reports where status = authorised/reported or complete AND
	# (requests.updated_at OR request_report.updated_at) between start & end dates:
	my @query = (
		description => [ $status, 'complete' ], # status options
		or => [
			and => [
				'requests.updated_at' => { ge => $start },
				'requests.updated_at' => { le => $end   },
			],
			and => [
				'request_report.updated_at' => { ge => $start },
				'request_report.updated_at' => { le => $end   },
			],
		],
	);
	
	my %args = (
		query  => \@query,
		select => [ 'id' ], # only need id's
		require_objects => [ qw(request_report status_option) ],
	);
	
	my $requests = LIMS::DB::Request::Manager->get_requests(%args);
	
	my @request_ids = map { $_->id } @$requests;
	return \@request_ids;
}

#-------------------------------------------------------------------------------
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} = 'diagnosis';

		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, $_->reason; 
			$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);
	# this method differs from the usual do_transaction(), which returns 0 on
	# error and 1 on success, even if coderef exits early; not interested in
	# return value now, only number of successful updates, which gets returned to
	# controller, along with $db->error (if any):
	$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), and numerical value of success (updates count):
	return {
		error   => $db->error ? 'update_patient_case() error - ' . $db->error : undef,
		success => $i,
	}
}

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

	return LIMS::DB::Request::Manager->get_requests(limit => 1)->[0]->created_at;
}

#-------------------------------------------------------------------------------
sub _get_hmrn_new_diagnoses_constraints {
	my ($self, $args) = @_;
	
	# if request for single lab number:
	if ( my $lab_number = $args->{lab_number} ) {
		my ($request_number, $year) = LIMS::Local::Utils::split_labno($lab_number);
		
		return [ request_number => $request_number, year => $year ];
	}
	# if date range requested:
	elsif ($args->{date_from}) { # date_from is minimun required to trigger date range
        my $start_date
			= LIMS::Local::Utils::to_datetime_using_datecalc($args->{date_from});
			
		my $end_date
			= $args->{date_to} # date_to is optional
			? LIMS::Local::Utils::to_datetime_using_datecalc($args->{date_to})
			: DateTime->today->ymd; # make it today if not supplied
		# warn Dumper [$start_date, $end_date];
		
		return [
			'request_history.time' => { gt => $start_date },
			'request_history.time' => { le => $end_date },
		];
	}
	else {
		my $days = $args->{duration} || 7; # value for 'previous_week' param & default 
		my $days_ago
			= $self->time_now->subtract( days => $days )->truncate( to => 'day' );
			
		return [ 'request_history.time' => { gt => $days_ago } ];
	}
}

#-------------------------------------------------------------------------------
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) = @_;
	
	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

=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;
}

#-------------------------------------------------------------------------------
# *** 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