#!/usr/bin/env perl
=begin
monthly notification of CML patients on monitoring who have had in past 7 months:
* inadequate sample
* no repeat sample
see __DATA__ section for manual query
does PDS query for live/dead status and updates patient_demographics table
=cut
#===============================================================================
# if script re-run manually use stored PDS data to save repeat lookups
my $USE_STORAGE = 0; # *** check file date is current, not from previous run ***
#===============================================================================
my $JUST_TESTING = 0; # saves excel file, doesn't email
#===============================================================================
# exempt nhs numbers (incorrectly screened, post-transplant, moved away, etc)
my @not_required = (
6305423733, 4849589804, 4583507917, 4581571391, 4125653828, 4320081552,
4520144728, 4970949352, 7093663230, 4383715656, 4229408412, 4067746202,
2002685827, 4065627206, 4081493650, 4300389845, 4862077994, 7020552889,
4086666863, 4042407528, 6249677682, 6502643051, 4185999402, 4123539939,
4562306629, 4125107742, 4821036037, 4506308816, 4423434601, 6391291896,
4706975190, 6190115640, 6262695508, 4465870612, 4423523647, 4086517213,
4520857686, 4860842626, 4302154233, 4486525876, 4069462945, 4860210255,
6143792917, 4860444671, 4801510051, 4581634016, 4480117520, 4523432732,
4822714632,
);
#===============================================================================
my @recipients = qw( paul.evans.secure raj.secure ); # patient data
my $system_user = 'HMDS-HILIS4-LEEDS';
my $duration = 7; # months
#===============================================================================
#my $addr = '163.160.171.118:1983'; # rie-test
my $addr = '163.160.171.247:1983'; # lthrie
# localhost just returns undef - see also localhost/script/cgi/soap.cgi but it
# can't yet handle Leeds-SMS.service urn:
my $proxy = $USE_STORAGE ? 'http://localhost' : 'http://'.$addr.'/lthspine';
my $urn = 'Leeds-SMS.service';
#===============================================================================
use lib '/home/raj/perl5/lib/perl5';
use Storable;
use SOAP::Lite; # +trace => 'all'; # or switch on after object created
use Modern::Perl;
use SQL::Abstract::More;
use DateTime::Format::MySQL;
use Spreadsheet::WriteExcel::Simple;
use Data::Printer use_prototypes => 0;
use FindBin qw($Bin); # warn $Bin;
use lib ("$Bin/../../../lib", '/home/raj/perl-lib');
use LIMS::Local::ScriptHelpers;
use Local::DB;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);
# use Local::DB for query display if just testing:
my $dbix = Local::DB->dbix({dbname => 'hilis4'});
$Local::QueryLogger::NO_QUERY_LOGS = 1;
$Local::DBIx::Simple::Result::NO_AUTO_DATE_INFLATION = 1; # just need mysql date format
my $ref_date = $tools->date_subtract( months => $duration ); # p $ref_date;
my $filename = 'cml_patient_notifications.xls';
my $subject = 'CML patients with no recent sample';
my $config = $tools->config();
my $sqla = SQL::Abstract::More->new;
my $xl = Spreadsheet::WriteExcel::Simple->new;
#===============================================================================
# default unknown gp & practice id's:
my $default_practice_id = $dbix->select('referral_sources', 'id',
{ organisation_code => 'V81999' })->value; # p $default_practice_id;
my $default_gp_id = $dbix->select('referrers', 'id',
{ national_code => 'G9999998' })->value; # p $default_gp_id;
my $system_user_id = $dbix->select('users', 'id',
{ username => 'hmds-lth'})->value; # p $system_user_id;
#===============================================================================
# get patient, location & last sample date of all cml monitoring patients:
my $cml_patients = do {
my @cols = ( qw/pc.patient_id p.last_name p.first_name p.dob p.nhs_number
rs.display_name|location/ );
push @cols, q!date_format(max(r.created_at), '%Y-%m-%d')|last_sample!; # p \@cols;
my @rels = (
'requests|r' => 'ris.request_id = r.id' ,
'request_initial_screen|ris' => 'ris.screen_id = s.id' ,
'screens|s' => 'r.patient_case_id = pc.id' ,
'patient_case|pc' => 'pc.patient_id = p.id' ,
'patients|p' => 'pc.referral_source_id = rs.id' ,
'referral_sources|rs' => '=>pd.patient_id = p.id' , # left join
'patient_demographics|pd'
);
my @args = (
-columns => \@cols,
-from => [ -join => @rels ],
-where => {
's.description' => { -like => 'follow-up CML (PB)%' },
'p.nhs_number' => { -not_in => \@not_required },
'pd.status' => [ 'alive', undef ], # needs an undef or lose all non-pd entries
},
-group_by => 'p.id',
); # p @args;
my ($sql, @bind) = $sqla->select(@args); # p $sql; p \@bind;
# $dbix->dump_query($sql, @bind); exit;
$dbix->query($sql, @bind)->hash_map('nhs_number'); # includes col as key/val pair
}; # p $cml_patients;
#===============================================================================
# get patients with at least 1 ICDO3 or unauthorised request in past 7 months
my $recent_requests = do {
my @nhs_nums = keys %$cml_patients;
my @rels = (
'requests|r' => '=>arv.id = r.id' , # left join
'authorised_reports_view|arv' => 'rh.request_id = r.id' ,
'request_history|rh' => 'r.patient_case_id = pc.id' ,
'patient_case|pc' => 'pc.patient_id = p.id' ,
'patients|p'
);
my @args = (
-columns => 'distinct(p.nhs_number)',
-from => [ -join => @rels ],
-where => {
'date(r.created_at)' => { '>=' => $ref_date->ymd },
'p.nhs_number' => { -in => \@nhs_nums },
-or => {
'rh.`action`' => { '!=' => 'authorised' },
'arv.icdo3' => { '!=' => undef },
}
},
); # p @args;
my ($sql, @bind) = $sqla->select(@args); # p $sql; # p \@bind;
# $dbix->dump_query($sql, @bind); exit;
$dbix->query($sql, @bind)->column; # aref
}; # p $recent_requests;
#===============================================================================
# remove patients with recent request(s) from cml_patients:
delete $cml_patients->{$_} for @$recent_requests; # warn scalar keys %$cml_patients;
#===============================================================================
# check PDS live/dead status of remaining patients (will not have dod recorded on HILIS):
{
my $action = 'GetExtendedPatientDetails';
my $soap = SOAP::Lite->new( proxy => $proxy );
# SOAP::Lite->import(+trace => 'all'); # for debug
$soap->on_action( sub { "urn:$urn/$action" } ); # .NET format uses '/' not '#'
$soap->autotype(0);
$soap->default_ns("urn:$urn");
my %pds_results; # to store PDS results to save from having to re-run them
# retrieve existing PDS results for use if $USE_STORAGE = 1
my $stored_pds_results = ( -e $Bin.'/pds.data' )
? retrieve $Bin.'/pds.data' : {}; # p $stored_pds_results;
PATIENT:
while ( my ($nhs_num, $d) = each %$cml_patients ) { # $d = href
# get aref of SOAP::Data objects suitable for soap call:
my $data = _soap_data_format($nhs_num, $d); # p $data; # aref
# next PATIENT;
my $res = $soap->call($action,
SOAP::Data->name('request')->value( SOAP::Data->value($data) )
);
if ($res->fault) {
# get fault (->faultstring just returns generic 'server error' msg):
my $fault = $res->fault->{detail}->{error}->{text}; # warn $fault;
$d->{pds_status} = $fault; # fault detail
next PATIENT;
}
my $result = $USE_STORAGE
? $stored_pds_results->{$nhs_num}
: $res->result; # p $result; # p $result->{Person}->{DateOfDeath};
# store result (ignored later if $USE_STORAGE):
$pds_results{$nhs_num} = $result;
if ( $result->{Person}->{DateOfDeath} ) {
delete $cml_patients->{$nhs_num};
_update_patient_demographics($d->{patient_id} => $result);
}
else { # add pds error-code value:
$d->{pds_status} = $result->{ErrorCode};
}
}
store \%pds_results, $Bin.'/pds.data' unless $USE_STORAGE; # no need - will be same
}
#===============================================================================
# save remaining patients to excel file, sorted by date of last sample:
my @cols = qw/last_name first_name dob nhs_number location last_sample pds_status/;
$xl->write_bold_row(\@cols);
# sort by last sample date:
my @nhs_nums = sort by_date keys %$cml_patients; # p \@nhs_nums; exit;
# p [ @{ $cml_patients->{$_} }{@cols} ] for @nhs_nums; exit;
$xl->write_row([ @{ $cml_patients->{$_} }{@cols} ]) for @nhs_nums;
#===============================================================================
if ($JUST_TESTING) {
$xl->save($filename);
}
else {
my %mail = (
config => $config,
subject => $subject,
filename => $filename,
attachment => $xl->data,
);
$tools->send_mail(\%mail, \@recipients);
}
#===============================================================================
sub _soap_data_format {
my ($nhs_num, $d) = @_;
my $last_name = $d->{last_name};
my $dob = $d->{dob};
$dob =~ s/-//g; # requires 8-digit string
my %h = (
DateOfBirth => $dob,
FamilyName => $last_name,
NHSNumber => $nhs_num,
UserID => $system_user,
);
my @data = map { SOAP::Data->name($_)->value($h{$_}) } keys %h;
return \@data;
}
sub _update_patient_demographics {
my ($patient_id, $data) = @_; # p $data;
# will have to update manually as it may already have been done:
return 0 if $USE_STORAGE;
my $dod = $data->{Person}->{DateOfDeath};
# convert dod to mysql date format:
$dod =~ s/^(\d{4})(\d{2})(\d{2})$/$1-$2-$3/;
# address is either href or AoH:
my $addressAddress = $data->{Address}->{Address}; # p $address; # why Address-Address?
if ( ref $addressAddress eq 'ARRAY' ) { # AddrType = H, TMP, PST
# replace arrayref with href where AddrType = 'H' (assumes there always is one):
($addressAddress) = grep $_->{AddrType} eq 'H', @$addressAddress;
} # p $addressAddress;
my $address = join ', ', map $addressAddress->{$_}, sort by_addr_line # AddLine1, AddrLine3, etc
grep $_ =~ /AddrLine/, keys %$addressAddress; # p $address;
my $post_code = $addressAddress->{Postcode};
my $table = 'patient_demographics';
my %data = (
practice_id => $default_practice_id,
patient_id => $patient_id,
post_code => $post_code,
address => $address,
status => 'dead',
gp_id => $default_gp_id,
dod => $dod,
);
# "on duplicate key update" cols - skip address, maybe just a capitalised
# version of existing entry, also because gp practice not available from pds:
my @odku = qw(dod time status);
# update existing record or insert new:
my $result = $dbix->update_or_insert($table, \%data, \@odku); # p $result->rows;
if ($result->rows) { # patient_demographic_history entry:
my %h = (
patient_id => $patient_id,
user_id => $system_user_id,
action => q!set patient demographic status to 'dead'!
);
$dbix->insert('patient_demographic_history', \%h);
}
}
sub by_date { # p $cml_patients->{$a}; p $cml_patients->{$b};
_to_datetime($cml_patients->{$a}->{last_sample}) cmp
_to_datetime($cml_patients->{$b}->{last_sample})
}
sub by_addr_line {
my ($addr_line_num_a) = $a =~ /(\d)$/; # p $addr_line_num_a;
my ($addr_line_num_b) = $b =~ /(\d)$/; # p $addr_line_num_b;
return $addr_line_num_a <=> $addr_line_num_b;
}
sub _to_datetime { DateTime::Format::MySQL->parse_date(@_) }
__DATA__
drop table if exists tmp1; /* all cml monitoring patients */
create temporary table tmp1(nhs_number char(10));
insert into tmp1(nhs_number)
select distinct(p.nhs_number)
from requests as r
join request_initial_screen as ris on ( ris.request_id = r.id )
join screens as s on ( ris.screen_id = s.id )
join patient_case as pc on ( r.patient_case_id = pc.id )
join patients as p on ( pc.patient_id = p.id )
left join patient_demographics pd on ( pd.patient_id = p.id )
where p.nhs_number is not null
and s.description like 'follow-up cml (pb)%'
and pd.`status` <> 'dead';
select * from tmp1;
drop table if exists tmp2; /* all above with at least 1 ICDO3 or unauthorised request in past 7 months */
create temporary table tmp2(nhs_number char(10));
insert into tmp2(nhs_number)
select distinct(p.nhs_number)
from requests as r
left join authorised_reports_view arv on ( arv.id = r.id )
join request_history as rh on ( rh.request_id = r.id )
join patient_case as pc on ( r.patient_case_id = pc.id )
join patients as p on ( pc.patient_id = p.id )
join tmp1 t on ( p.nhs_number = t.nhs_number )
where date(r.created_at) >= date_sub(current_date, interval 7 month)
and ( rh.`action` !='authorised' or arv.icdo3 is not null );
select * from tmp2;
/* all cml monitoring patients with no ICDO3 or unauthorised requests in past 7 months */
select p.last_name, p.first_name, p.dob, p.nhs_number, rs.display_name,
date_format(max(r.created_at), '%Y-%m-%d') as 'last_date'
from requests as r
join patient_case as pc on ( r.patient_case_id = pc.id )
join patients as p on ( pc.patient_id = p.id )
join referral_sources rs on ( pc.referral_source_id = rs.id )
join tmp1 t1 on ( t1.nhs_number = p.nhs_number )
left join tmp2 t2 on ( t1.nhs_number = t2.nhs_number )
where t2.nhs_number is null
group by p.id
order by max(r.created_at);
