package LIMS::Model::Outreach;
use Moose;
with (
'LIMS::Model::Roles::Query', # get_sql_with_constraint(), sql_lib()
'LIMS::Model::Roles::Outreach',
'LIMS::Model::Roles::DBIxSimple',
'LIMS::Model::Roles::RequestUpdate', # do_history_log
);
extends 'LIMS::Model::Base';
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::Dumper;
use DateTime;
#-------------------------------------------------------------------------------
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->sql_lib->retr('outreach_lab_params');
my $query = $dbix->query($sql);
# get list of cols from defaults_and_ranges table:
my $meta = $self->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;
}
}
{ # add lab_test results:
my $sql = $self->sql_lib->retr('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->sql_lib->retr('outreach_patient_demographics');
my $demographics = $dbix->query($sql, $patient_id)->hash;
$data{demographics} = $demographics;
}
{ # questionnaire:
my $sql = $self->sql_lib->retr('outreach_patient_questionnaire');
my $data = $dbix->query($sql, $request_id)->hash;
$data{questionnaire} = $data;
}
{ # questionnaire details:
my $sql = $self->sql_lib->retr('outreach_questionnaire_details');
my $data = $dbix->query($sql, $request_id)->hashes; # array of hashes
for (@$data) {
my $field = $_->{field_name};
$data{questionnaire}{details}{$field} = $_->{details};
}
}
{ # followup 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;
}
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;
my $sql = $self->sql_lib->retr('outreach_menu_options');
my $query = $dbix->query($sql);
my %opts;
while ( my $vars = $query->array ) {
my ($field_name, $detail) = @$vars;
push @{ $opts{$field_name} }, $detail;
}
{ # add follow_up options:
my $followup_options = $self->followup_options_map;
$opts{followup_options} = $followup_options;
}
return \%opts; # warn Dumper \%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->sql_lib->retr('outreach_request_results');
# can't use ?? placeholders in sql as already using 1 placeholder:
if ( ref $field eq 'ARRAY' ) {
$sql =~ s/%PARAMS%/join ',', map $dbix->dbh->quote($_), @$field/e;
}
else {
$sql =~ s/%PARAMS%/$dbix->dbh->quote($field)/e;
} # warn $sql;
my $data = $dbix->query( $sql, $patient_id )->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->sql_lib->retr('outreach_request_results');
# can't use ?? placeholders in sql as already using 1 placeholder:
$sql =~ s/%PARAMS%/join ',', map $dbix->dbh->quote($_), @fields/e; # warn $sql;
my $data = $dbix->query( $sql, $patient_id )->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};
if ( $args->{imperial_stones} && ! $args->{weight} ) { # 'imperial_pounds' optional
$args->{weight} = LIMS::Local::Utils::convert_imperial($args);
} # warn Dumper $args;
my @tbls = qw(
outreach_questionnaire_adenopathy
outreach_questionnaire_treatment
outreach_questionnaire_symptoms
outreach_questionnaire_service
outreach_questionnaire_pain
outreach_questionnaire_eq5d
);
# create hash of corresponding classes for above tables (*in same order*):
my %class_for_tbl; @class_for_tbl{@tbls} = qw(
QuestionnaireAdenopathy QuestionnaireTreatment QuestionnaireSymptoms
QuestionnaireService QuestionnairePain QuestionnaireEQ5D
);
# get existing questionnaire data for this request:
my $data = LIMS::DB::Request->new(id => $request_id)
->load( with => \@tbls ); # warn Dumper $data;
# create hashref of $data object to avoid 2nd db query when testing for accessors:
my $h = $data->as_tree;
# take list of tables, if accessor exists, update it, otherwise create new:
for my $tbl (@tbls) { # eg outreach_questionnaire_pain
if ( $h->{$tbl} ) { # exists so update it:
my $o = $data->$tbl; # get object eg $data->outreach_questionnaire_pain
my @cols = grep $_ ne 'request_id', $o->meta->column_names;
COL: for (@cols) {
no warnings 'uninitialized'; # ie optional cols
next COL if $o->$_ eq $args->{$_}; # skip unchanged
$o->$_($args->{$_});
}
}
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) {
$data{request_id} = $args->{request_id};
$data->$tbl(%data);
} # else { warn "$tbl has no data" }
}
}
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
# update/insert all tables:
for my $tbl (@tbls) { # warn $tbl; warn Dumper $data->$tbl;
next unless $data->$tbl; # skip empty table datasets
$data->$tbl->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_patient_questionnaire() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_followup {
my ($self, $args) = @_; # warn Dumper $args;
my $option_id = $args->{followup_option_id}; # required
my $request_id = $args->{_request_id}; # required
my $return_due = $args->{return_due}; # optional
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 );
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 folloup (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 ) {
# get value of new duration (will be undef if not a duration choice):
my $number_of_months = $self->get_followup_option_duration($option_id);
# where new follow-up option is a duration (including '0'):
if ( defined $number_of_months ) { # warn Dumper $months_int;
# calculate new pack dispatch due date:
my %args = (
int => $number_of_months,
date => $data->created_at, # datetime object required
);
my $new_pack_dispatch_date
= $self->calculate_pack_dispatch_date(\%args);
# 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,
);
}
}
# 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);
}
}
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
$data->outreach_request_followup->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->sql_lib->retr('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_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->sql_lib->retr('outreach_most_recent');
$dbix->query($sql, 'community monitoring', 'outreach')->map; # hashref map
};
my $dfm = DateTime::Format::MySQL->new();
# get all requests where return_due date < today:
my $requests = do {
my $sql = $self->sql_lib->retr('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 ['sent:'.$ref->{pack_sent},'back:'.$entry,'cmp:'.$val];
next REQ if $val < 0; # ie $most_recent_date AFTER $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;
}
# get details of all requests where no follow-up sample received:
my $data = $self->_get_overdue_packs_data(\@request_ids);
return $data;
}
#-------------------------------------------------------------------------------
sub get_packs_due_details {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('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) = @_;
my (%immunology, $questionnaire);
my $electrophoresis = $vals->{electrophoresis};
my $neoplastic_b = $vals->{neoplastic_b_cells};
# IgM paraprotein:
if ( defined $electrophoresis && $electrophoresis =~ /^IgM/ ) {
$questionnaire = 'blpd';
$immunology{$_}++ for qw(igs sep ppq);
}
# MGUS:
elsif ( $vals->{diagnosis} =~ 'MGUS|gammopathy' ) {
$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';
$immunology{$_}++ for qw(igs sep);
}
# known electrophoresis result but no paraprotein:
elsif ( $electrophoresis =~ /^No/ ) {
$questionnaire = 'blpd';
$immunology{$_}++ for qw(igs);
}
# any (non-IgM) paraprotein:
else {
$questionnaire = 'combined';
$immunology{$_}++ for qw(igs sep ppq);
}
}
$vals->{immunology_req} = \%immunology;
$vals->{questionnaire} = $questionnaire;
}
#-------------------------------------------------------------------------------
sub get_packs_due_summary {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('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->sql_lib->retr('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->sql_lib->retr('outreach_report_labels');
my $data = $dbix->query($sql, @$patient_ids)->hashes;
return $data;
}
#-------------------------------------------------------------------------------
sub get_outreach_practices {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('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->sql_lib->retr('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);
}
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'do_pack_dispatch() 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->sql_lib->retr('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->sql_lib->retr('outreach_followup_data');
my $data = $dbix->query($sql, $request_id)->hash;
my $meta = $self->get_meta('outreach.request_pack_dispatch'); # warn Dumper $meta;
my @date_fields = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;
$self->inflate_mysql_dates_to_datetime($data, \@date_fields);
return $data;
}
#-------------------------------------------------------------------------------
sub get_diagnosis_ids {
my $self = shift;
my $dbix = $self->lims_dbix;
my $ids = $dbix->query('select diagnosis_id from outreach.diagnoses')->flat;
return $ids;
}
#-------------------------------------------------------------------------------
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 { # warn Dumper $_->as_tree;
[ $_->referrer->id, $_->referrer->name ];
} 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.pack_sent',
);
my $o = LIMS::DB::Request::Manager->get_requests(@args);
my $today = LIMS::Local::Utils::time_now();
my @requests;
# calculate delta_days (from pack_dispatch to current_date):
for (@$o) {
my $data = $_->as_tree(deflate => 0); # preserve DateTime
{
my $pack_sent = $_->outreach_request_pack_dispatch->pack_sent;
my $delta = $pack_sent->delta_days($today)->delta_days;
$data->{delta_days} = $delta;
}
push @requests, $data;
}
return \@requests;
}
1;
