• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Controller::Admin::Patient::Merge;

use base 'LIMS::Base';

use Moose;
with (
	'LIMS::Controller::Roles::SearchConstraint', # generate_search_constraints()
	'LIMS::Controller::Roles::SessionStore',
);

__PACKAGE__->meta->make_immutable(inline_constructor => 0);

use LIMS::Local::Utils;

use Data::Dumper;

#-------------------------------------------------------------------------------
sub default : StartRunmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);
	my $errs = shift; # $self->stash( errs => $errs );
	
	return $self->forbidden() unless $self->user_can('patient_merge');

    $self->js_validation_profile('patient_merge');

	return $self->tt_process($errs);
}

#-------------------------------------------------------------------------------
sub search : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);
	
	return $self->forbidden() unless $self->user_can('patient_merge');

    my $dfv = $self->check_rm( 'default', $self->validate('patient_merge') )
    || return $self->dfv_error_page;

    my $data = $dfv->valid; # $self->debug($data);	

	unless ( $self->get_current_runmode eq 'do_merge' ) { # ie re-direct
		# store params in session to save multiple hidden fields:
		my $vars = $self->query->Vars(); # need scalar context to get hashref
		$self->session_store_form_data($vars);
	}
	
	# protect against submission of empty form:
    my $search_constraints = $self->generate_search_constraints($data) 
    || return $self->forward('default'); # $self->debug($search_constraints);
	
	my $records = $self->_get_records_for_merge($search_constraints);
	$self->tt_params( records => $records ); # warn Dumper $records;
	
	my $count = scalar @$records; # warn $count;
	if ( $count > 50 ) {
		my $msg = sprintf $self->messages('patient')->{merge}->{too_many}, $count;
		$self->flash( warning => $msg );
		# return $self->forward('default');	# probably not - would prevent merge
		# on patient with high number of follow-ups - so just set flash msg
	}
	
	if ($count) { # warn Dumper $_->as_tree for @$records;
		# get list of unique patients sorted according to sort_by input:
		my $patients = $self->_sort_patients($records);		
		$self->tt_params( patients => $patients );
	}
	else {
		# just set flash warning:
		$self->flash( info => $self->messages('search')->{no_records_found} );		
	}

	return $self->tt_process('admin/patient/merge/default.tt');
}

#-------------------------------------------------------------------------------
# returns array(ref) of hashrefs of flattened RDBO::Manager objects
sub _get_records_for_merge {
	my ($self, $search_constraints) = @_;
	
	# RDBO::Manager object containing patient_case arrays of request arrays:
	my $o = $self->model('Patient')->get_records_for_merge($search_constraints);
	my $cloner = sub { LIMS::Local::Utils::clone(@_) };
	my $delta  = sub { LIMS::Local::Utils::delta_business_days(@_) };

	my $today = LIMS::Local::Utils::today->ymd('-');

	# get array of hashes (patient data, location, unit_no, labno, diagnosis, reported)
	my @records;
	REF: for my $ref (@$o) { # warn Dumper $ref; # ref contains arrays of arrays
		my %h = (); # reset
		$h{patient}{$_} = $ref->$_ for
			qw(id last_name first_name middle_name nhs_number gender dob); # warn Dumper \%h;

		# get patient_case (an array of PatientCase objects):
		my $patient_case = $ref->patient_case; # warn Dumper $patient_case; # AoH
		CASE: for my $case (@$patient_case) { # warn ref $case; # hashref
			my $c = &$cloner(\%h); # $self->debug($c); # hashref
			$c->{patient}{patient_case} = $case->as_tree;

			# get request data or add patient data:
			my $request = $case->{request} || []; # must exists as arrayref
			if ( not @$request ) { push @records, $c; next CASE }

			for my $req (@$request) { # warn Dumper $req;
				my $d = &$cloner($c); # $self->debug($d); # hashref
				$d->{request} = $req;
				{ # calculate age of report in delta business days:
					my $report_date = $req->created_at->ymd('-') || $today; # deflate
					$d->{request}{delta_report} = &$delta($report_date, $today);
				} # warn Dumper $d;
				push @records, $d;
			}
		}
	} # warn Dumper \@records;
	return \@records;
}

#-------------------------------------------------------------------------------
sub do_merge : Runmode {
    my $self = shift; $self->_debug_path($self->get_current_runmode);
	
	return $self->forbidden() unless $self->user_can('patient_merge');
	
	my $params = $self->query->Vars(); # $self->debug($params);	
	{ # need to put original search params back into query for forward to search():
		my $search_params = $self->session->param('_patient_merge_data');
		while ( my ($param, $val) = each %$search_params ) {
			$self->query->param($param, $val);
		}
	}
	
	# initialise data structure to hold 'to' & 'from' data:
	my $data = {
		from => [], # can be array of 1 or more patient_case_id's
		to   => [], # must ONLY have array size of 1 
	};
	
	PARAM: # sort form params into %$data hash:
	while ( my($patient_case_id, $direction_of_change) = each %$params ) {
		# skip irrelevant form params:
		next PARAM unless grep $direction_of_change eq $_, qw(from to);
		
		my $list = $data->{$direction_of_change}; # ie 'to' or 'from' key
		push @$list, $patient_case_id;
	} # $self->debug($data);

	# check we have AT LEAST one 'from' & ONLY one 'to':
	unless ( scalar (@{ $data->{from} }) >= 1 && scalar (@{ $data->{to} }) == 1 ) {
		$self->flash( warning => $self->messages('patient')->{merge}->{not_flagged} );
		return $self->search();	# don't use forward() here - need to keep current rm
	}
	
	# require confirmation:
	unless ( $self->query->param('confirm_merge') ) {
		return $self->_generate_merge_confirmation($data);
	}
	
	# add scope param to $data:
	$data->{scope} = $self->query->param('scope');

	my $rtn = $self->model('Patient')->merge_patients($data);
	
	if ($rtn) {
		return $self->error($rtn);
	}
	else {
		$self->flash( info => $self->messages('patient')->{merge}->{merge_success} );
		return $self->search();	# don't use forward() here - need to keep current rm
	}
}

