package LIMS::Model::Outreach;
use Moose;
extends 'LIMS::Model::Base';
with (
'LIMS::Model::Roles::Query', # get_sql_with_constraint(), sql_lib()
'LIMS::Model::Roles::Outreach',
'LIMS::Model::Roles::RequestUpdate', # do_history_log
);
use namespace::clean -except => 'meta';
has actions => (
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub { [] },
lazy => 1,
traits => ['Array'],
handles => {
add_to_actions => 'push',
reset_actions => 'clear',
all_actions => 'elements',
},
);
__PACKAGE__->meta->make_immutable;
use DateTime::Format::MySQL;
use LIMS::Local::Utils;
use Data::Printer;
use Data::Dumper;
use DateTime;
# load test db if running under test mode:
sub outreach_db {
shift->lims_db->database eq 'lims_test' ? 'outreach_test' : 'outreach';
}
# get query from sql_lib:
sub get_query {
my ($self, $item) = @_;
my $sql = $self->sql_lib->retr($item)
or die "cannot find [$item] in sql library";
$sql =~ s/(outreach)\./$1_test./g if $self->outreach_db =~ /test/;
return $sql;
}
#-------------------------------------------------------------------------------
sub get_all_data {
my ($self, $request_id) = @_; # warn $request_id;
my $dbix = $self->lims_dbix;
my $request = LIMS::DB::Request->new(id => $request_id)
->load(with => 'patient_case');
my $patient_id = $request->patient_case->patient_id; # warn Dumper $patient_id;
my %data = ();
{ # first get list of all departments, lab_tests, defaults & ranges:
my $sql = $self->get_query('outreach_lab_params');
my $query = $dbix->query($sql);
# get list of cols from defaults_and_ranges table:
my $meta = $self->dbix_get_meta('outreach.defaults_and_ranges'); # warn Dumper $meta;
my @cols = grep {
$meta->{$_}->{key} ne 'PRI' # skip primary key
} keys %$meta; # warn Dumper \@cols;
while ( my $vars = $query->hash ) {
my $param = $vars->{param_name};
my $dept = $vars->{description};
my %params = (
field_label => $vars->{field_label},
param_name => $vars->{param_name},
field_type => $vars->{field_type},
result => undef, # initialise placeholder
);
$data{$dept}{$param} = \%params;
# add any (optional) default & ranges cols:
map {
$data{$dept}{$param}{$_} = $vars->{$_};
} grep $vars->{$_}, @cols;
}
}
{ # requested lab tests:
my $sql = $self->get_query('outreach_requested_lab_tests');
my $ref = $dbix->query($sql, $request_id)->flat; # warn Dumper $ref; # arrayref
$data{requested_lab_tests} = $ref;
}
{ # add lab_test results:
my $sql = $self->get_query('outreach_lab_results');
my $query = $dbix->query($sql, $request_id);
# get epoch value of current request for data summary:
# my $epoch = $request->created_at->epoch; # using chart instead now
while ( my $vals = $query->hash ) {
my $result = $vals->{result};
my $param = $vals->{param_name};
my $dept = $vals->{description};
# for individual sections (haem, immunol, etc):
$data{$dept}{$param}{result} = $result;
# for data summary - using chart instead now:
# $data{datasets}{$epoch}{$param}{result} = $result;
}
{ # calculate total & abnormal B cells:
my %h = (
wbc => $data{haematology}{wbc}{result},
total_b_cells => $data{flow_cytometry}{total_b_cells}{result},
neoplastic_b_cells => $data{flow_cytometry}{neoplastic_b_cells}{result},
);
my $calculated = $self->calculate_flow_params(\%h);
map { $data{calculated}{$_}{result} = $calculated->{$_} }
keys %$calculated;
}
}
{ # add patient demographics data:
my $sql = $self->get_query('outreach_patient_demographics');
my $demographics = $dbix->query($sql, $patient_id)->hash;
$self->inflate_mysql_dates_to_datetime($demographics, ['dod']);
$data{demographics} = $demographics;
}
{ # questionnaire:
my $ref = { request_id => $request_id };
{ # eq5d:
my $tbl = 'outreach.questionnaire_eq5d';
my $meta = $self->dbix_get_meta($tbl); # get list of cols (not PRIMARY KEY):
my @cols = grep { $_ ne 'request_id' } keys %$meta; # warn Dumper \@cols;
my $eq5d = $dbix->select($tbl, \@cols, $ref)->hash;
$data{questionnaire}{eq5d} = $eq5d;
}
{ # symptoms:
my $tbl = 'outreach.questionnaire_symptoms';
my $meta = $self->dbix_get_meta($tbl); # get list of cols (not PRIMARY KEY):
my @cols = grep { $_ ne 'request_id' } keys %$meta; # warn Dumper \@cols;
my $symptoms = $dbix->select($tbl, \@cols, $ref)->hash;
$data{questionnaire}{symptoms} = $symptoms;
}
{ # pain:
my $tbl = 'outreach.questionnaire_pain';
my $ary = $dbix->select($tbl, 'pain_option_id', $ref)->flat;
$data{questionnaire}{pain}{$_}++ for @$ary;
}
{ # adenopathy:
my $tbl = 'outreach.questionnaire_adenopathy';
my $ary = $dbix->select($tbl, 'nodal_option_id', $ref)->flat;
$data{questionnaire}{adenopathy}{$_}++ for @$ary;
}
{ # service assessment:
my $tbl = 'outreach.questionnaire_service';
my $service = $dbix->select($tbl, 'opinion', $ref)->hash;
$data{questionnaire}{service} = $service;
}
}
{ # follow-up data:
my $follow_up = $self->get_followup_data($request_id);
$data{followup} = $follow_up;
}
{ # patient notes:
my @args = ( patient_id => $patient_id );
my $data = LIMS::DB::PatientNote->new(@args)->load(speculative => 1);
$data{demographics}{patient_notes} = $data;
}
# get GP's for practice:
if ( my $practice_id = $data{demographics}{practice_id} ) {
my $GPs = $self->get_practitioners_for_practice($practice_id);
$data{demographics}{practitioners} = $GPs;
}
{ # get unknown practitioner id:
my $o = LIMS::DB::ReferralType->new(description => 'practitioner')
->load(with => 'unknown_referrer');
$data{demographics}{unknown_gp_id} = $o->unknown_referrer->id;
}
{ # non-participating practices:
my $sql = 'select practice_id, 1 from outreach.non_participant_practice';
my $ids = $dbix->query($sql)->map;
$data{demographics}{non_participant_practices} = $ids;
}
{ # get menu options:
my $opts = $self->get_menu_options; # warn Dumper $opts;
$data{menu_options} = $opts;
} # warn Dumper \%data;
return \%data;
}
# ------------------------------------------------------------------------------
# calculate absolute number of total & neoplastic B-cells; shared with C::Chart::outreach
sub calculate_flow_params {
my $self = shift;
my $data = shift; # warn Dumper $data;
my %calculated = ();
# require wbc AND total_b_cells AND neoplastic_b_cells:
my @required = qw(wbc total_b_cells neoplastic_b_cells);
unless ( grep { ! defined $data->{$_} } @required ) {
my $total_b_cell_count = $data->{wbc} * $data->{total_b_cells} / 100;
$calculated{total_b_cells} = $total_b_cell_count;
my $neoplastic_b_cell_count
= $total_b_cell_count * $data->{neoplastic_b_cells} / 100;
$calculated{neoplastic_b_cells} = $neoplastic_b_cell_count;
} # warn Dumper \%calculated;
return \%calculated;
}
#-------------------------------------------------------------------------------
sub get_menu_options { # get menu options - shared with C::Outreach::dfv_err()
my $self = shift;
my $dbix = $self->lims_dbix;
# get pain opts, nodal opts, follow-up opts:
my $opts = $self->questionnaire_options;
{ # add data from menu_options table:
my $sql = $self->get_query('outreach_menu_options');
my $query = $dbix->query($sql);
while ( my $vars = $query->array ) {
my ($field_name, $detail) = @$vars;
push @{ $opts->{$field_name} }, $detail;
} # warn Dumper $opts;
}
return $opts;
}
#-------------------------------------------------------------------------------
sub get_chart_results {
my ($self, $patient_id, $field) = @_; # scalar, scalar || arrayref
# $fields either scalar, or arrayref; need to get additional fields for
# calculation of value if $fields either total_b_cells or neoplastic_b_cells:
return $self->calculated_chart_results($patient_id, $field)
if (! ref $field) && grep $field eq $_, qw(total_b_cells neoplastic_b_cells);
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_request_results'); # warn Dumper $sql;
my @bind = ref $field eq 'ARRAY' ? @$field : $field; # warn Dumper \@bind;
my $data = $dbix->query( $sql, $patient_id, @bind )->hashes; # warn Dumper $data;
return $data;
}
#-------------------------------------------------------------------------------
sub calculated_chart_results { # for total_b_cells or neoplastic_b_cells:
my ($self, $patient_id, $field) = @_;
my $dbix = $self->lims_dbix;
my @fields = ( 'wbc', 'total_b_cells', 'neoplastic_b_cells' );
my $sql = $self->get_query('outreach_request_results');
my $data = $dbix->query( $sql, $patient_id, @fields )->hashes; # warn Dumper $data;
# create interim hash where keys = epoch seconds, vals = hashref of results:
my %h = my %labels = (); # %labels for @calculated array
for (@$data) { # warn Dumper $_;
my $result = $_->{result};
my $param = $_->{param_name};
my $date = $_->{created_at};
$labels{$param} = $_->{field_label};
my $epoch = LIMS::Local::Utils::to_datetime_using_parsedate($date)->epoch;
$h{$epoch}{$param} = $result; # convert to seconds to allow sort on hash
} # warn Dumper \%h;
my @calculated = (); # array of data in same format as original @$data
# calculate total_b_cells & neoplastic_b_cells vals for each time-point:
for my $key ( sort keys %h ) { # $key = epoch seconds of requests.created_at
my $data_set = $h{$key}; # warn Dumper $set;
my $vals = $self->calculate_flow_params($data_set); # warn Dumper $vals;
# convert epoch back to date string for perlchartdir::chartTime(@date):
my $formatter = DateTime::Format::Strptime->new( pattern => '%F %T' );
my $date = DateTime->from_epoch( epoch => $key, formatter => $formatter );
my $result = $vals->{$field}; # warn Dumper $result;
# recreate original @$data entries:
my %data = (
field_label => $labels{$field},
created_at => $date, # ( join ' ', $dt->ymd, $dt->hms ),
param_name => $field,
result => $result,
); # warn Dumper \%data;
push @calculated, \%data;
} # warn Dumper \@calculated;
return \@calculated;
}
#-------------------------------------------------------------------------------
sub get_lab_param {
my ($self, $param) = @_;
my $o = LIMS::DB::Outreach::LabParam->new(param_name => $param)->load;
return $o;
}
#-------------------------------------------------------------------------------
sub update_patient_questionnaire {
my ($self, $args) = @_; # warn Dumper $args;
my $request_id = $args->{request_id};
# tables with 1-to-1 relationship with request.id:
my @horizontal = qw(
outreach_questionnaire_symptoms
outreach_questionnaire_service
outreach_questionnaire_eq5d
);
# tables with 1-to-many relationship with request.id:
my @vertical = qw(
outreach_questionnaire_adenopathy
outreach_questionnaire_pain
);
my @all = (@horizontal,@vertical); # combined for %class_for_tbl
# create hash of corresponding classes for above tables (*in same order*):
my %class_for_tbl; @class_for_tbl{@all} = qw(
QuestionnaireSymptoms
QuestionnaireService
QuestionnaireEQ5D
QuestionnaireAdenopathy
QuestionnairePain
);
# get existing (1-2-1) questionnaire data for this request:
my $data = LIMS::DB::Request->new(id => $request_id)
->load( with => \@horizontal ); # warn Dumper $data;
# create hashref of $data object to avoid 2nd db query when testing for accessors:
my $h = $data->as_tree; # warn Dumper $h;
# use 162560 & 168625;
my $has_array_diff = sub { LIMS::Local::Utils::get_array_diff(@_) };
my $update = sub {
# for 1-to-1 tables, if accessor exists, update it, otherwise create new:
for my $tbl (@horizontal) { # eg outreach_questionnaire_eq5d
if ( $h->{$tbl} ) { # exists so update it:
my $o = $data->$tbl; # get object
my @cols = $o->meta->column_names;
COL: for my $col(@cols) { # warn Dumper $_;
no warnings 'uninitialized'; # ie optional cols
next COL if $o->$col eq $args->{$col}; # skip unchanged
$o->$col($args->{$col}); # warn Dumper $o->as_tree;
my $action = sprintf 'updated outreach %s from %s to %s',
$col, $h->{$tbl}->{$col} || 'NULL', $args->{$col} || 'NULL';
$self->add_to_actions($action);
}
$o->save(changes_only => 1);
}
else { # doesn't exist so insert new:
my $class = 'LIMS::DB::Outreach::'.$class_for_tbl{$tbl}; # eg QuestionnairePain
# get cols from meta data:
my @cols = $class->new->meta->column_names; # warn Dumper \@cols;
my %data = map +($_ => $args->{$_}),
grep { defined $args->{$_} } # skip unless col has a value
grep { $_ ne 'request_id' } @cols; # warn Dumper \%data;
if (%data) { # if table data, add request_id & save:
$data{request_id} = $args->{request_id};
$data->$tbl(%data)->save;
$tbl =~ s/_/ /g; # for history log:
# TODO: can't distinguish between individual tables & complete questionnaire
$self->add_to_actions("added new $tbl dataset");
} # else { warn "$tbl has no data" }
} # warn Dumper $data->as_tree;
}
TBL: # 1-to-many (vertical) tables:
for my $tbl (@vertical) { # eg outreach_questionnaire_pain
my $class = 'LIMS::DB::Outreach::'.$class_for_tbl{$tbl}; # eg QuestionnairePain
# get table col names from meta data:
my @cols = $class->new->meta->column_names; # warn Dumper \@cols;
# get existing data object:
my $mgr = $class . '::Manager';
my $o = $mgr->get_objects( query => [ request_id => $request_id ] );
# get single non-request_id col name (only 1 for vertical tables):
my ($col_name) = grep $_ ne 'request_id', @cols; # warn $col_name;
# get existing data for this col:
my @vals = map $_->$col_name, @$o; # warn Dumper \@vals;
# ensure form data is arrayref (even if empty - for get_array_diff()):
my $data = ref $args->{$col_name} eq 'ARRAY'
? $args->{$col_name} # already arrayref
: defined $args->{$col_name} # make scalar into arrayref, or create empty []
? [ $args->{$col_name} ] : []; # warn Dumper $data;
# check for changes or skip table:
&$has_array_diff($data, \@vals) || next TBL; # warn Dumper $diff;
# delete any existing rows:
$_->delete for @$o; # warn Dumper $o;
# add any new rows:
$class->new( request_id => $request_id, $col_name => $_ )->save
for @$data;
# log change:
$tbl =~ s/_/ /g; # for history log:
$self->add_to_actions("updated $tbl dataset");
}
$self->do_history_log({ _request_id => $request_id }); # just needs _request_id attr
};
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_patient_questionnaire() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_followup {
my ($self, $args) = @_; # warn Dumper $args;
my $appointment = $args->{appointment_date}; # optional
my $request_id = $args->{_request_id}; # required
my $return_due = $args->{return_due}; # optional
my $option_id = $args->{followup_option_id}; # required
my $pack_due = $args->{pack_due}; # optional
# get follow-up options table data:
my $options_map = $self->followup_options_map; # warn Dumper $options_map;
# get existing data for this request:
my @tbls = qw(
outreach_request_followup
outreach_request_pack_dispatch
outreach_request_clinic_return
); #
my $data = LIMS::DB::Request->new(id => $request_id)
->load( with => \@tbls ); # warn Dumper $data->as_tree;
# outreach_request_pack_dispatch will only exist for a duration followup (eg
# 1 month, 6 month, etc) - calling method on $data will force db lookup every time, so:
my $has_pack_dispatch = $data->as_tree->{outreach_request_pack_dispatch}; #warn Dumper $has_pack_dispatch;
# set null date to 1/1/1999:
my $null_date = LIMS::Local::Utils::to_datetime_using_datecalc('1/1/1999');
# 1) where follow-up option has changed:
if ( $option_id != $data->outreach_request_followup->followup_option_id ) {
# returns { href of keys = period & duration } if option_id is a
# chronological one (eg six_week):
my $pack_dispatch_args = $self->get_pack_dispatch_args($option_id); # href
if ( $pack_dispatch_args ) { # warn Dumper $pack_dispatch_args;
# add ref date (request.created_at):
$pack_dispatch_args->{ref_date} = $data->created_at;
my $new_pack_dispatch_date
= $self->calculate_pack_dispatch_date($pack_dispatch_args);
#my $new_pack_dispatch_date = $data->created_at->clone
# ->add( %{$pack_dispatch_args} ) # + required duration (eg weeks => 6)
# ->subtract( days => 14 ); # - 14 days
# if existing entry in request_pack_dispatch table:
if ( $has_pack_dispatch ) {
my $o = $data->outreach_request_pack_dispatch;
# update pack dispatch due date only if no pack sent:
if (! $o->pack_sent ) {
$o->pack_due($new_pack_dispatch_date);
}
# if pack sent, adjust pack return date
else {
# clone pack_sent_date so val not changed:
my $d = $new_pack_dispatch_date->clone;
my $return_date = $self->calculate_pack_return_date($d);
$o->return_due($return_date);
}
}
else { # else add a new request_pack_dispatch row:
$data->outreach_request_pack_dispatch(
request_id => $request_id,
pack_due => $new_pack_dispatch_date,
)->save;
}
}
# new follow-up not a duration - check for existing pack dispatch:
# if pack not sent, set pack dispatch due date null
# if pack sent, set return due date to null
elsif ( $has_pack_dispatch ) {
my $pack_dispatch = $data->outreach_request_pack_dispatch;
# if we get here, previous follow-up decision must have been a timeline
if ($pack_dispatch->return_due) { # pack must have been sent
$pack_dispatch->return_due($null_date);
}
else { # pack not sent so due date must be future:
$pack_dispatch->pack_due($null_date);
}
}
{ # log follow-up option change:
my $original_option_id
= $data->outreach_request_followup->followup_option_id;
my $msg = sprintf 'changed outreach follow-up option from %s to %s',
$options_map->{$original_option_id}->{label},
$options_map->{$option_id}->{label};
$self->add_to_actions($msg);
}
# register the follow-up option change (AFTER changing pack_due date):
$data->outreach_request_followup->followup_option_id($option_id);
}
# 2) elsif pack dispatch due date submitted (and follow-up option NOT changed):
elsif ($pack_due) { # only allowed to do this if not already past pack_due date
my $old_date = $data->outreach_request_pack_dispatch->pack_due;
my $new_date = LIMS::Local::Utils::to_datetime_using_datecalc($pack_due);
if ( $new_date->delta_days($old_date)->delta_days ) { # if date changed:
$data->outreach_request_pack_dispatch->pack_due($new_date);
# and log date change
my $msg = sprintf 'changed pack due date from %s to %s',
$old_date->dmy, $new_date->dmy;
$self->add_to_actions($msg);
}
}
# 3) elsif return_due date submitted (and follow-up option NOT changed):
elsif ($return_due) {
my $old_date = $data->outreach_request_pack_dispatch->return_due;
my $new_date = LIMS::Local::Utils::to_datetime_using_datecalc($return_due);
if ( $new_date->delta_days($old_date)->delta_days ) { # date changed:
$data->outreach_request_pack_dispatch->return_due($new_date);
# and log date change
my $msg = sprintf 'changed pack return date from %s to %s',
$old_date->dmy, $new_date->ymd;
$self->add_to_actions($msg);
}
}
# 4) return to clinic appointment date
elsif ($appointment) {
my $d = LIMS::Local::Utils::to_datetime_using_datecalc($appointment);
my $old_appointment_date
= $data->outreach_request_clinic_return->appointment_date;
if ( $d->delta_days($old_appointment_date)->delta_days ) { # have changed date
$data->outreach_request_clinic_return->appointment_date($d);
my $msg = sprintf 'amended clinic appointment date [%s]',
$old_appointment_date->ymd;
$self->add_to_actions($msg);
}
}
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
$data->outreach_request_followup->save(changes_only => 1);
if ($appointment) { # only supplied if returned to clinic & amended appointment date
$data->outreach_request_clinic_return->save(changes_only => 1);
}
if ($has_pack_dispatch) { # won't exist for a previously non-pack-dispatch entry
$data->outreach_request_pack_dispatch->save(changes_only => 1);
}
$self->do_history_log($args); # just needs _request_id attr
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_followup() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_lab_params {
my ($self, $data) = @_; # warn Dumper $data;
my $request_id = $data->{_request_id};
my $department = $data->{department}; # eg immunology
my $dbix = $self->lims_dbix;
# get lab_param => id map:
my $sql = $self->get_query('outreach_params_for_department');
my $param_map = $dbix->query( $sql, $department )->map; # warn Dumper $param_map;
my @cols = keys %$param_map; # warn Dumper \@cols;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
PARAM: for my $col (@cols) {
my $val = $data->{$col};
my $param_id = $param_map->{$col}
or die "$col doesn't exist in lab_params table";
my @PK = (request_id => $request_id, param_id => $param_id);
my $o = LIMS::DB::Outreach::RequestResult->new(@PK); # warn Dumper $o;
if ( $o->load_speculative ) { # warn Dumper [$val, $o->result];
if ( defined $val && defined $o->result ) { # log update if param changed:
next PARAM if $val eq $o->result; # skip unchanged
$self->add_to_actions("updated outreach $col from " . $o->result);
}
elsif ($val) { # new param
$self->add_to_actions("new outreach $col result");
}
elsif ($o->result) { # delete param
$self->add_to_actions("removed outreach $col result");
$o->delete;
next PARAM; # skip $o->result() & $o->save later in loop
}
}
else { # log new dataset:
$department =~ s/_/ /g; # underscores => spaces
my $action = sprintf 'input new outreach %s dataset', $department;
$self->add_to_actions($action) # only need it once
unless grep $_ eq $action, $self->all_actions;
}
if ( defined $val ) { # in case allowing null cols in any table
$o->result($val);
$o->save(changes_only => 1);
}
}
$self->do_history_log($data); # just needs _request_id attr
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_lab_params() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_dispatch_detail {
my ($self, $args) = @_;
my $patient_id = $args->{patient_id};
my $dispatch_to = $args->{dispatch_to};
my $user_id = $self->user_profile->{id};
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
my $o = LIMS::DB::Outreach::PatientDispatchDetail
->new(patient_id => $patient_id);
# do patient demographic history if dispatch_to changed:
if ( $o->load_speculative && $o->dispatch_to ne $args->{dispatch_to} ) {
my $action = sprintf q!updated 'dispatch_to' from '%s'!, $o->dispatch_to;
my %data = (
patient_id => $patient_id,
user_id => $user_id,
action => $action,
);
LIMS::DB::PatientDemographicHistory->new(%data)->save;
}
$o->dispatch_to($dispatch_to);
$o->save(changes_only => 1); # doesn't do changes_only
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_dispatch_detail() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_outstanding_clinic_returns {
my $self = shift;
my @args = (
with_objects => [
'request.patient_case.patient',
'followup_option',
'clinic_return',
],
query => [
'followup_option.option' => 'clinic_return',
'clinic_return.request_id' => undef, # no entry in table
],
);
my $o = LIMS::DB::Outreach::RequestFollowup::Manager->get_objects(@args);
return $o;
}
#-------------------------------------------------------------------------------
sub get_cml_prescriptions {
my $self = shift;
}
#-------------------------------------------------------------------------------
sub update_clinic_appointment {
my $self = shift;
my $vars = shift; # warn Dumper $vars;
my $request_id = $vars->{request_id};
my $date = $vars->{appointment_date}; # jQuery datepicker validated
my $dt = LIMS::Local::Utils::to_datetime_using_datecalc($date);
my %h = (
request_id => $request_id,
appointment_date => $dt,
);
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
LIMS::DB::Outreach::RequestClinicReturn->new(%h)->save;
$self->add_to_actions('new clinic appointment date');
$self->do_history_log({ _request_id => $request_id }); # just needs _request_id attr
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_clinic_appointment() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_overdue_packs {
my $self = shift;
my $args = shift; # optional flag to include notification events
my $dbix = $self->lims_dbix;
# get most recent registration date for all outreach patients:
my $most_recent = do {
my $sql = $self->get_query('outreach_most_recent');
$dbix->query($sql)->map; # hashref map
};
my $dfm = DateTime::Format::MySQL->new();
# get all requests where return_due date < today:
my $requests = do {
my $sql = $self->get_query('outreach_overdue_packs');
$dbix->query($sql); # AoH
};
# if outreach notification request:
if ($args->{notifications}) { # create overdue_notification map:
my $o = $self->get_overdue_pack_notifications(); # M::R::Outreach
my %map = map +($_->request_id => $_), @$o;
$self->set_notifications(%map) if %map; # warn Dumper $self->overdue_notification;
}
my @request_ids = ();
REQ: # get request_ids where return_date < today and no follow-up yet:
while ( my $ref = $requests->hash ) { # request_id, nhs_number, pack_sent
my $nhs_number = $ref->{nhs_number};
my $request_id = $ref->{request_id};
# skip if follow-up sample received *after* pack_sent date:
if ( my $entry = $most_recent->{$nhs_number} ) {
my $most_recent_date = $dfm->parse_date($entry);
my $pack_sent_date = $dfm->parse_date($ref->{pack_sent});
# result of compare: -1 if $dt1 < $dt2, 0 if $dt1 == $dt2, 1 if $dt1 > $dt2
my $val = DateTime->compare( $pack_sent_date, $most_recent_date );
# warn Dumper [$ref->{request_id},'sent:'.$ref->{pack_sent},'back:'.$entry,'cmp:'.$val];
# 26/3/2014 - changed from <0 to <1 to allow for return on same day as dispatch:
next REQ if $val < 1; # ie $most_recent_date AFTER OR EQUAL TO $pack_sent_date
# if outreach notification request, skip if final notification sent,
# or less overdue than next event date:
if ( $self->has_notification_event($request_id) ) {
next REQ if $self->skip_notification($ref);
}
}
# no follow-up received for this request_id:
push @request_ids, $request_id;
}
return undef unless @request_ids; # or causes fatal in _get_overdue_packs_data
# get details of all requests where no follow-up sample received:
my $data = $self->_get_overdue_packs_data(\@request_ids); # arrayref
return $data;
}
#-------------------------------------------------------------------------------
sub get_packs_due_details {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_packs_due_details');
my $query = $dbix->query($sql);
my @packs;
my $trim = sub { LIMS::Local::Utils::trim(@_) };
while ( my $row = $query->hash ) {
$self->inflate_mysql_dates_to_datetime($row, ['dob']);
# re-arrange GP name:
$row->{practitioner} = join ' ', reverse split ' ', $row->{practitioner};
# extract post_code from practice address:
my $post_code = ( split ',', $row->{practice_address} )[-1]; # last item
$row->{practice_post_code} = &$trim($post_code); # warn Dumper [$post_code, &$trim($post_code)];
# decision-tree for loading correct questionnaire & pathology request form:
$self->_do_questionnaire_decision_tree($row); # updates $row hashref
push @packs, $row;
}
return \@packs;
}
#-------------------------------------------------------------------------------
sub _do_questionnaire_decision_tree {
my ($self, $vals) = @_; # warn Dumper $vals;
my (%pathology, $questionnaire);
my $electrophoresis = $vals->{electrophoresis};
my $neoplastic_b = $vals->{neoplastic_b_cells};
# CML:
if ( $vals->{icdo3} && $vals->{icdo3} =~ m!9875/3! ) {
$questionnaire = 'cml';
$pathology{biochem}{$_}++ for qw(u_and_e lft mg); # doesn't need immunology
}
# IgM paraprotein:
elsif ( defined $electrophoresis && $electrophoresis =~ /^IgM/ ) {
$questionnaire = 'blpd';
$pathology{immunology}{$_}++ for qw(igs sep ppq);
}
# MGUS:
elsif ( $vals->{diagnosis} =~ 'MGUS|gammopathy' ) { # can't use icdo3 - includes amyloidosis
$pathology{immunology}{$_}++ for qw(igs sep ppq);
# neoplastic-B value of zero gets MGUS questionnaire, otherwise combined:
$questionnaire = ( defined $neoplastic_b && ! $neoplastic_b )
? 'mgus' # ie neoplastic-B result zero but not null
: 'combined'; # warn Dumper [$ref->{neoplastic_b_cells}, $questionnaire];
}
# not IgM paraprotein and non-MGUS:
else {
# no electrophoresis:
if ( ! defined $electrophoresis ) {
$questionnaire = 'combined';
$pathology{immunology}{$_}++ for qw(igs sep);
}
# known electrophoresis result but no paraprotein:
elsif ( $electrophoresis =~ /^No/ ) {
$questionnaire = 'blpd';
$pathology{immunology}{$_}++ for qw(igs);
}
# any (non-IgM) paraprotein:
else {
$questionnaire = 'combined';
$pathology{immunology}{$_}++ for qw(igs sep ppq);
}
}
# biochem tests defined in CML block, otherwise:
$pathology{biochem} ||= { map +($_ => 1), qw(albumin calcium creatinine) };
$vals->{pathology} = \%pathology;
$vals->{questionnaire} = $questionnaire;
}
#-------------------------------------------------------------------------------
sub get_packs_due_summary {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_packs_due_summary');
my $query = $dbix->query($sql);
my @packs;
while ( my $row = $query->hash ) {
$self->inflate_mysql_dates_to_datetime($row, ['pack_due']);
$self->inflate_mysql_timestamp_to_datetime($row, ['created_at']);
push @packs, $row;
}
return \@packs;
}
#-------------------------------------------------------------------------------
sub pack_labels {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_pack_labels');
my $data = $dbix->query($sql)->hashes;
return $data;
}
#-------------------------------------------------------------------------------
sub report_labels {
my ($self, $patient_ids) = @_; # arrayref of request_ids
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_report_labels');
my $data = $dbix->query($sql, @$patient_ids)->hashes;
return $data;
}
#-------------------------------------------------------------------------------
sub reports_to_issue {
my $self = shift;
my $dbix = $self->lims_dbix;
my $min_date = $dbix->select('outreach.request_report_issued',
'MIN(DATE(time))')->list; # warn $min_date; # also works fine as sub-query
my $sql = $self->get_query('outreach_reports_to_issue');
my $data = $dbix->query($sql, $min_date)->hashes;
$self->inflate_mysql_timestamp_to_datetime($_, ['auth_datetime']) for @$data;
return $data;
}
#-------------------------------------------------------------------------------
sub get_outreach_practices {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_practices');
my $practices = $dbix->query($sql)->hashes;
return $practices;
}
#-------------------------------------------------------------------------------
sub get_practice_blood_tube {
my ($self, $practice_id) = @_;
my $data
= LIMS::DB::ReferralSource->new(id => $practice_id )
->load(with => 'outreach_practice_blood_tube');
return $data;
}
#-------------------------------------------------------------------------------
sub practice_blood_tube_overrides {
my $self = shift;
my @args = (
require_objects => 'practice',
sort_by => 'TRIM(RIGHT(display_name, 8))', # ie post code, but ascii-numerical
);
my $data = LIMS::DB::Outreach::PracticeBloodTube::Manager
->get_practice_blood_tubes(@args);
return $data;
}
#-------------------------------------------------------------------------------
sub update_practice_blood_tube {
my ($self, $args) = @_;
my $practice_id = $args->{practice_id};
my $tube_type = $args->{tube_type}; # optional
my $o = LIMS::DB::Outreach::PracticeBloodTube->new(practice_id => $practice_id);
# if row exists, only valid action is to delete:
if ( $o->load(speculative => 1) ) {
$o->delete;
}
elsif ($tube_type) { # insert new entry:
$o->tube_type($tube_type);
$o->save;
}
return 0; # or could return error, but will already propagate
}
#-------------------------------------------------------------------------------
sub update_alternate_address {
my $self = shift;
my $data = shift; # warn Dumper $data;
my $patient_id = $data->{patient_id};
my $post_code = $data->{post_code};
my $address = $data->{address};
my $o = LIMS::DB::Outreach::PatientAlternateAddress
->new(patient_id => $patient_id);
if ( $o->load_speculative ) { # edit
$o->address($address);
$o->post_code($post_code);
$o->save(changes_only => 1);
}
else { # new
$o->address($address);
$o->post_code($post_code);
$o->save;
}
return 0; # or could return error, but will already propagate
}
#-------------------------------------------------------------------------------
sub get_packs_due_future {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_packs_due_summary');
# change pack_due <= CURRENT_DATE() to > CURRENT_DATE():
$sql =~ s/<= (CURRENT_DATE)/> $1/; # warn $sql;
my @packs;
my $today = LIMS::Local::Utils::time_now();
my $query = $dbix->query($sql);
while ( my $row = $query->hash ) {
$self->inflate_mysql_dates_to_datetime($row, ['pack_due']);
$self->inflate_mysql_timestamp_to_datetime($row, ['created_at']);
{ # calculate delta_days (from current_date to pack_dispatch):
my $delta = $today->delta_days($row->{pack_due})->delta_days;
$row->{delta_days} = $delta;
}
push @packs, $row;
}
return \@packs;
}
#-------------------------------------------------------------------------------
sub do_pack_dispatch {
my ($self, $request_ids) = @_; # arrayref
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $today = LIMS::Local::Utils::time_now();
my $return_due_date = $self->calculate_pack_return_date($today)->ymd;
my $update = sub {
for my $id(@$request_ids) {
my $o = LIMS::DB::Outreach::RequestPackDispatch
->new(request_id => $id)->load;
$o->pack_sent($today->ymd);
$o->return_due($return_due_date);
$o->save(changes_only => 1);
{ # request history:
$self->add_to_actions('dispatched CMP pack');
$self->do_history_log({ _request_id => $id }); # just needs _request_id attr
$self->reset_actions; # prevent build up of actions in loop
}
}
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'do_pack_dispatch() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub do_reports_issued {
my ($self, $request_ids) = @_; # warn Dumper $request_ids; # arrayref
my $db = $self->lims_db;
my $update = sub {
for my $id(@$request_ids) { # warn $id;
LIMS::DB::Outreach::RequestReportIssued->new(request_id => $id)->save;
{ # request history:
$self->add_to_actions('recorded report dispatch');
$self->do_history_log({ _request_id => $id }); # just needs _request_id attr
$self->reset_actions; # prevent build up of actions in loop
}
}
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'do_reports_issued() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub do_letter_dispatch {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $request_ids = $args->{request_ids};
my $notification_event = $args->{notification}; # 30, 60 or 90 days
my $notification = LIMS::DB::Outreach::NotificationEvent
->new(days => $notification_event)->load; # warn Dumper $notification->as_tree;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $tx = sub {
for my $id (@$request_ids) {
my $o = LIMS::DB::Outreach::RequestNotification->new(request_id => $id);
$o->event_id($notification->id); # warn Dumper $o->as_tree;
$o->insert_or_update_on_duplicate_key; # MySQL-specific syntax - updates if primary key exists
{ # request history:
my $action = sprintf "dispatched %s day outreach notification",
$notification_event;
$self->add_to_actions($action);
$self->do_history_log({ _request_id => $id }); # just needs _request_id attr
$self->reset_actions; # prevent build up of actions in loop
}
}
};
my $ok = $db->do_transaction($tx);
# don't need return value unless error:
return $ok ? 0 : 'do_letter_dispatch() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_authorised_cases_data {
my $self = shift;
my $date = shift; # warn Dumper $date; # hashref of date_from & date_to DateTimes
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_authorised_between_dates');
my @date_fields = qw(created_at authorised); # for inflation to DateTimes
my $date_from = $date->{begin}->ymd;
# make date_to extend to end of day - effectively 00:00:00 on following day:
my $date_to = $date->{end}->clone->add(days => 1)->ymd; # clone, or affects tmpl
my $query = $dbix->query( $sql, $date_from, $date_to ); # warn Dumper $query;
my @data;
while ( my $row = $query->hash ) {
$self->inflate_mysql_timestamp_to_datetime($row, \@date_fields);
push @data, $row;
}
return \@data;
}
#-------------------------------------------------------------------------------
# method shared by get_all_data & C::Outreach::edit_followup:
sub get_followup_data {
my ($self, $request_id) = @_;
my $dbix = $self->lims_dbix;
my $sql = $self->get_query('outreach_followup_data'); # p $sql;
my $data = $dbix->query($sql, $request_id)->hash;
# OK to hard-code dbname for get_meta():
my $t1_meta = $self->dbix_get_meta('outreach.request_pack_dispatch');
my $t2_meta = $self->dbix_get_meta('outreach.request_clinic_return');
# merge $t1_meta & $t2_meta - have request_id in both but OK as only want dates:
my $meta = { %$t1_meta, %$t2_meta }; # warn Dumper $meta;
my @date_fields = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_fields;
$self->inflate_mysql_dates_to_datetime($data, \@date_fields);
return $data;
}
#-------------------------------------------------------------------------------
sub get_diagnosis_ids {
my $self = shift;
my $db_name = $self->outreach_db;
$self->lims_dbix->select($db_name . '.diagnoses', 'diagnosis_id')->flat;
}
#-------------------------------------------------------------------------------
sub do_history {
my ($self, $patient_id) = @_;
my @actions = $self->all_actions;
my $dbix = $self->lims_dbix;
my $user_id = $self->user_profile->{id};
for my $action(@actions) {
my %data = (
patient_id => $patient_id,
user_id => $user_id,
action => $action,
); # warn Dumper \%data;
$dbix->insert('some_table', \%data); # request_history
}
}
#-------------------------------------------------------------------------------
sub get_practitioners_for_practice { # from M::Referrer::get_referrers_by_source_id
my ($self, $source_id) = @_;
my @args = (
query => [ 'referral_sources.id' => $source_id ],
require_objects => [
'referrer',
'parent_organisation.referral_source'
],
);
# use ReferrerDepartment - easier to retrieve data from object:
my $referrers = LIMS::DB::ReferrerDepartment::Manager
->get_referrer_department(@args);
my @data = map { $_->referrer->as_tree }
sort { $a->referrer->name cmp $b->referrer->name } @$referrers;
return \@data;
}
#-------------------------------------------------------------------------------
# get details of all requests where no follow-up sample received:
sub _get_overdue_packs_data {
my ($self, $request_ids) = @_;
my @tables = qw(
diagnoses patient_practices patient_gps outreach_pack_dispatches
referral_sources
);
my $relationships = $self->get_relationships(\@tables); # warn Dumper $relationships;
my @args = (
query => [ id => $request_ids ],
require_objects => $relationships,
sort_by => 'outreach_request_pack_dispatch.return_due',
);
my $o = LIMS::DB::Request::Manager->get_requests(@args);
my $today = LIMS::Local::Utils::time_now();
my @requests;
# calculate delta_days (from return_due to current_date):
for (@$o) {
my $data = $_->as_tree(deflate => 0); # preserve DateTime
{
my $return_due = $_->outreach_request_pack_dispatch->return_due;
my $delta = $return_due->delta_days($today)->delta_days;
$data->{delta_days} = $delta;
}
push @requests, $data;
}
return \@requests;
}
1;
