package LIMS::Controller::HMRN;
use Moose;
BEGIN { extends 'LIMS::Base'; }
with (
'LIMS::Controller::Roles::Misc',
'LIMS::Controller::Roles::FormData',
);
use namespace::clean -except => 'meta';
has newly_diagnosed => (
is => 'ro',
isa => 'ArrayRef[LIMS::DB::Request]',
default => sub { [] },
lazy => 1,
traits => ['Array'],
handles => {
add_to_new_diagnoses => 'push',
has_new_diagnoses => 'count',
all_new_diagnoses => 'elements',
},
);
has known_previous => (
is => 'ro',
isa => 'ArrayRef[HashRef]',
default => sub { [] },
lazy => 1,
traits => ['Array'],
handles => {
add_to_known_previous => 'push',
has_known_previous => 'count',
all_known_previous => 'elements',
},
);
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
use Spreadsheet::WriteExcel::Simple;
use LIMS::Local::Utils;
use Digest::SHA1 'sha1_hex';
use Data::Dumper;
#__PACKAGE__->authz->authz_runmodes( ':all' => 'hmrn_admin' ); # doesn't work if not logged in
# ------------------------------------------------------------------------------
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('hmrn_admin');
return $self->tt_process($errs);
}
# ------------------------------------------------------------------------------
sub new_diagnoses : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
return $self->forbidden() unless $self->user_can('hmrn_admin');
my $dfv = $self->check_rm( 'default', $self->validate('hmrn_new_diagnoses') )
|| return $self->dfv_error_page;
my $params = $dfv->valid; # warn Dumper $params;
my $data = $self->model('HMRN')->get_new_diagnoses($params); # warn Dumper $data;
# abort downstream lookups if no records found, or too many to handle:
my $count = $data->{count};
if (! $count || $count > 1000 ) {
my $msg = $count
? ( sprintf $self->messages('search')->{too_many_records}, $count )
: $self->messages('search')->{no_records_found};
$self->stash->{status_msg} = $msg;
return $self->forward('default');
}
my $cases = $data->{cases}; # arrayref
# can force template for individual case with known icdo3 previous diagnosis
# using 'force' param (only submitted for single case in 'Known previous' list):
my $force_template = ( $params->{force_tmpl} && $params->{request_id} );
if ( $force_template ) { # force template display:
$self->add_to_new_diagnoses($cases->[0]); # @cases will be array size of 1
}
else {
my $previous_diagnoses # arrayref of previous diagnoses/icdo3 events for all cases:
= $self->model('HMRN')->get_previous_icdo3_diagnoses($cases);
# split each case into 2 categories: those with & without a known previous
# ICDO3 diagnosis:
CASE: for my $case (@$cases) {
my $pid = $case->patient_case->patient_id;
# if previous icdo3 diagnoses, add case to @known_previous list with
# array(ref) of previous diagnosis names:
my %previous = ();
if ( my $data = $previous_diagnoses->{$pid} ) { # arrayref of previous diagnoses
for (@$data) {
# only interested in diagnoses prior to *this* case, and may
# have multiple requests from same patient over selected duration:
next unless $_->{date} < $case->created_at;
my $diagnosis = $_->{diagnosis};
$previous{$diagnosis} = $_->{icdo3}; # hash to handle duplicates
} # warn Dumper $data if $pid == 86276;
}
if (%previous) {
my %h = (
current => $case, # current record
previous => \%previous, # unique previous diagnoses
);
$self->add_to_known_previous(\%h);
}
else { # case doesn't have any diagnoses previous to this crreated_at date
$self->add_to_new_diagnoses($case);
}
}
}
{ # sort new_diagnoses by location then name:
my @data = sort by_location_and_name $self->all_new_diagnoses;
$self->tt_params( cases => \@data ); # warn Dumper \@data;
}
# provide an age calculation callback:
$self->tt_params( calculate_age => sub {
LIMS::Local::Utils::calculate_age(@_);
});
my $format = $self->query->param('format'); # templates, worklist or export
# templates (requires new_diagnoses):
if (lc $format eq 'templates' && $self->has_new_diagnoses) {
# get specimens map:
my @request_ids = map { $_->id } $self->all_new_diagnoses; # warn Dumper \@request_ids;
my $specimen_map = $self->specimen_map(\@request_ids);
$self->tt_params( specimen_map => $specimen_map ); # warn Dumper $specimen_map;
return $self->tt_process('hmrn/data_collection.tt');
}
# export (requires new_diagnoses and/or known_previous, ie @$cases):
elsif (lc $format eq 'export' && @$cases) {
my $filename = sprintf 'new_diagnoses_%s.xls', DateTime->today->ymd('_');
$self->header_props(-type => 'application/excel', -attachment => $filename, -expires => 'now');
my $data = $self->_export_data();
return $data;
}
else { # format = worklist, or no new diagnoses (gets 'no new diags' msg): :
my $from = DateTime->today->subtract( days => $params->{duration} || 7 );
$self->tt_params( date_from => $from ); # format date for template display
$self->tt_params( known_previous => $self->known_previous );
{ # get request counts for each patient in list:
my %patient_ids = map +($_->patient_case->patient_id => 1),
$self->all_new_diagnoses; # warn Dumper \%patient_ids;
if ( my @pids = keys %patient_ids ) { # warn Dumper \@pids;
my $map = $self->model('HMRN')->get_total_request_counts(\@pids);
$self->tt_params( request_counts => $map );
}
}
return $self->tt_process; # use method default template
}
}
# ------------------------------------------------------------------------------
sub params_config : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
return $self->forbidden() unless $self->user_can('hmrn_admin');
my $categories = $self->model('HMRN')->get_categories;
$self->tt_params( categories => $categories );
my $category = $self->query->param('category');
# if param_id submitted, update:
if ( my @ids = $self->query->param('param_id') ) { # warn Dumper \@ids;
my %args = (
category => $category,
param_ids => \@ids,
);
my $rtn = $self->model('HMRN')->update_category_parameter(\%args);
if ($rtn) { return $self->error($rtn) }
else { $self->flash(info => $self->messages('action')->{edit_success}) }
}
# get active params for category:
if ($category) {
my $params =
$self->model('HMRN')->get_active_params_for_category($category);
$self->tt_params( params => $params );
}
return $self->tt_process;
}
# ------------------------------------------------------------------------------
sub treatment_options : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
return $self->forbidden() unless $self->user_can('hmrn_admin');
my $opts = $self->model('HMRN')->get_treatment_options;
$self->tt_params( opts => $opts );
# vars only exist if form submitted:
my $vars = $self->query->Vars();
return $self->tt_process() unless %$vars; # warn Dumper $vars;
my $rtn = $self->model('HMRN')->update_tx_options($vars);
return $rtn
? $self->error($rtn)
: $self->redirect_after_edit_success('/hmrn/treatment_options');
}
# ------------------------------------------------------------------------------
sub treatment_rename : Runmode {
my $self = shift; $self->_debug_path($self->get_current_runmode);
return $self->forbidden() unless $self->user_can('hmrn_admin');
my $param_type_id = $self->param('id');
my $param_detail_id = $self->param('Id');
my %treatment_ids = (
type_id => $param_type_id,
detail_id => $param_detail_id,
);
$self->tt_params( treatment_ids => \%treatment_ids );
# edit_mode: Determines if we are editing the TYPE or the DETAIL
# 2nd parameter (Id) will be undefined if editing type
my $edit_mode = $self->param('Id') ? 'DETAIL' : 'TYPE';
$self->tt_params( edit_mode => $edit_mode );
{
my $opts = $self->model('HMRN')->get_treatment_options;
$self->tt_params( opts => $opts );
}
my $vars = $self->query->Vars();
return $self->tt_process() unless %$vars; # warn Dumper $vars;
# -->> save form here
my $rtn = $self->model('HMRN')->edit_tx_description($vars, \$edit_mode, \%treatment_ids);
return $rtn
? $self->error($rtn)
: $self->redirect_after_edit_success('/hmrn/treatment_options'); # error msg or 0 for success
}
# ------------------------------------------------------------------------------
sub find_practice : Runmode { return shift->tt_process } # just loads tmpl
# ------------------------------------------------------------------------------
# redirects to HMRN survival info, generates MS-style SHA1 hex digest hash
sub info : Runmode {
my $self = shift;
my $diagnosis_id = $self->param('id');
my $settings = $self->cfg('settings');
my $formatter = LIMS::Local::Utils::datetime_formatter('%F %T');
my $variable = LIMS::Local::Utils::time_now({ formatter => $formatter });
my $fixed_str = $settings->{hmrn_info_str};
my $hmrn_site = $settings->{hmrn_link}; # have already checked in .tt that it exists
# generate string for hashing (eg HILIS_HMRN_2114911_YYYY-mm-dd h:m:s):
my $str = join '_', $fixed_str, $variable; # warn $str;
# MS SQL server generates 40-char uppercase hex hash, with 0x prepended:
my $hex = '0x' . uc Digest::SHA1::sha1_hex($str); # warn $hex;
my $url = sprintf
'http://%s?DiagnosisID=%s&hash=%s', $hmrn_site, $diagnosis_id, $hex; # warn $url;
return $self->redirect($url, '302');
}
# ------------------------------------------------------------------------------
sub by_location_and_name { # sort for new diagnosis list
my $patient_a = $a->patient_case->patient;
my $patient_b = $b->patient_case->patient;
my $location_a = $a->patient_case->referral_source->display_name;
my $location_b = $b->patient_case->referral_source->display_name;
return
$location_a cmp $location_b
||
$patient_a->last_name cmp $patient_b->last_name
||
$patient_a->first_name cmp $patient_b->first_name
}
# ------------------------------------------------------------------------------
sub _export_data {
my $self = shift; $self->_debug_path();
my @known_previous = $self->all_known_previous;
my @new_diagnoses = $self->all_new_diagnoses;
my %h; # hash so we can recombine lists in request.id order
# process new diagnoses:
for my $d (@new_diagnoses) { # warn Dumper $d;
my $row = $self->_format_row($d);
$h{$d->id} = $row;
}
# process requests with known previous diagnoses:
REQ: for my $d (@known_previous) { # warn Dumper $d->{current};
my $previous = $d->{previous}; # HoH of diagnosis => icdo3
my $data = $d->{current}; # LIMS::DB::Request object
my $row = $self->_format_row($data);
my @diagnoses = ();
while ( my ($diagnosis, $icdo3) = each %$previous ) {
# skip this case entirely if any previous diagnosis has same ICDO3:
next REQ if $icdo3 eq $data->request_report->diagnosis->icdo3;
push @diagnoses, $diagnosis; # icdo3 different so add
}
# add list of previous diagnoses to $row:
push @$row, join ', ', @diagnoses;
$h{$data->id} = $row; # add row to hash
}
my $xl = Spreadsheet::WriteExcel::Simple->new;
my @headers = qw(requestID ref name dob patID referrer source authorised
unit_no nhs_no diagnosis new previous);
$xl->write_bold_row(\@headers);
# write out rows in request.id order:
$xl->write_row($h{$_}) for sort keys %h;
return $xl->data; # or $xl->save("filename.xls");
}
# ------------------------------------------------------------------------------
sub _format_row {
my ($self, $d) = @_; $self->_debug_path();
my $name = join ', ',
uc $d->patient_case->patient->last_name,
ucfirst $d->patient_case->patient->first_name;
my $lab_number = join '/', $d->request_number, $d->year - 2000;
my $auth_date = ref $d->request_history # for duplicate actions
? $d->request_history->[0]->time->dmy('.') # arrayref
: $d->request_history->time->dmy('.');
my $status = $d->request_report->status eq 'new'
? 'Y'
: $d->request_report->status eq 'relapse'
? 'R'
: 'N';
my @data = (
$d->id,
$lab_number,
$name,
$d->patient_case->patient->dob->dmy('.'),
$d->patient_case->patient_id,
$d->referrer_department->referrer->name,
$d->patient_case->referral_source->display_name,
$auth_date,
$d->patient_case->unit_number,
$d->patient_case->patient->nhs_number,
$d->request_report->diagnosis->name,
$status,
); # warn Dumper \@data;
return \@data;
}
1;