#-------------------------------------------------------------------------------
sub _generate_merge_confirmation {
	my $self = shift; $self->_debug_path();
	my $data = shift;
	
	{ # from:
		my @ids = @{ $data->{from} };	
		my $cases = $self->model('PatientCase')->get_patient_cases(\@ids);
		$self->tt_params( merge_from => $cases );
	}
	{ # to:
		my ($id) = @{ $data->{to} };
		my $case = $self->model('PatientCase')->get_patient_case($id);	
	
		$self->tt_params( merge_to => $case );
	}
	
	return $self->tt_process('admin/patient/merge/confirm.tt');
}

#-------------------------------------------------------------------------------
# get list of unique patients sorted according to sort_by input:
# possible sorts: id, name, dob, unit_no, nhs_no, count:
sub _sort_patients {
	my ($self, $records) = @_; $self->_debug_path();
	
	# extract unique patients from $records arrayref:
	my %unique_patients; # as hash to eliminate duplicates
	for (@$records) { # hashref of patient, location and request hashrefs:
		my $patient = $_->{patient}; # warn Dumper $patient;
		my $patient_id = $patient->{id};
		
		$unique_patients{$patient_id}{count}++; # auto increment
		# convert patient_case object to hashref for clarity downstream:		
		$unique_patients{$patient_id}{patient} ||= $patient;
	}; # warn Dumper \%unique_patients;

	# sort order supplied by user, or default to patient_id:
	my $sort_by = $self->query->param('sort_by') || 'patient_id'; # warn $sort_by;

	# dispatch table of sort methods:
	my %methods = (
		dob	        => \&_sort_by_dob,
		name        => \&_sort_by_name,
		count       => \&_sort_by_count,
		nhs_number  => \&_sort_by_nhs_number,
		patient_id  => \&_sort_by_patient_id,
		unit_number => \&_sort_by_unit_number,		
	);
	
	# get required sort_method:
	my $sort_method = $methods{$sort_by};
	
	# pass \%unique_patients to the required sort method & get sorted list of
	# patient.id's back:
	my $patient_ids = $sort_method->(\%unique_patients);
	
	# create an array of patient data hashrefs, sorted according to @ids:
	my @sorted_patients = map $unique_patients{$_}, @$patient_ids;
	return \@sorted_patients;
}

sub _sort_by_dob {
	my $unique_patients = shift;
	
	my $NULL = DateTime->now; # need a datetime object for null dob's
	
	my @ids = sort {
		my $A = $unique_patients->{$a}{patient}{dob} || $NULL; 
		my $B = $unique_patients->{$b}{patient}{dob} || $NULL;
			
		DateTime->compare( $A, $B );			
	} keys %$unique_patients; 

	return \@ids;
}

sub _sort_by_name {
	my $unique_patients = shift;

	my @ids = sort {
		my $A_LN = $unique_patients->{$a}{patient}{last_name};
		my $B_LN = $unique_patients->{$b}{patient}{last_name};
			
		my $A_FN = $unique_patients->{$a}{patient}{first_name};
		my $B_FN = $unique_patients->{$b}{patient}{first_name};
			
		$A_LN cmp $B_LN || $A_FN cmp $B_FN;
	} keys %$unique_patients; 

	return \@ids;
}

sub _sort_by_unit_number {
	my $unique_patients = shift;

	my @ids = sort {
		$unique_patients->{$a}{patient}{unit_number}
			cmp
		$unique_patients->{$b}{patient}{unit_number}
	} keys %$unique_patients;
	
	return \@ids;
}
	
sub _sort_by_nhs_number {			
	my $unique_patients = shift; # warn Dumper $unique_patients;

	my @ids = sort {
		my $A = $unique_patients->{$a}{patient}{nhs_number} || 0;
		my $B = $unique_patients->{$b}{patient}{nhs_number} || 0;

		$A <=> $B;
	} keys %$unique_patients;
	
	return \@ids;
}

sub _sort_by_count {
	my $unique_patients = shift;

	my @ids = sort {
		$unique_patients->{$a}{count} <=> $unique_patients->{$b}{count};
	} keys %$unique_patients;
	
	return \@ids;
}

sub _sort_by_patient_id { # default if nothing supplied
	my $unique_patients = shift; 
	
	return [ sort { $a <=> $b } keys %$unique_patients ];
} 

1;