• 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 LIMS::Local::Search;

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 %args = ( search_constraints => $search_constraints );
	my $records	= $self->model('Request')->find_requests(\%args);
	$self->tt_params( records => $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) {
		# get arrayref of all the request_ids:
		my @request_ids = map $_->id, @$records; # $self->debug(\@request_ids);
		
		{ # get report & diagnosis info for each request id:
			my $report_map = $self->_get_report_data(\@request_ids);
			$self->tt_params( report_map => $report_map );
		}
		{ # 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');
}

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

#-------------------------------------------------------------------------------
sub _get_report_data {
	my ($self, $request_ids) = @_; $self->_debug_path(); # arrayref
	
	my $reports
		= $self->model('Request')->get_request_report_diagnosis($request_ids);

	my $today = DateTime->now->ymd('-');
	
	my %report_data; # report data for each $request_id
	
	for my $report (@$reports) { # warn Dumper $report->created_at;
		my $data = $report->as_tree(deflate => 0);
		
		{ # calculate age of report in delta business day & add to $data:
			my $report_date = $report->created_at->ymd('-') # deflate for delta_business_days()
			|| $today; # if not reported, so delta days = 0
			$data->{age_of_report}
				= LIMS::Local::Utils::delta_business_days($report_date, $today);
		} # warn Dumper $data;
		
		$report_data{$report->id} = $data; 
	} # warn Dumper \%report_map;
	
	return \%report_data;
}

#-------------------------------------------------------------------------------
# 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) {
		my $patient_case = $_->patient_case;
		my $id = $patient_case->patient_id;
		
		$unique_patients{$id}{count}++; # auto increment
		# only need patient_case once:
		next if $unique_patients{$id}{patient_case};
		# convert patient_case object to hashref for clarity downstream:		
		$unique_patients{$id}{patient_case} = $patient_case->as_tree(deflate => 0);
	}; # warn Dumper \%patient_map;

	# sort order supplied by user, or default to patient_id:
	my $sort_by = $self->query->param('sort_by') || 'patient_id'; 
	
	# 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_case}{patient}{dob} || $NULL; 
		my $B = $unique_patients->{$b}{patient_case}{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_case}{patient}{last_name};
		my $B_LN = $unique_patients->{$b}{patient_case}{patient}{last_name};
			
		my $A_FN = $unique_patients->{$a}{patient_case}{patient}{first_name};
		my $B_FN = $unique_patients->{$b}{patient_case}{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_case}{unit_number}
			cmp
		$unique_patients->{$b}->{patient_case}{unit_number}
	} keys %$unique_patients;
	
	return \@ids;
}
	
sub _sort_by_nhs_number {			
	my $unique_patients = shift;

	my @ids = sort {
		my $A = $unique_patients->{$a}{patient_case}{patient}{nhs_number} || 0;
		my $B = $unique_patients->{$b}{patient_case}{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;