package LIMS::Model::HMRN;
use Moose;
extends 'LIMS::Model::Base';
use namespace::clean -except => 'meta';
use DateTime::Format::MySQL;
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, $patient_id) = @_; # warn $patient_id;
my $dbix = $self->lims_dbix;
# switch db:
# $dbix->dbh->do('use hmrn'); # needs reversing or get fatal error downstream
my $hmrn_data = {};
{ # chronologies:
my $sql = q!select * from hmrn.patient_chronologies where patient_id = ?!;
my $dates = $dbix->query($sql, $patient_id)->hash; # warn Dumper $dates;
my $cols = $self->_get_cols('patient_chronologies'); # warn Dumper $cols;
# convert MySQL dates to dt objects:
my %data = map {
$_ => DateTime::Format::MySQL->parse_date($dates->{$_})
} grep $dates->{$_}, @$cols; # warn Dumper \%data;
# 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 ) {
my $dt = DateTime::Format::MySQL->parse_date($vals->{date});
my $data = { id => $vals->{id}, date => $dt };
push @{ $hmrn_data->{chronology}->{mdt_dates} }, $data;
}
}
{ # 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 radiotherapy, chemotherapy from
hmrn.patient_prior_therapies where patient_id = ?!;
my $tx = $dbix->query($sql, $patient_id)->hash; # warn Dumper $tx;
$hmrn_data->{antecedent}{prior_tx} = $tx; # 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;
map { # dates to datetime:
$vals->{$_} = DateTime::Format::MySQL->parse_date($vals->{$_})
} grep $vals->{$_}, qw(start_date end_date); # warn Dumper $vals;
push @{ $hmrn_data->{treatments} }, $vals; # add to treaments array
}
}
{ # get select option maps:
my $select_option_data = $self->_get_select_option_data();
$hmrn_data->{maps} = $select_option_data;
}
return $hmrn_data;
}
#-------------------------------------------------------------------------------
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 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_select_option_data {
my $self = shift;
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;
}
{ # treatment details:
my $tx_details
= $dbix->query(q!select * from hmrn.treatment_details order by description!)->hashes;
$maps{tx_detail} = $tx_details; # array(ref) of hashes
# get unique type_ids from treatment_details:
my %type_ids = map { $_->{type_id} => 1 } @$tx_details;
$maps{tx_type_ids} = [ keys %type_ids ]; # warn Dumper \%type_ids;
}
{ # treatment reponses:
my $meta = $self->_get_meta('patient_treatment')->{response}->{type};
my ($enum) = $meta =~ /enum\((.*)\)/; # warn $enum;
my @opts = sort grep { $_ =~ s/\'//g } split ',', $enum; # warn Dumper \@opts;
$maps{response} = \@opts;
}
return \%maps;
}
sub _get_cols {
my ($self, $table) = @_;
my $dbh = $self->lims_dbix;
my $meta = $self->_get_meta($table); # warn Dumper $meta;
my @cols = keys %$meta; # warn Dumper \@cols;
return \@cols;
}
sub _get_meta {
my ($self, $table) = @_;
my $dbh = $self->lims_dbix;
my $t = $dbh->query("show columns from hmrn.$table")->hashes; # warn Dumper $t;
my %meta = map {
$_->{field} => $_,
} @$t; # warn Dumper \%meta;
return \%meta;
}
1;
