#!/usr/bin/perl
=begin -------------------------------------------------------------------------
uploads activity data to ftp server - can be set to test mode using $JUST_TESTING
--------------------------------------------------------------------------------
=cut
use strict;
use warnings;
my $JUST_TESTING = 0; # skips ftp, sets /tmp dir for data file, emails just raj
#===============================================================================
my @recipients = qw(douglas raj hmds.secure);
my $duration = 1; # months ago
#===============================================================================
use lib '/home/raj/perl5/lib/perl5'; # do this before $Bin
use IO::All;
use Data::Dumper;
use DateTime::Format::MySQL;
use IO::Compress::Gzip qw(gzip $GzipError);
use FindBin qw($Bin); # warn $Bin;
use lib "$Bin/../../../lib";
use LIMS::Local::ScriptHelpers;
my $cfg_file = "$Bin/../lib/settings.cfg";
my $settings = Config::Auto::parse($cfg_file); # warn Dumper $settings;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);
# get tools from LIMS::Local::ScriptHelpers:
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
my $date = $tools->date_subtract(months => $duration);
my $month = $date->month_name;
my $filename = $tools->script_filename;
my $query = $sql_lib->retr('activity_data');
my $delimiter = '|';
# data NOT required in activity data:
my $skip_orgs = $settings->{skip_organisation_codes}; # warn Dumper $skip_orgs;
my $skip_samples = $settings->{skip_sample_types}; # warn Dumper $skip_samples;
# override ST code and charge as normal sample:
my $chargable_trials = $settings->{chargable_trials}; # warn Dumper $chargable_trials;
# get list of request ids with at least 1 molecular sequencing assay on a PB sample:
my $mol_seq_map = _get_mol_seq_map(); # warn Dumper $mol_seq_map;
# get list of request ids from private hospitals:
my $private_patients_map = _get_private_patients_map(); # warn Dumper $private_patients_map;
# get list of request ids with BMA/BMAT sample:
my $bone_marrow_map = _get_bone_marrow_requests_map(); # warn Dumper $bone_marrow_map;
# local network locations:
my @local_network_locations = _get_local_network_locations(); # warn Dumper @local_network_locations;
my @rows = ();
my %log = (
unsourced => [], # initialise to avoid possible undef value error later
failed => [],
);
my $result = $dbix->query($query, $duration, $duration); # needs duration twice
ROW:
while (my $vars = $result->hash) { # warn Dumper $vars; next;
my $request_id = $vars->{id};
my $lab_no = join '/', $vars->{request_number}, ($vars->{year} - 2000);
# log & skip unknown referral_source:
if ( grep $vars->{organisation_code} eq $_, @$skip_orgs ) {
push @{ $log{unsourced} },
{ labno => $lab_no, trial => $vars->{trial_name} };
next ROW;
}
# skip sample types:
next ROW if grep $vars->{sample_code} eq $_, @$skip_samples;
# log failures (unknown clinicians for non-study requests):
if ( $vars->{referrer_code} =~ /9999998\Z/ && $vars->{category} ne 'ST' ) {
next ROW if $log{seen}{$request_id}++; # duplicates if request has >1 specimen
push @{ $log{failed} }, $lab_no;
my $location = $vars->{display_name};
$log{unknown}{$location}++;
}
# non-NHS sources unless in trial/study:
if ( $vars->{organisation_code} =~ /^NT\d{3}|8EQ15/ ) {
$vars->{category} = '04' unless $vars->{category} eq 'ST';
}
# private patient in NHS hospital:
elsif ( $private_patients_map->{$request_id} ) {
$vars->{category} = '02'; # warn $request_id;
}
# apply any local billing rules before upload:
apply_local_rules($vars);
# generate data row:
my $data = parse_data($vars);
push @rows, $data;
}
my $cfg = $settings->{activity_data_server};
my $local_filename = sprintf '%s/hmds.dat', $JUST_TESTING
? '/tmp' # override path for testing
: $cfg->{path_to_datafile};
my $content = join "\n", @rows;
$content > io($local_filename);
unless ($JUST_TESTING) {
my %args = (
local_filename => $local_filename,
remote_filename => $cfg->{remote_filename},
server_addr => $cfg->{remote_address},
username => $cfg->{username},
password => $cfg->{password},
);
# ftp file (returns str on failure, undef on success):
my $rtn = $tools->ftp_file(\%args);
if ($rtn) {
$tools->mail_admin({ script => $0, msg => $rtn });
die "$0 - $rtn\n"; # dump to logs
}
print "$filename reports data for $month succesfully uploaded\n"; # for cron log
# archive activity data file:
archive_data_file();
}
my @no_referrer_src = map "$_: $log{unknown}{$_}",
reverse sort { $log{unknown}{$a} <=> $log{unknown}{$b} }
keys %{ $log{unknown} };
# calculate some vars for email message:
my $total_requests = scalar @rows;
my $number_unsourced = scalar @{ $log{unsourced} };
my $number_failed = scalar @{ $log{failed} };
my $percent_failed = eval { 100 * $number_failed / $total_requests };
my $no_referrer_reqs = join "\n\t", @{ $log{failed} };
my $no_referrer_src = join "\n\t", @no_referrer_src;
my $unsourced_labnos = get_unsourced_requests($log{unsourced});
# send emails to recipients:
my $message
= sprintf qq!Activity data file created successfully (%s entries).\n\n!
. qq!Unknown source: %s\n\t%s\n\n!
. qq!Unknown referrer: %s (%.2f%%)\n\t%s\n\n!
. qq!Sources for unknown referrer:\n\t%s!,
$total_requests,
$number_unsourced,
$unsourced_labnos,
$number_failed,
$percent_failed || 0,
$no_referrer_reqs,
$no_referrer_src; # print $message . "\n"; # exit;
my %mail = (
config => $config,
message => $message,
subject => 'Activity data for month ' . $month,
); # warn Dumper \%mail; exit;
$tools->send_mail(\%mail, \@recipients);
sub parse_data {
my $vars = shift; # hashref
my $line = join $delimiter, (
'HMDS',
'H' . $vars->{request_number} . '/' . ( $vars->{year} - 2000 ),
uc $vars->{last_name},
( join ' ', map ucfirst $vars->{$_}, grep $vars->{$_}, qw/first_name middle_name/ ),
$vars->{unit_number}, # have to handle default unknown
$vars->{dob} || '', # already converted to dmy('/') in apply_local_rules()
$vars->{age} || '',
$vars->{gender} || 'U',
$vars->{organisation_code},
$vars->{referrer_code},
$vars->{organisation_code} =~ /\A(RR8|RAE)/ ? $vars->{hospital_department_code} : '',
'HM' . $vars->{sample_code},
'HM' . $vars->{sample_code},
$vars->{category},
$vars->{on_call},
DateTime::Format::MySQL->parse_datetime($vars->{created_at})->dmy('/'),
DateTime::Format::MySQL->parse_datetime($vars->{created_at})->strftime('%d/%m/%Y:%H:%M'),
'', # external ref - not used
$vars->{nhs_number} || '',
);
return $line;
}
sub apply_local_rules {
my $vars = shift; # hashref
my $request_id = $vars->{id};
if (
$vars->{first_name} =~ /\A(lgi|pin)\Z/i ||
$vars->{last_name} =~ /\Ahtg\d+/i
) {
$vars->{first_name} = uc $vars->{first_name};
}
# $vars->{unit_number} = '' if $vars->{unit_number} eq 'UNKNOWN';
# downstream system can't handle d.o.b eg 1/1/1000, replace with NULL:
if ( my $dob = $vars->{dob} ) {
my $date = DateTime::Format::MySQL->parse_date($dob);
if ( $date->year <= 1900 ) { # warn $dob;
$vars->{dob} = $vars->{age} = undef; # warn @{$vars}{'dob','age'};
}
else { # to save rpt D::F::MySQL in parse_data():
$vars->{dob} = $date->dmy('/'); # convert to activity data format
}
}
# avoid uninitialized value error:
map $vars->{$_} ||= '', qw(trial_name presentation);
# haematology needs to be clinical not laboratory:
$vars->{hospital_department_code} =~ s/823/303/;
# Castleford & Normanton DH now RGX18, unless Dermatology which has its own code:
if ( $vars->{organisation_code} eq 'RXF07' ) {
if ( # examine both speciality & specimen:
$vars->{hospital_department_code} == 330 ||
$vars->{sample_description} =~ /^skin/i
) {
$vars->{organisation_code} = '5N301D';
}
else {
$vars->{organisation_code} = 'RGX18';
}
}
# maybe change sample type based on presentation or test type - PB only:
if ( $vars->{sample_code} =~ /^PB/ ) {
my $presentation = $vars->{presentation};
my $set_code_map = $settings->{set_codes_map};
# force specimen code to PBSEQ if at least one molecular sequencing test:
if ( $mol_seq_map->{$request_id} ) {
$vars->{sample_code} = 'PBSEQ'; # warn $request_id;
}
elsif ( my $set_code = $set_code_map->{$presentation} ) { # eg PB => PBCML:
# $vars->{sample_code} .= $set_code if $vars->{sample_code} eq 'PB';
$vars->{sample_code} =~ s/^PB$/${set_code}/; # warn $vars->{sample_code};
}
}
# override 01 category for research PB samples from LTH source:
if ( $vars->{sample_code} eq 'RXPB' && $vars->{organisation_code} =~ /^RR8/) {
$vars->{category} = 'ST';
}
# Birmingham Royal Orthopaedic Hospital - handles Leeds cases so don't charge:
if ( $vars->{organisation_code} eq 'RRJ05' ) {
$vars->{category} = 'ST';
}
# presentation / screened as:
#===============================================================================
# Outreach:
if ( $vars->{presentation} =~ /Outreach/ ) { # billed directly now
$vars->{category} = 'ST';
}
# NCG PNH (PB & BMAT):
elsif ( $vars->{presentation} =~ /^NCG PNH/ ) { # billed directly now
$vars->{category} = 'ST';
}
# HTS myeloid only (from Apr/17 needs to generate a new request for all ref.
# sources if HTS myeloid requested *in addition to* any other test(s):
# if ( hts_myeloid_test_done ) { # screened-as doesn't matter
# if ( no_of_tests > 1 ) { # make a new request:
# my $data = clone $vars;
# $data->{sample_code} = 'BMASEQ';
# push @rows, parse_data($vars);
# }
# else { $vars->{sample_code} = 'BMASEQ' }
#}
elsif ( $vars->{presentation} eq 'HTS myeloid only' ) {
$vars->{sample_code} = 'BMASEQ' unless # until April 2017:
grep $vars->{parent_organisation_id} eq $_, @local_network_locations;
}
#===============================================================================
# EQA samples:
if ( $vars->{last_name} eq 'ceqas' && length $vars->{first_name} == 2 ) {
$vars->{category} = 'ST';
}
# set category to ST for PB if accompanied by BMA[T] (skip if already set to ST):
if ( $vars->{sample_code} eq 'PB' && $vars->{category} ne 'ST' ) {
$vars->{category} = 'ST' if $bone_marrow_map->{$request_id};
}
# trial sample ST code overriden and billed as normal:
if ( grep $vars->{trial_name} eq $_, @$chargable_trials ) {
$vars->{category} = '01'; # override ST code
}
# FLAIR trial:
if ( $vars->{presentation} =~ /FLAIR/ || $vars->{trial_name} =~ /CLL FLAIR/ ) {
# set default charge to ST (all samples):
$vars->{category} = 'ST';
my $sample = $vars->{sample_code};
# baseline requests:
if ( $vars->{presentation} eq 'FLAIR baseline' ) {
# require BSL sample code & category 01 if BMA(T) or PB without a BMA(T):
do { $vars->{sample_code} = 'BSL'; $vars->{category} = '01' }
if $sample =~ /^BMA/
|| ( $sample =~ /^PB/ && ! $bone_marrow_map->{$request_id} );
} # warn Dumper [$request_id, $vars->{sample_code}, $vars->{category} ];
# follow-up IR/unstated:
elsif ( $vars->{presentation} eq 'FLAIR follow-up (IR/unstated)' ) {
# require RXPB charge code & category 01 if BMA(T) or PB without a BMA(T):
do { $vars->{sample_code} = 'RXPB'; $vars->{category} = '01' }
if $sample =~ /^BMA/
|| ( $sample =~ /^PB/ && ! $bone_marrow_map->{$request_id} );
} # warn Dumper [$request_id, $vars->{sample_code}, $vars->{category} ];
}
{ # branch => parent practices map:
my $org_code = $vars->{organisation_code};
if ( my $parent = $settings->{location_codes_map}->{$org_code} ) {
$vars->{organisation_code} = $parent;
}
}
}
sub get_unsourced_requests {
my $data = shift; # arrayref of hashrefs (labno & trial)
my @d = map {
sprintf '%s [%s]', $_->{labno}, $_->{trial} || 'WILL NOT BE BILLED'
} @$data;
return join "\n\t", @d;
}
sub archive_data_file {
my $data_file = $cfg->{path_to_datafile} . '/hmds.dat';
# make sure it exists:
if (-e $data_file) {
my $o = io($data_file);
my $input = $o->name; # warn $input;
# compress and archive:
my $output = sprintf '%s/%s_%02d_hmds.dat.gz',
$cfg->{path_to_datafile}, $date->year, $date->month;
my $status = gzip $input => $output, Minimal => 1 # avoids full path info
or warn "$0 - gzip failed: $GzipError\n";
$o->unlink; # archived if has data, deleted anyway
}
}
# some request.id maps:
sub _get_mol_seq_map {
my $sql = $sql_lib->retr('activity_molecular_sequencing');
my $test_names = $settings->{molecular_sequencing_tests};
my $map = $dbix->query($sql, $duration, $duration, @$test_names)->map;
return $map;
}
sub _get_bone_marrow_requests_map {
my $sql = $sql_lib->retr('activity_bone_marrow_requests');
my $map = $dbix->query($sql, $duration, $duration)->map;
return $map;
}
sub _get_private_patients_map {
my $sql = $sql_lib->retr('activity_private_patients');
my $map = $dbix->query($sql, $duration, $duration)->map;
return $map;
}
sub _get_local_network_locations {
my $lnl = $dbix->select('local_network_locations', 'parent_id')->flat;
return @$lnl;
}
sub _has_marrow { # replaced with _get_bone_marrow_requests()
# my $request_id = shift;
# $dbix->query($has_marrow, $request_id)->into(my $result); # warn Dumper [$request_id, $result];
# return $result;
=begin
if ($result) {
my $data = $dbix->query(
q!select r.request_number, s.description, d.name, rs.display_name
from requests r join request_report_view rr on rr.request_id = r.id
join diagnoses d on rr.diagnosis_id = d.id
join patient_case pc on r.patient_case_id = pc.id
join referral_sources rs on pc.referral_source_id = rs.id
join request_initial_screen ris on ris.request_id = r.id
join screens s on ris.screen_id = s.id
where r.id = ?!, $request_id)->array;
print $fh Tr( td($data));
}
=cut
}
