package LIMS::Model::HMRN;
use Moose;
with (
'LIMS::Model::HMRN::Data',
'LIMS::Model::Roles::Query', # get_sql_with_constraint(), sql_lib()
'LIMS::Model::HMRN::PrognosticIndicator',
);
extends 'LIMS::Model::Base';
use namespace::clean -except => 'meta';
has _patient_id => (is => 'rw', isa => 'Int'); # set in get_all_hmrn_data()
has actions => (
is => 'ro',
isa => 'ArrayRef[Str]',
traits => ['Array'],
default => sub { [] },
lazy => 1,
handles => {
add_to_actions => 'push',
unique_actions => 'uniq', # skip duplicates
all_actions => 'elements',
},
);
__PACKAGE__->meta->make_immutable;
use LIMS::Local::Utils;
use Data::Dumper;
# for Roles (HMRN::Data & HMRN::PrognosticIndicator):
sub patient_id { return shift->_patient_id }
# ------------------------------------------------------------------------------
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/event mdt_dates/ ) {
my $tbl = 'hmrn.patient_' . $_;
return 1 if $dbix->select($tbl, 1, { patient_id => $patient_id })->list;
}
return 0;
}
# ------------------------------------------------------------------------------
sub get_all_hmrn_data {
my $self = shift;
my $args = shift;
my $vars = $args->{vars}; # supplied if tx_details required
$self->_patient_id($args->{patient_id});
my $data = { # initialise following keys:
maps => {}, # options for drop-down menus
params => { # data params from categories:
myeloid => {}, lymphoid => {}, plasmacell => {}, precursor => {},
indices => {}, # calculated prognostic indicators (IPI, FLIPI, etc)
comment => {}, # free-text comment
},
imaging => {}, # CT & PET scan data
event_dates => {}, # event dates
referrals => [], # referral pathway
antecedent => {}, # antecedent events
treatments => [], # list of treatment episodes
all_diagnoses => [], # all (ICDO3+) diagnoses for this patient
category_has_data => {}, # which dataset(s) we have eg myeloid => nn
};
{ # get all this patients diagnoses (with an ICDO3 designation):
my $icdo3_diagnoses = $self->_get_all_icdo3_diagnoses(); # arrayref
$data->{all_diagnoses} = $icdo3_diagnoses;
}
# dates of MDT meetings:
$self->mdt_dates($data);
# event (diagnosed, first appointment, etc) dates:
$self->event_dates($data);
# referral pathway:
$self->referral_pathway($data);
# antecedent events & previous radio & chemotherapy:
$self->antecedent_events($data);
# treatment history:
$self->treatment($data);
# laboratory, physiological, etc parameters:
$self->data_params($data);
# which dataset(s) do we have:
$self->dataset_type($data);
# imaging data (CT & PET scan - nodal & extranodal site involvements):
$self->imaging_data($data);
# comments:
$self->comments($data);
{ # get select option maps (pass vars in case tx_details req'd):
my $select_option_data = $self->_get_select_option_data($vars);
$data->{maps} = $select_option_data;
}
# calculated prognostic indices (IPI, Ann Arbor, etc):
$self->calculated_indices($data);
return $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_categories {
my $self = shift;
my $dbix = $self->lims_dbix;
my $categories = $dbix->query('select category from hmrn.categories')->flat;
return $categories;
}
#-------------------------------------------------------------------------------
sub get_active_params_for_category {
my ($self, $category) = @_;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('hmrn_category_params');
my $category_params = $dbix->query($sql, $category)->map;
my $all_params
= $dbix->query('select param_name, id from hmrn.parameters')->map;
my %map = map {
$_ => {
id => $all_params->{$_},
selected => $category_params->{$_} ? 1 : 0,
},
} keys %$all_params; # warn Dumper \%map;
return \%map;
}
#-------------------------------------------------------------------------------
sub update_category_parameter {
my $self = shift;
my $args = shift;
my $param_ids = $args->{param_ids};
my $category = $args->{category};
my $dbix = $self->lims_dbix;
my $tbl = 'hmrn.category_parameter';
my $sql = 'select id from hmrn.categories where category = ?';
$dbix->query($sql, $category)->into(my $category_id );
my $update = sub {
# clear exsiting params for this category:
$dbix->delete($tbl, { category_id => $category_id });
$dbix->insert($tbl, { category_id => $category_id, parameter_id => $_ })
for @$param_ids;
};
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_category_parameter() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_imaging_data {
my ($self, $event_id) = @_;
my $dbix = $self->lims_dbix;
my %h = ( imaging_event_id => $event_id );
my %data;
{ # patient_imaging options:
my $map = $dbix->select('hmrn.patient_imaging_option',
['imaging_option_id', 1], \%h )->map;
$data{options_map} = $map; # warn Dumper $map;
}
{ # patient_imaging_other.details:
my $tbl = 'hmrn.patient_imaging_other';
$dbix->select($tbl, ['details'], \%h)->into(my $details);
$data{details} = $details; # warn Dumper $details;
}
{ # scan date:
my @fields = qw(id scan_type dataset stage date);
my $ref = $dbix->select('hmrn.patient_imaging_event',
\@fields, { id => $event_id })->hash;
$self->inflate_mysql_dates_to_datetime($ref, ['date']);
$data{$_} = $ref->{$_} for @fields;
}
{ # SUV & deauville data - only exists for pet scan:
my @cols = qw(param result);
my $map = $dbix->select('hmrn.patient_pet_score', \@cols, \%h)->map;
$data{pet_scan_scores} = $map; # warn Dumper $map;
}
return \%data;
}
#-------------------------------------------------------------------------------
sub get_referral_data {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $tbl = 'hmrn.patient_referrals';
my $meta = $self->dbix_get_meta($tbl); # warn Dumper $meta;
my @cols = keys %$meta; # warn Dumper \@cols;
my $data = $dbix->select($tbl, \@cols, { id => $id })->hash;
# inflate dates:
my @dates = qw(referral_date date_first_seen);
$self->inflate_mysql_dates_to_datetime($data, \@dates);
{ # get select option maps:
my @cols = qw(description id); # same for both tables
{ # referral_types:
my $map = $dbix->select('hmrn.referral_type_options', \@cols)->map;
$data->{maps}{referral_types} = $map;
}
{ # referral_sources:
my $map = $dbix->select('hmrn.referral_source_options', \@cols)->map;
$data->{maps}{referral_sources} = $map;
}
} # warn Dumper $data;
return $data;
}
#-------------------------------------------------------------------------------
sub get_treatment_data {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $tbl = 'hmrn.patient_treatment';
my $meta = $self->dbix_get_meta($tbl); # warn Dumper $meta;
my @cols = keys %$meta; # warn Dumper \@cols;
my $data = $dbix->select($tbl, \@cols, { 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 %h = ( tx_type_id => $data->{tx_type_id} ); # supply tx_type_id for select menu:
my $select_option_data = $self->_get_select_option_data(\%h);
$data->{maps} = $select_option_data;
} # warn Dumper $data;
return $data;
}
#-------------------------------------------------------------------------------
sub get_imaging_options {
my $self = shift;
my $dbix = $self->lims_dbix;
my $map = $dbix->select('hmrn.imaging_options', ['description', 'id'])->map;
return $map;
}
#-------------------------------------------------------------------------------
sub get_treatment_options {
my $self = shift;
my $dbix = $self->lims_dbix;
my %opts = ();
{
my $tx_types = $self->get_tx_type_map;
$opts{tx_types} = $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;
$opts{tx_type_ids} = $unique_tx_type_ids;
} # warn Dumper \%opts;
return \%opts;
}
#-------------------------------------------------------------------------------
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; # warn Dumper $args;
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 ) {
defined $form_data->{$param_name} || next PARAM; # maybe '0'
my %data = (
patient_id => $patient_id,
param_id => $param_id,
result => $form_data->{$param_name},
); # warn Dumper \%data;
$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_imaging_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $dbix = $self->lims_dbix;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $to_mysql_date = sub { # for imaging_event
LIMS::Local::Utils::to_datetime_using_datecalc(@_)->ymd;
};
my $new = sub {
my $event_id; # set below:
{ # imaging event:
my $tbl = 'hmrn.patient_imaging_event';
my %h = map +($_ => $args->{$_}), qw(patient_id dataset scan_type); # warn Dumper \%h;
$h{stage} = $args->{scan_stage};
$h{date} = &$to_mysql_date($args->{scan_date});
$dbix->insert($tbl, \%h);
$event_id = $dbix->dbh->last_insert_id( undef, undef, $tbl, 'id' );
}
if ( $args->{option_id} ) { # patient_imaging options:
# option_id MUST be arrayref (single val passed as scalar):
my $option_id = ref $args->{option_id} eq 'ARRAY'
? $args->{option_id} : [ $args->{option_id} ];
for (@$option_id) {
my %h = (imaging_event_id => $event_id, imaging_option_id => $_);
$dbix->insert('hmrn.patient_imaging_option', \%h);
}
}
if ( my $details = $args->{details} ) { # patient_imaging_other:
my %h = ( imaging_event_id => $event_id, details => $details );
$dbix->insert('hmrn.patient_imaging_other', \%h);
}
PARAM: for my $p( qw/suv_max deauville/ ) { # pet scan opts
my $result = $args->{$p} or next PARAM;
my %h = (
imaging_event_id => $event_id, param => $p, result => $result,
);
$dbix->insert('hmrn.patient_pet_score', \%h);
}
my $str = sprintf 'added new %s scan dataset', uc $args->{scan_type};
$self->add_to_actions($str);
$self->do_history($args->{patient_id});
};
my $ok = $db->do_transaction($new);
# don't need return value unless error:
return $ok ? 0 : 'new_imaging_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub new_referral_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $tbl = 'hmrn.patient_referrals';
my $meta = $self->dbix_get_meta($tbl); # warn Dumper $meta;
my @cols = grep { $_ !~ /\A(id|timestamp)\Z/ } keys %$meta; # warn Dumper \@cols;
my @date_cols = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;
my %data = map {
$_ => $args->{$_};
} grep $args->{$_}, @cols;
map { # transform EU dates to MySQL format:
$data{$_} = LIMS::Local::Utils::date_to_mysql($data{$_})
} @date_cols; # warn Dumper \%data;
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 referral dataset');
$self->do_history($args->{patient_id}); # same as $data{patient_id}
};
my $ok = $db->do_transaction($new);
# don't need return value unless error:
return $ok ? 0 : 'new_referral_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->dbix_get_meta($tbl); # warn Dumper $meta;
my @cols = grep { $_ !~ /\A(id|timestamp)\Z/ } keys %$meta; # warn Dumper \@cols;
my @date_cols = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;
my %data = map {
$_ => $args->{$_};
} grep $args->{$_}, @cols;
map { # transform EU dates to MySQL format:
$data{$_} = LIMS::Local::Utils::date_to_mysql($data{$_})
} @date_cols; # warn Dumper \%data;
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($args->{patient_id}); # same as $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_tx_options {
my ($self, $vars) = @_;
my $new_tx_detail = $vars->{new_tx_detail};
my $new_tx_type = $vars->{new_tx_type};
my $tx_type_id = $vars->{tx_type_id};
my $dbix = $self->lims_dbix;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
# possibilities are: new tx_type, new tx_detail (requires tx_type_id), or both:
my $update = sub {
if ( $new_tx_type ) {
my $sql = 'select 1 from hmrn.treatment_types where description = ?';
unless ( $dbix->query($sql, $new_tx_type)->list ) { # check not exists
$dbix->insert('hmrn.treatment_types', { description => $new_tx_type });
# need to get last_insert_id if also have new_tx_detail:
if ($new_tx_detail) {
$tx_type_id = $dbix->dbh->last_insert_id(
undef, undef, 'hmrn.treatment_types', 'id'
);
}
}
}
if ( $new_tx_detail && $tx_type_id ) { # need tx_type_id to add new:
my %data = (
description => $new_tx_detail,
type_id => $tx_type_id,
);
my $sql = q!select 1 from hmrn.treatment_details where description = ?
and type_id = ?!; # check combination doesn't already exist:
unless ( $dbix->query($sql, $new_tx_detail, $tx_type_id)->list ) {
$dbix->insert('hmrn.treatment_details', \%data);
}
}
};
my $ok = $db->do_transaction( $update );
# don't need return value unless error:
return $ok ? 0 : 'update_tx_options() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_imaging_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $dbix = $self->lims_dbix;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $scan_stage = $args->{scan_stage}; # required
my $option_id = $args->{option_id}; # scalar || arrayref (optional)
my $scan_type = $args->{scan_type}; # required
my $scan_date = $args->{scan_date}; # required
my $event_id = $args->{event_id}; # required
my $dataset = $args->{dataset}; # required
my $details = $args->{details}; # optional
# option_id MUST be arrayref (single val passed as scalar):
$option_id = [ $option_id ] if ref $option_id ne 'ARRAY';
# common fields for update & delete:
my %h = (imaging_event_id => $event_id); # warn Dumper \%h;
my $to_mysql_date = sub { # for stage_date
LIMS::Local::Utils::to_datetime_using_datecalc(@_)->ymd;
};
my $action = sprintf 'updated %s scan dataset #%s', uc $scan_type, $dataset;
my $update = sub {
{ # update patient_imaging entries:
my $tbl = 'hmrn.patient_imaging_option';
my $entries = $dbix->select($tbl, 'imaging_option_id', \%h)->flat; # warn Dumper $entries;
my $diff = LIMS::Local::Utils::get_array_diff($entries, $option_id);
if ($diff) { # warn $diff; # will be integer equal to number of diffs
$dbix->delete($tbl, \%h); # delete existing
if (@$option_id) { # insert new ones (if supplied):
my %c = %h; # clone to preserve original
for (@$option_id) {
$c{imaging_option_id} = $_;
$dbix->insert($tbl, \%c);
}
}
$self->add_to_actions($action);
}
}
{ # update patient_imaging_other.details:
my $tbl = 'hmrn.patient_imaging_other';
my $d = $dbix->select($tbl, 'details', \%h)->list;
if ($d && not $details) { # delete entry:
$dbix->delete($tbl, \%h);
$self->add_to_actions($action);
}
elsif ($details && not $d) { # insert new entry:
my %c = %h; # clone to preserve original
$c{details} = $details;
$dbix->insert($tbl, \%c);
$self->add_to_actions($action);
}
elsif ($d && $details && $d ne $details) { # update:
$dbix->update( $tbl, { details => $details }, \%h );
$self->add_to_actions($action);
}
}
{ # scan stage & date:
my $tbl = 'hmrn.patient_imaging_event';
my $data = $dbix->select($tbl,
['patient_id', 'stage', 'date'], { id => $event_id })->hash;
my $date = &$to_mysql_date($scan_date); # warn $date;
# add patient_id to $args for do_history():
$args->{patient_id} = $data->{patient_id};
my %h;
unless ( $date eq $data->{date} ) {
$h{date} = $date;
}
unless ( $scan_stage eq $data->{stage} ) {
$h{stage} = $scan_stage;
};
if (%h){
$dbix->update($tbl, \%h, { id => $event_id } );
$self->add_to_actions($action);
}
}
{ # pet suv_max & deauville score:
my $tbl = 'hmrn.patient_pet_score';
for my $param( qw/suv_max deauville/ ) {
my %h = ( param => $param, imaging_event_id => $event_id );
my $result = $dbix->select($tbl, 'result', \%h )->list; # warn $result;
if ($args->{$param} && $result && $args->{$param} ne $result) { # update:
$dbix->update($tbl, { result => $result }, \%h);
$self->add_to_actions($action);
}
elsif ($args->{$param} && ! $result) { # insert:
my %c = %h; # clone to preserve original
$c{result} = $args->{$param};
$dbix->insert($tbl, \%c);
$self->add_to_actions($action);
}
elsif ($result && ! $args->{$param}) { # delete:
my %c = %h; # clone to preserve original
$c{result} = $result;
$dbix->delete($tbl, \%c);
$self->add_to_actions($action);
}
}
}
$self->do_history($args->{patient_id});
};
my $ok = $db->do_transaction( $update );
# don't need return value unless error:
return $ok ? 0 : 'update_imaging_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_treatment_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
$args->{_tbl} = 'hmrn.patient_treatment';
$args->{_section} = 'treatment';
my $rtn = $self->update_hmrn_data($args); # returns err or 0
return $rtn ? 'update_treatment_data() error - ' . $rtn : 0;
}
#-------------------------------------------------------------------------------
sub update_referral_data {
my $self = shift;
my $args = shift; # warn Dumper $args;
$args->{_tbl} = 'hmrn.patient_referrals';
$args->{_section} = 'referral';
my $rtn = $self->update_hmrn_data($args); # returns err or 0
return $rtn ? 'update_referral_data() error - ' . $rtn : 0;
}
#-------------------------------------------------------------------------------
sub update_hmrn_data { # shared with update_referral_data, update_treatment_data
my $self = shift;
my $args = shift; # warn Dumper $args;
my $tbl = $args->{_tbl};
my $row_id = $args->{id};
my $section = $args->{_section};
my $meta = $self->dbix_get_meta($tbl); # warn Dumper $meta;
# get table data cols (ie not PK or timestamp):
my @cols = grep { $_ !~ /\A(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->select( $tbl, \@cols, { id => $row_id } )->hash; # warn Dumper $data;
$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
|| $col eq 'patient_id'; # don't receive data on this col
my $new = $args->{$col};
my $old = $data->{$col};
if ($new && $old && $new ne $old) { # changed
push @updates, ( $col => $new );
$self->add_to_actions("updated $section $col [id = $args->{id}]");
}
elsif ($new && ! $old) {
push @updates, ( $col => $new );
$self->add_to_actions("added new $section $col [id = $args->{id}]");
}
elsif ($old && ! $new) {
push @updates, ( $col => undef );
$self->add_to_actions("deleted $section $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 $section $col [id = $args->{id}]");
}
elsif ($new && ! $old) {
push @updates, ( $col => $new->ymd );
$self->add_to_actions("added new $section $col [id = $args->{id}]");
}
elsif ($old && ! $new) {
push @updates, ( $col => undef );
$self->add_to_actions("deleted $section $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 : $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->select( $tbl, 'patient_id', { 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 delete_referral_data {
my ($self, $id) = @_;
my $dbix = $self->lims_dbix;
my $tbl = 'hmrn.patient_referrals';
my $patient_id = $dbix->select( $tbl, 'patient_id', { 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 referral dataset');
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($delete);
# don't need return value unless error:
return $ok ? 0 : 'delete_referral_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 diagnostic_categories parent_organisations
request_history referrers );
my $relationships = $self->get_relationships(\@tables);
my @params = (
query => \@query,
require_objects => $relationships,
multi_many_ok => 1, # required if using diagnostic_categories rel.
);
my $cases = LIMS::DB::Request::Manager->get_requests(@params);
return $cases;
}
# ------------------------------------------------------------------------------
# get all diagnoses with ICD03 entry (NB includes /1, /3, /6):
sub get_previous_icdo3_diagnoses {
my ($self, $req) = @_;
my $patient_id = $req->patient_case->patient_id; # warn $patient_id;
my $curr_reg_date = $req->created_at; # warn $curr_reg_date->ymd;
$self->_patient_id($patient_id); # for Roles::HMRN
my $previous = $self->all_icdo3_diagnoses(); # warn Dumper $previous;
# only want to collect ICDO3 xxxx/3 & MGUS diagnoses PREDATING current case:
my @diagnoses = ();
DIAGNOSIS: for my $d ( @$previous ) { # warn Dumper $d->as_tree;
my $icdo3 = $d->request_report->diagnosis->icdo3; # warn Dumper $icdo3;
# skip if case registered after current case:
next DIAGNOSIS if $d->created_at >= $curr_reg_date;
# skip case if ICDO3 ends in /1 or /6, and is not MGUS (9765/1):
if ( $icdo3 =~ /[16]\Z/ ) {
next DIAGNOSIS unless $icdo3 eq '9765/1'; # 9769/1 = Primary amyloidosis +/- MGUS
}
push @diagnoses, {
diagnosis => $d->request_report->diagnosis->name,
icdo3 => $d->request_report->diagnosis->icdo3,
# date => $d->created_at, # need to handle attr in C::HMRN::new_diagnoses()
};
} # warn Dumper \@diagnoses;
return \@diagnoses;
}
# ------------------------------------------------------------------------------
sub get_total_request_counts {
my ($self, $patient_ids) = @_; # warn Dumper $patient_ids;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('hmrn_total_request_counts');
my $counts = $dbix->query($sql, @$patient_ids)->map; # warn Dumper $counts;
return $counts;
}
# ------------------------------------------------------------------------------
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 get_post_code_at_diagnosis {
my ($self, $patient_id) = @_;
my $dbix = $self->lims_dbix;
my $sql = 'select post_code from hmrn.patient_post_code where patient_id = ?';
my $data = $dbix->query( $sql, $patient_id )->list;
return $data;
}
# ------------------------------------------------------------------------------
sub update_post_code_at_diagnosis {
my ($self, $data) = @_; # warn Dumper $data;
my $patient_id = $data->{patient_id}; # warn Dumper $patient_id;
my $post_code = $data->{post_code}; # warn Dumper $post_code;
my $dbix = $self->lims_dbix;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $tbl = 'hmrn.patient_post_code';
my $update = sub {
my $sql = "select 1 from $tbl where patient_id = ?";
if ( $dbix->query($sql, $patient_id)->list ) { # warn 'here';
$dbix->update( $tbl,
{ post_code => $post_code}, { patient_id => $patient_id }
);
$self->add_to_actions('updated post-code at diagnosis');
}
else { # warn 'here';
$dbix->insert( $tbl, {
patient_id => $patient_id,
post_code => $post_code,
});
$self->add_to_actions('new post-code at diagnosis')
unless $data->{address}; # don't log if part of original demographics entry
}
$self->do_history($patient_id);
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_post_code_at_diagnosis() error - ' . $db->error;
}
# ------------------------------------------------------------------------------
sub update_comment {
my ($self, $data) = @_; # warn Dumper $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');
}
}
elsif ($form_param) { # if have new data:
$dbix->insert($table,
{ patient_id => $patient_id, comment => $form_param }
);
$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_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 %w = ( patient_id => $patient_id ); # common 'where' statement
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
{ # antecedent event:
my $event_id = $args->{event_id}; # required field
if ( $dbix->select($antecedent_tbl, 'event_id', \%w)->into(my $id) ) { # warn Dumper $data;
if ( $event_id != $id ) {
$dbix->update($antecedent_tbl, {event_id => $event_id}, \%w);
$self->add_to_actions('updated antecedent event');
}
}
else {
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 $list = $dbix->select($prior_tx_tbl, 'therapy', \%w)->flat; # warn Dumper $data;
if (@$list) {
my %old = map { $_ => 1 } @$list; # create hash for comp. with $args
foreach my $tx(@$therapy_opts) { # warn Dumper $tx;
my %data = (
patient_id => $patient_id,
therapy => $tx,
);
my $have_new = $args->{$tx}; # will be 1 or 0
my $have_old = $old{$tx}; # will be 1 or 0
if ( $have_new && ! $have_old ) { # warn 'have new & not old';
$dbix->insert($prior_tx_tbl, \%data);
$self->add_to_actions("added new prior Tx $tx");
}
elsif ( $have_old && ! $have_new ) { # warn 'have old & not 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_events {
my ($self, $args) = @_; # warn Dumper $args; # patient_id + dates
my $patient_id = $args->{patient_id};
my $dbix = $self->lims_dbix;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $tbl = 'hmrn.patient_event';
my $o = do { # get existing events data:
my $sql = qq!select t2.description, t1.date from $tbl t1 join
hmrn.events t2 on t1.event_id = t2.id where t1.patient_id = ?!;
$dbix->query($sql, $patient_id)->hashes;
};
my %data = map +( $_->{description} => $_->{date} ), @$o;
my $events = $dbix->select('hmrn.events', ['description', 'id'] )->map;
my $to_mysql_date = sub { LIMS::Local::Utils::date_to_mysql(@_) };
my $to_datetime = sub { LIMS::Local::Utils::to_datetime_using_datecalc(@_) };
my $update = sub {
if (%data) { # update existing:
EVENT:
while ( my ($event, $id) = each %$events ) {
my $new = $args->{$event}; # in EU format
my $old = $data{$event}; # in MySQL format
if ( $new && $old ) {
# convert new to DT object:
my $dt1 = &$to_datetime($new);
my $dt2 = $self->inflate_mysql_date_to_datetime($old);
next EVENT unless DateTime->compare($dt1, $dt2); # true if different
$dbix->update($tbl, { date => $dt1->ymd },
{ patient_id => $patient_id, event_id => $id } );
$self->add_to_actions("updated date $event");
}
elsif ( $old && ! $new ) {
$dbix->delete($tbl,
{ patient_id => $patient_id, event_id => $id } );
$self->add_to_actions("deleted date $event");
}
elsif ( $new && ! $old ) {
my %h = (
patient_id => $patient_id,
event_id => $id,
date => &$to_datetime($new),
);
$dbix->insert($tbl, \%h);
$self->add_to_actions("added new date $event");
}
else { next EVENT } # ignore if no new or old
}
}
else { # add new dataset:
EVENT:
while ( my ($event, $id) = each %$events ) {
my $date = $args->{$event} || next EVENT;
my %h = (
patient_id => $patient_id,
event_id => $id,
date => &$to_mysql_date($date),
);
$dbix->insert($tbl, \%h);
}
$self->add_to_actions("added new event data");
}
# mdt_date always new (not edited):
if ( my $mdt_date = $args->{mdt_date} ) {
my $date = &$to_mysql_date($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");
}
=begin # synchronise hilis4.patient_demographics.dod field: TODO
if ( $args->{deceased} ) { # warn $args->{deceased};
my $dod = &$to_datetime($args->{deceased})->ymd;
my $sql = 'select * from patient_demographics where patient_id = ?';
my $h = $dbix->query($sql, $patient_id)->hash; # warn Dumper $h;
no warnings 'uninitialized'; # %$h vals possibly
unless ($h->{dod} eq $dod) {
$dbix->update('patient_demographics', { dod => $dod },
{ patient_id => $patient_id } );
}
unless ($h->{status} eq 'dead') {
$dbix->update('patient_demographics', { status => 'dead' },
{ patient_id => $patient_id } );
}
}
=cut
$self->do_history($patient_id);
# die 'rollover beethoven';
};
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_patient_events() error - ' . $db->error;
}
sub do_history {
my ($self, $patient_id) = @_;
my @actions = $self->unique_actions; # update_imaging_data can duplicate
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.patient_dispatch_detail 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_hmrn_new_diagnoses_constraints {
my ($self, $args) = @_;
# if request for single lab number:
if ( my $lab_number = $args->{lab_number} ) {
my ($request_number, $year) = LIMS::Local::Utils::split_labno($lab_number);
return [ request_number => $request_number, year => $year ];
}
# if request for particulat request id:
elsif ( my $request_id = $args->{request_id} ) {
return [ id => $request_id ];
}
# if date range requested:
elsif ($args->{date_from}) { # date_from is minimun required to trigger date range
my $start_date
= LIMS::Local::Utils::to_datetime_using_datecalc($args->{date_from});
my $end_date
= $args->{date_to} # date_to is optional
? LIMS::Local::Utils::to_datetime_using_datecalc($args->{date_to})
: DateTime->today->ymd; # make it today if not supplied
# warn Dumper [$start_date, $end_date];
return [
'request_history.time' => { gt => $start_date },
'request_history.time' => { le => $end_date },
];
}
else {
my $days = $args->{duration} || 7; # value for 'previous_week' param & default
my $days_ago
= $self->time_now->subtract( days => $days )->truncate( to => 'day' );
return [ 'request_history.time' => { gt => $days_ago } ];
}
}
sub _get_all_icdo3_diagnoses {
my $self = shift;
my $diagnoses = $self->all_icdo3_diagnoses(); # arrayref
# get unique diagnosis list:
my %unique;
for (@$diagnoses) {
my $diagnosis = $_->{request_report}->{diagnosis}->{name};
$unique{$diagnosis}++;
}
return [ keys %unique ];
}
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->select('hmrn.locations', ['location' ,'id'])->map;
$maps{location} = $locations;
}
{ # antecedent events:
my $antecedent
= $dbix->select( 'hmrn.antecedent_events', ['event','id'] )->map;
$maps{antecedent} = $antecedent;
}
{ # treatment types:
my $tx_types
= $dbix->select('hmrn.treatment_types', ['description', 'id'])->map;
$maps{tx_type} = $tx_types;
}
{ # unique tx_type_ids from treatment_details table:
my $field = 'distinct(type_id)';
my $ids = $dbix->select('hmrn.treatment_details', $field)->flat;
$maps{tx_type_ids} = $ids; # warn Dumper $ids;
}
{ # treatment responses:
my $opts
= $dbix->select('hmrn.response_options', ['description', 'id'])->map;
$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 $tx_details = $dbix->select( 'hmrn.treatment_details',
[ qw(id description) ], { type_id => $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;
}
{ # imaging_options - need 2 maps: id => { description & option_type } & description => id:
my $opts = do {
my @cols = qw( id description option_type );
$dbix->select('hmrn.imaging_options', \@cols)->map_hashes('id');
};
$maps{imaging_options}{map} = $opts; # warn Dumper $data;
{ # also need description => id:
my %h = map { $opts->{$_}->{description} => $_ } keys %$opts; # HoH with keys = description
$maps{imaging_options}{description} = \%h; # warn Dumper \%h;
}
}
{ # referral_types (pathway):
my @cols = qw(description id);
my $map = $dbix->select('hmrn.referral_type_options', \@cols)->map;
$maps{referral_types} = $map;
}
{ # referral_sources (pathway):
my @cols = qw(description id);
my $map = $dbix->select('hmrn.referral_source_options', \@cols)->map;
$maps{referral_sources} = $map;
}
return \%maps;
}
1;
