package LIMS::Model::HMRN;
use Moose;
with (
'LIMS::Model::Roles::DBIxSimple',
'LIMS::Model::Roles::QueryFormatter',
'LIMS::Model::HMRN::PrognosticIndicator',
);
extends 'LIMS::Model::Base';
use MooseX::AttributeHelpers;
use namespace::clean -except => 'meta';
has actions => (
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub { [] },
lazy => 1,
traits => ['Array'],
handles => {
add_to_actions => 'push',
all_actions => 'elements',
},
);
__PACKAGE__->meta->make_immutable;
use LIMS::Local::Utils;
use Data::Dumper;
# ------------------------------------------------------------------------------
sub has_data {
my ($self, $patient_id) = @_; # warn $patient_id;
my $dbix = $self->lims_dbix;
# minimum data set for hmrn is mdt or chronology:
for ( qw/chronologies mdt_dates/ ) {
my $tbl = 'hmrn.patient_' . $_;
return 1 if $dbix->query( "SELECT 1 FROM $tbl WHERE patient_id = ?",
$patient_id )->list;
}
return 0;
}
# ------------------------------------------------------------------------------
sub get_all_hmrn_data {
my $self = shift;
my $args = shift;
my $patient_id = $args->{patient_id}; # warn $patient_id;
my $request_id = $args->{request_id}; # warn $patient_id;
my $vars = $args->{vars}; # supplied if tx_details required
my $dbix = $self->lims_dbix;
# switch db:
# $dbix->dbh->do('use hmrn'); # needs reversing or get fatal error downstream
my $hmrn_data = { # initialise following keys:
maps => {}, # options for drop-down menus
params => { # data params from categories:
myeloid => {}, lymphoid => {}, plasmacell => {}, precursor => {},
staging => {}, # nodal, extranodal & extramedullary involved sites
indices => {}, # calculated progrostic indicators (IPI, FLIPI, etc)
comment => {}, # free-text comment
},
chronology => {}, # dates (diagnosis, first appointment, etc)
antecedent => {}, # antecedent events
treatments => [], # list of treatment episodes
category_has_data => {}, # which dataset(s) we have eg myeloid => nn
all_diagnoses => [], # list of all (ICDO3+) diagnoses for this patient
};
{ # all diagnoses (with ICDO3 designation) :
my %args = (
query => [ patient_id => $patient_id ],
require_objects => [
'patient_case.patient',
'request_report.diagnosis',
],
);
my $o = LIMS::DB::Request::Manager->get_requests(%args);
my %diagnoses = map { $_->request_report->diagnosis->name => 1 }
grep { $_->request_report->diagnosis->icdo3 } @$o;
$hmrn_data->{all_diagnoses} = \%diagnoses; # warn Dumper \%diagnoses;
}
{ # chronologies:
my $sql = q!select * from hmrn.patient_chronologies where patient_id = ?!;
my $data = $dbix->query($sql, $patient_id)->hash; # warn Dumper $dates;
my $meta = $self->get_meta('hmrn.patient_chronologies'); # warn Dumper $meta;
my @date_cols = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;
# convert MySQL dates to dt objects:
$self->inflate_mysql_dates_to_datetime($data, \@date_cols);
# provide an age calculation callback:
$data->{calculate_age} = sub {
LIMS::Local::Utils::calculate_age(@_);
};
$hmrn_data->{chronology} = $data;
}
{ # add mdt data to chronologies:
my $sql = q!select id, date from hmrn.patient_mdt_dates where
patient_id = ? order by date!;
my $dates = $dbix->query($sql, $patient_id);
while ( my $vals = $dates->hash ) { # inflate 'date' val to DT object:
$self->inflate_mysql_dates_to_datetime($vals, ['date']);
push @{ $hmrn_data->{chronology}->{mdt_dates} }, $vals;
}
}
{ # antecendent event data:
my $sql = q!select event_id from hmrn.patient_antecedent where patient_id = ?!;
my $event_id = $dbix->query($sql, $patient_id)->list;
$hmrn_data->{antecedent}{event_id} = $event_id;
}
{ # get previous therapies:
my $sql = q!select therapy from hmrn.patient_prior_therapies where patient_id = ?!;
my $tx = $dbix->query($sql, $patient_id)->flat; # warn Dumper $tx;
my %data = map { $_ => 1 } @$tx; # warn Dumper \%data;
$hmrn_data->{antecedent}{prior_tx} = \%data; # part of antecedent/prior tx set
}
{ # treatment details:
my $sql = $self->sql_lib->retr('hmrn_patient_treatment_data');
my $tx = $dbix->query($sql, $patient_id);
while ( my $vals = $tx->hash ) { # warn Dumper $vals; # dates to datetime:
$self->inflate_mysql_dates_to_datetime($vals, [ qw(start_date end_date) ]);
push @{ $hmrn_data->{treatments} }, $vals; # add to treaments array
}
}
{ # data params:
my $sql = $self->sql_lib->retr('hmrn_all_patient_params');
my $query = $dbix->query($sql, $patient_id);
while ( my $vals = $query->hash ) {
my $param_name = $vals->{param_name};
my $category = $vals->{category};
$hmrn_data->{params}{$category}{$param_name} = $vals->{result};
}
}
{ # which dataset(s) do we have - skip 'promiscuous' params & autoincrement category counter:
my $sql = $self->sql_lib->retr('hmrn_non_unique_params');
my @non_unique_params = $dbix->query($sql)->flat;
my $param_data = $hmrn_data->{params};
CATEGORY: # for each category (precursor, myeloid, etc):
while ( my($category, $data) = each %$param_data ) {
PARAM: # for each data param (albumin, Hb, etc):
while ( my ($param, $result) = each %$data ) {
# skip any params shared by >1 category:
next PARAM if grep $param eq $_, @non_unique_params;
# increment category_has_data count for category:
$hmrn_data->{category_has_data}{$category}++;
}
} # warn Dumper \%data_type;
}
{ # staging data:
my $sql = $self->sql_lib->retr('hmrn_patient_staging');
my $data = $dbix->query($sql, $patient_id)->flat;
$hmrn_data->{params}{staging}{$_}++ for @$data;
{ # add 'staging other' text data:
my $sql = 'select detail from hmrn.patient_staging_other where
patient_id = ?';
my $data = $dbix->query($sql, $patient_id)->flat;
$hmrn_data->{params}{staging}{$_}++ for @$data;
}
{ # other (free-text) sites:
my $sql = q!select details from hmrn.patient_sites_other where
patient_id =?!;
if ( $dbix->query($sql, $patient_id)->into(my $other) ) {
$hmrn_data->{params}{staging}{details} = $other;
}
}
}
{ # calculated indices (IPI, FLIPI, HIPI, etc)
my %args = (
patient_id => $patient_id,
params_data => $hmrn_data->{params},
); # warn Dumper $hmrn_data->{params};
my $indices = $self->_get_prognostic_indicators(\%args);
$hmrn_data->{params}{indices} = $indices; # warn Dumper $indices;
}
{ # comment:
my $sql = 'select * from hmrn.patient_comments where patient_id = ?';
my $data = $dbix->query($sql, $patient_id)->hash;
$self->inflate_mysql_timestamp_to_datetime($data, ['timestamp']);
$hmrn_data->{params}{comment} = $data;
}
{ # get select option maps:
my $select_option_data = $self->_get_select_option_data($vars); # vars in case tx_details req'd
$hmrn_data->{maps} = $select_option_data;
}
return $hmrn_data;
}
#-------------------------------------------------------------------------------
sub get_mdt_data {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $data
= $dbix->query('select * from hmrn.patient_mdt_dates where id = ?', $id)->hash;
# inflate 'date' val to DT object:
$self->inflate_mysql_dates_to_datetime($data, ['date']);
return $data;
}
#-------------------------------------------------------------------------------
sub get_treatment_data {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $data
= $dbix->query('select * from hmrn.patient_treatment where id = ?', $id)->hash;
# inflate dates:
$self->inflate_mysql_dates_to_datetime($data, [ qw(start_date end_date) ]);
{ # get select option maps (don't need antecedent data, but all rest req'd):
my $select_option_data # supply tx_type_id for select menu:
= $self->_get_select_option_data({ tx_type_id => $data->{tx_type_id} });
$data->{maps} = $select_option_data;
}
return $data;
}
#-------------------------------------------------------------------------------
sub get_defaults_and_ranges {
my ($self, $param) = @_;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('hmrn_defaults_and_ranges');
my $data = $dbix->query($sql, $param)->hash;
return $data;
}
#-------------------------------------------------------------------------------
sub get_parameter_constraints {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('hmrn_parameter_constraints');
my $constraints = $dbix->query($sql)->map_hashes('param_name');
return $constraints;
}
#-------------------------------------------------------------------------------
sub update_params {
my $self = shift;
my $args = shift;
my $patient_id = $args->{patient_id};
my $form_data = $args->{data}; warn Dumper $form_data;
my $data_type = $args->{data_type};
my $dbix = $self->lims_dbix;
my $params_map;
{ # get param_names for data type:
my $sql = $self->sql_lib->retr('hmrn_category_params');
$params_map = $dbix->query($sql, $data_type)->map; # warn Dumper $params_map;
}
# get existing data:
my $sql = $self->sql_lib->retr('hmrn_category_patient_params');
my $data = $dbix->query($sql, $patient_id, $data_type)->map; # warn Dumper $data;
my $table = 'hmrn.patient_params';
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $tx = sub {
if (%$data) { # update of existing:
no warnings 'uninitialized';
PARAM:
while ( my ($param_name, $param_id) = each %$params_map ) {
my $new = $form_data->{$param_name}; # warn Dumper $new;
my $old = $data->{$param_name}; # warn Dumper $old;
next PARAM if $new eq $old; # both same or both null
my %params = (
patient_id => $patient_id,
param_id => $param_id,
); # need to test for defined values to handle zeros:
if (defined $new && ! defined $old) { # add new param:
$dbix->insert($table, { %params, result => $new });
$self->add_to_actions("added new $param_name value");
}
elsif (defined $old && ! defined $new) { # delete record:
$dbix->delete($table, \%params);
$self->add_to_actions("deleted $param_name value");
}
else { # $new ne $old, so update result:
$dbix->update($table, { result => $new }, \%params );
$self->add_to_actions(
"updated $param_name value [$old -> $new]"
);
}
}
}
else { # new data:
PARAM:
while ( my ($param_name, $param_id) = each %$params_map ) {
my $result = defined $form_data->{$param_name} || next PARAM;
my %data = (
patient_id => $patient_id,
param_id => $param_id,
result => $result,
);
$dbix->insert($table, \%data);
}
$self->add_to_actions("added new $data_type data set");
}
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($tx);
# don't need return value unless error:
return $ok ? 0 : 'update_params_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub new_treatment_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $tbl = 'hmrn.patient_treatment';
my $meta = $self->get_meta($tbl); # warn Dumper $meta;
my @cols = grep { $_ !~ /\A(id|timestamp)\Z/ } keys %$meta; # warn Dumper \@cols;
my %data = map {
$_ => $args->{$_};
} grep $args->{$_}, @cols; warn Dumper \%data; return 1;
my $dbix = $self->lims_dbix;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $new = sub {
$dbix->insert($tbl, \%data);
$self->add_to_actions('added new treatment dataset');
$self->do_history($data{patient_id});
};
my $ok = $db->do_transaction($new);
# don't need return value unless error:
return $ok ? 0 : 'new_treatment_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_tx_type_map {
my $self = shift;
my $dbix = $self->lims_dbix;
my $map = $dbix->query( 'select description, id from hmrn.treatment_types')->map;
return $map;
}
#-------------------------------------------------------------------------------
sub get_history {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $sql = q!select * from hmrn.history h join users u on h.user_id = u.id
where patient_id = ? order by time!;
my $data = $dbix->query($sql, $id)->hashes;
$self->inflate_mysql_timestamp_to_datetime($_, ['time']) for @$data;
return $data;
}
#-------------------------------------------------------------------------------
sub update_treatment_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $tbl = 'hmrn.patient_treatment';
my $meta = $self->get_meta($tbl); # warn Dumper $meta;
# get patient_treatment data cols (ie not PK, timestamp, patient_id):
my @cols = grep { $_ !~ /\A(id|patient_id|timestamp)\Z/ } keys %$meta; # warn Dumper \@cols;
# date cols:
my @date_cols = grep $meta->{$_}->{type} eq 'date', keys %$meta; # warn Dumper \@date_cols;
$args->{$_} = LIMS::Local::Utils::to_datetime_using_datecalc($args->{$_})
for grep $args->{$_}, @date_cols; # warn Dumper $args;
my $dbix = $self->lims_dbix;
my $data = $dbix->query("select * from $tbl where id = ?", $args->{id})->hash;
$self->inflate_mysql_dates_to_datetime($data, \@date_cols); # inflate $data dates
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
my @updates = ();
# non-date cols:
COL: for my $col(@cols) {
next COL if $meta->{$col}->{type} eq 'date'; # skip date cols - done later
my $new = $args->{$col};
my $old = $data->{$col};
if ($new && $old && $new ne $old) { # changed
push @updates, ( $col => $new );
$self->add_to_actions("updated treatment $col [id = $args->{id}]");
}
elsif ($new && ! $old) {
push @updates, ( $col => $new );
$self->add_to_actions("added new treatment $col [id = $args->{id}]");
}
elsif ($old && ! $new) {
push @updates, ( $col => undef );
$self->add_to_actions("deleted treatment $col [id = $args->{id}]");
}
else { next COL } # both same or null so skip
}
# date cols:
COL: for my $col(@date_cols) {
my $new = $args->{$col}; # warn $new->datetime
my $old = $data->{$col}; # warn $old->datetime
if ($new && $old) {
next COL unless DateTime->compare($old, $new); # true if different
push @updates, ( $col => $new->ymd );
$self->add_to_actions("updated treatment $col [id = $args->{id}]");
}
elsif ($new && ! $old) {
push @updates, ( $col => $new->ymd );
$self->add_to_actions("added new treatment $col [id = $args->{id}]");
}
elsif ($old && ! $new) {
push @updates, ( $col => undef );
$self->add_to_actions("deleted treatment $col [id = $args->{id}]");
}
else { next COL } # both null so skip
}
if (@updates) { warn Dumper \@updates; warn Dumper [$self->all_actions];
#$dbix->update($tbl, { @updates }, { id => $args->{id} });
#$self->do_history($data->{patient_id});
}
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_treatment_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_mdt_date {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $date = LIMS::Local::Utils::to_datetime_using_datecalc($args->{date});
my $tbl = 'hmrn.patient_mdt_dates';
my $dbix = $self->lims_dbix;
my $patient_id
= $dbix->query("select patient_id from $tbl where id = ?", $args->{id})->list;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
$dbix->update('hmrn.patient_mdt_dates',
{ date => $date->ymd },
{ id => $args->{id} }
);
$self->add_to_actions("updated mdt date [id = $args->{id}]");
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_mdt_date() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub delete_mdt_date {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $tbl = 'hmrn.patient_mdt_dates';
my $patient_id
= $dbix->query("select patient_id from $tbl where id = ?", $id)->list;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $delete = sub {
$dbix->delete($tbl, { id => $id });
$self->add_to_actions('deleted mdt date');
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($delete);
# don't need return value unless error:
return $ok ? 0 : 'delete_mdt_date() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub delete_treatment_data {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $tbl = 'hmrn.patient_treatment';
my $patient_id
= $dbix->query("select patient_id from $tbl where id = ?", $id)->list;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $delete = sub {
$dbix->delete($tbl, { id => $id });
$self->add_to_actions('deleted treatment data');
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($delete);
# don't need return value unless error:
return $ok ? 0 : 'delete_treatment_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_new_diagnoses {
my $self = shift;
my $args = shift;
# get HMRN parent organisation ids:
my $o = LIMS::DB::LocalNetworkLocation::Manager->get_local_network_locations;
my @parent_organisation_ids = map { $_->parent_id } @$o;
# get referral_type.id for practices (saves multi_many_ok flag in query):
my $ref_type = LIMS::DB::ReferralType->new(description => 'practice')->load;
my @query = (
'request_history.action' => 'authorised',
or => [ # any network hospital or GP practice:
'parent_organisations.id' => \@parent_organisation_ids,
'parent_organisations.referral_type_id' => $ref_type->id, # GP's
],
or => [ # ICDO3 or MGUS diagnoses:
'request_report.diagnosis.icdo3' => { like => '%3' },
'request_report.diagnosis.icdo3' => '9765/1', # MGUS
],
);
{ # calculate requested duration (previous_week, days, date_range, etc):
my $constraints = $self->_get_hmrn_new_diagnoses_constraints($args);
push @query, @$constraints;
}
my @tables = qw( patients diagnoses parent_organisations request_history
referrers );
my $relationships = $self->get_relationships(\@tables);
my @params = (
query => \@query,
require_objects => $relationships,
);
my $cases = LIMS::DB::Request::Manager->get_requests(@params);
return $cases;
}
# ------------------------------------------------------------------------------
sub get_patient_demographics {
my ($self, $patient_id) = @_;
my $data = LIMS::DB::PatientDemographic->new(patient_id => $patient_id)
->load( with => [ 'referrer', 'practice' ], speculative => 1 );
return $data;
}
# ------------------------------------------------------------------------------
sub update_patient_demographics {
my ($self, $args) = @_; # warn Dumper $args;
my $patient_id = $args->{patient_id};
# format post-code:
$args->{post_code} = LIMS::Local::Utils::format_postcode($args->{post_code});
my $user_id = $self->user_profile->{id};
my $o = LIMS::DB::PatientDemographic->new(patient_id => $patient_id);
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
if ($o->load_speculative) {
my $old = $o->clone->as_tree;
# update object with new data:
map {
$o->$_($args->{$_})
} grep $_ ne 'patient_id', keys %$args;
$o->save(changes_only => 1);
my $new = $o->clone->as_tree;
my @changed = do {
no warnings 'uninitialized';
grep { $new->{$_} ne $old->{$_} } keys %$old;
}; # warn Dumper \@new;
for my $field (@changed) {
my $action = qq!updated '$field' from $old->{$field}!;
my %data = (
patient_id => $patient_id,
user_id => $user_id,
action => $action,
);
LIMS::DB::PatientDemographicHistory->new(%data)->save;
}
}
else { # create new:
map { $o->$_($args->{$_}) } keys %$args;
$o->save;
}
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_patient_demographics() error - ' . $db->error;
}
# ------------------------------------------------------------------------------
sub update_comment {
my ($self, $data) = @_;
my $patient_id = $data->{patient_id}; # warn Dumper $patient_id;
my $form_param = $data->{comment}; # warn Dumper $form_param;
my $dbix = $self->lims_dbix;
my $table = 'hmrn.patient_comments';
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
my $sql = "select comment from $table where patient_id = ?";
if ( my $comment = $dbix->query($sql, $patient_id)->list ) { # warn Dumper $comment;
return 0 if $form_param && $form_param eq $comment; # skip if no change
if ($form_param) { # have both & they're different so do update:
$dbix->update($table,
{ comment => $form_param }, { patient_id => $patient_id }
);
$self->add_to_actions('updated comment');
}
else { # no form_param so delete:
$dbix->delete($table, { patient_id => $patient_id });
$self->add_to_actions('deleted comment');
}
}
else { # have new data:
$dbix->insert($table,
{ patient_id => $patient_id, comment => $comment }
);
$self->add_to_actions('added comment');
}
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_comment() error - ' . $db->error;
}
# ------------------------------------------------------------------------------
sub update_staging_data {
my ($self, $args) = @_;
my $patient_id = $args->{patient_id};
my $form_params = $args->{form_params};
my $dbix = $self->lims_dbix;
my $sites_map
= $dbix->query('select description, id from hmrn.staging_sites')->map;
my @site_ids = map $sites_map->{$_}, @$form_params; # warn Dumper \@site_ids;
my $staging_tbl = 'hmrn.patient_staging_site';
my $other_tbl = 'hmrn.patient_staging_other';
my $staging_opts = $self->get_enum_opts($other_tbl);
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
{ # clear any existing data:
my $i = grep {
$dbix->query(
qq!select 1 from $_ where patient_id = ?!, $patient_id )->list;
} ($staging_tbl, $other_tbl);
if ($i) { # have existing data:
for my $tbl($staging_tbl, $other_tbl) {
$dbix->delete($tbl, { patient_id => $patient_id });
}
$self->add_to_actions('updated staging data');
}
else {
$self->add_to_actions('added new staging data');
}
}
# staging sites:
for my $id(@site_ids) {
$dbix->insert($staging_tbl,
{ patient_id => $patient_id, site_id => $id }
);
}
# staging other deails:
for my $opt( @$staging_opts ) {
$dbix->insert($other_tbl,
{ patient_id => $patient_id, detail => $opt }
);
}
if ( my $others = $form_params->{other_sites} ) {
my $tbl = 'hmrn.patient_sites_other';
my $sql = "select details from $tbl where patient_id = ?";
my $old = $dbix->query($sql, $patient_id)->list;
no warnings 'uninitialized';
if ($others ne $old) {
if ($others && ! $old) { # new data:
$dbix->insert($tbl,
{ patient_id => $patient_id, details => $others }
);
}
elsif ($old && ! $others) { # delete:
$dbix->delete($tbl, { patient_id => $patient_id });
}
else { # update
$dbix->update($tbl,
{ details => $others },
{ patient_id => $patient_id }
);
}
}
}
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_lymphoid_involvement() error - ' . $db->error;
}
# ------------------------------------------------------------------------------
sub update_antecedent_events {
my ($self, $args) = @_; # warn Dumper $args;
my $patient_id = $args->{patient_id};
my $dbix = $self->lims_dbix;
my $antecedent_tbl = 'hmrn.patient_antecedent';
my $prior_tx_tbl = 'hmrn.patient_prior_therapies';
my $therapy_opts = $self->get_enum_opts($prior_tx_tbl, 'therapy'); # ie Rx, Cx
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
{ # antecedent event:
my $sql = qq!select * from $antecedent_tbl where patient_id = ?!;
if ( my $data = $dbix->query($sql, $patient_id)->hash ) { # warn Dumper $data;
my %data = ( event_id => $args->{event_id} || undef );
$dbix->update($antecedent_tbl, \%data, { patient_id => $patient_id });
my $action = $args->{event_id}
? "updated antecedent event"
: "deleted antecedent event";
$self->add_to_actions($action);
}
elsif ( my $event_id = $args->{event_id} ) {
my %data = (
patient_id => $patient_id,
event_id => $event_id,
);
$dbix->insert($antecedent_tbl, \%data);
$self->add_to_actions("added new antecedent event");
}
}
{ # prior therapies:
my $sql = qq!select therapy from $prior_tx_tbl where patient_id = ?!;
if ( my $data = $dbix->query($sql, $patient_id)->flat ) { # warn Dumper $data;
foreach my $tx(@$therapy_opts) {
my %data = (
patient_id => $patient_id,
therapy => $tx,
);
my $new = $args->{$tx};
my $old = $data->{$tx};
if ( $new && ! $old ) {
$dbix->insert($prior_tx_tbl, \%data);
$self->add_to_actions("added new prior Tx $tx");
}
elsif ( $old && ! $new ) {
$dbix->delete($prior_tx_tbl, \%data );
$self->add_to_actions("deleted prior Tx $tx entry");
}
else {} # old & new both same value or null, so skip
}
}
else {
foreach my $tx(@$therapy_opts) {
next unless $args->{$tx};
my %data = (
patient_id => $patient_id,
therapy => $tx,
);
$dbix->insert($prior_tx_tbl, \%data);
$self->add_to_actions("added new prior Tx $tx");
}
}
}
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_antecedent_events() error - ' . $db->error;
}
# ------------------------------------------------------------------------------
sub update_patient_chronologies {
my ($self, $args) = @_; # warn Dumper $args; # patient_id + dates
my $patient_id = $args->{patient_id};
my $dbix = $self->lims_dbix;
my $table = 'hmrn.patient_chronologies';
# get date cols in patient_chronologies table:
my $meta = $self->get_meta($table);
my @date_cols = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
# get existing chronologies:
my $sql = qq!select * from $table where patient_id = ?!;
if ( my $data = $dbix->query($sql, $patient_id)->hash ) { # warn Dumper $data;
$self->inflate_mysql_dates_to_datetime($data, \@date_cols);
my @updates = ();
COL: for my $col(@date_cols) {
my $new = $args->{$col}; # in EU format
my $old = $data->{$col}; # in DT format
if ( $new && $old ) {
# convert new to DT object:
my $new_dt = LIMS::Local::Utils::to_datetime_using_datecalc($new);
next COL unless DateTime->compare($old, $new_dt); # true if different
push @updates, ( $col => $new_dt->ymd );
$self->add_to_actions("updated date $col");
}
elsif ( $old && ! $new ) {
push @updates, ( $col => undef );
$self->add_to_actions("deleted date $col");
}
elsif ( $new && ! $old ) {
my $dt = LIMS::Local::Utils::to_datetime_using_datecalc($new);
push @updates, ( $col => $dt->ymd );
$self->add_to_actions("added new date $col");
}
else { next COL } # ignore if no new or old
}
if (@updates) { # warn Dumper \@updates;
$dbix->update($table, { @updates }, { patient_id => $patient_id } );
}
}
else { # insert new data:
my $cols = keys %$meta;
my %data = map { $_ => $args->{$_} } @$cols; # warn Dumper \%data;
$dbix->insert($table, \%data);
$self->add_to_actions("added new chronology data");
}
# mdt_date always new (not edited):
if ( my $mdt_date = $args->{mdt_date} ) {
my $date = LIMS::Local::Utils::date_to_mysql($mdt_date);
my %data = (
patient_id => $patient_id,
date => $date,
); # warn Dumper \%data;
$dbix->insert('hmrn.patient_mdt_dates', \%data);
$self->add_to_actions("added new mdt meeting date");
}
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_patient_demographics() error - ' . $db->error;
}
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('hmrn.history', \%data);
}
}
# ------------------------------------------------------------------------------
sub is_in_outreach {
my ($self, $patient_id) = @_;
my $dbix = $self->lims_dbix;
my $sql = 'select 1 from outreach.dispatch_details where patient_id = ?';
return $dbix->query( $sql, $patient_id )->list;
}
# ------------------------------------------------------------------------------
sub get_tx_details_for_tx_type {
my ($self, $type_id) = @_;
my $dbix = $self->lims_dbix;
my $sql = q!select id, description from hmrn.treatment_details where
type_id = ? order by description!;
return $dbix->query( $sql, $type_id )->hashes; # array(ref) of hashes
}
# ----------------------- private methods --------------------------------------
sub _get_prognostic_indicators {
my ($self, $args) = @_;
# all calculations handled by Model::HMRN::PrognosticIndicator:
my $prognostic_indicators = $self->prognostic_indicators($args);
return $prognostic_indicators;
}
sub _get_select_option_data {
my $self = shift;
my $args = shift || {}; # optional - supplied only if tx_details required
my $dbix = $self->lims_dbix;
my %maps = ();
{ # locations:
my $locations = $dbix->query(q!select location,id from hmrn.locations!)->map;
$maps{location} = $locations;
}
{ # antecedent events:
my $antecedent
= $dbix->query(q!select event,id from hmrn.antecedent_events!)->map;
$maps{antecedent} = $antecedent;
}
{ # treatment types:
my $tx_types
= $dbix->query(q!select description,id from hmrn.treatment_types!)->map;
$maps{tx_type} = $tx_types;
}
{ # unique tx_type_ids from treatment_details table:
my $sql = q!select distinct(type_id) from hmrn.treatment_details!;
my $unique_tx_type_ids = $dbix->query($sql)->flat; # warn Dumper $unique_tx_type_ids;
$maps{tx_type_ids} = $unique_tx_type_ids;
}
{ # treatment reponses:
my $opts = $self->get_enum_opts('hmrn.patient_treatment', 'response');
$maps{response} = $opts; # warn Dumper $opts;
}
{ # parameter validation data:
my $sql = q!select * from hmrn.parameters!;
my $data = $dbix->query($sql)->map_hashes('param_name'); # HoH with keys = param_name
$maps{parameters} = $data; # warn Dumper $data;
}
{ # menu options:
my $sql = $self->sql_lib->retr('hmrn_menu_options');
my $data = $dbix->query($sql)->map; # HoH with keys = param_name
$maps{menu_options} = $data; # warn Dumper $data;
}
# treatment details for treatment_type (if submitted):
if ( my $tx_type_id = $args->{tx_type_id} ) {
my $sql = q!select id,description from hmrn.treatment_details where type_id = ?!;
my $tx_details = $dbix->query($sql, $tx_type_id)->map;
# tx_details is ajax function in original form, so not loaded in _get_select_option_data()
$maps{tx_details} = $tx_details;
}
return \%maps;
}
1;
