#!/usr/bin/env perl
=begin -------------------------------------------------------------------------
uploads activity data to ftp server
usage: $0 [-t] [-m <months ago>], -t = test mode (skips file upload)
--------------------------------------------------------------------------------
=cut
use Getopt::Std;
getopts('m:t'); # months, testing
our($opt_m,$opt_t); # warn $opt_m; exit;
use strict;
use warnings;
#===============================================================================
my @recipients = qw(douglas raj hmds.secure);
my $duration = $opt_m || 1; # months ago
#===============================================================================
my $JUST_TESTING = $opt_t || 0; # skips ftp, sets /tmp dir for data file, emails just raj
use lib '/home/raj/perl5/lib/perl5'; # do this before $Bin
use IO::All;
use Data::Dumper;
use Data::Printer;
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); # p $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'); # p $query;
my $delimiter = '|';
# data NOT required in activity data:
my $skip_orgs = $settings->{skip_organisation_codes}; # p $skip_orgs;
my $skip_samples = $settings->{skip_sample_types}; # p $skip_samples;
# override ST code and charge as normal sample:
my $chargable_trials = $settings->{chargable_trials}; # p $chargable_trials;
# get map of higher-charge molecular sequencing tests:
my $mol_seq_map = _get_mol_seq_map(); # p $mol_seq_map;
# get list of request ids from private hospitals:
my $private_patients_map = _get_private_patients_map(); # p $private_patients_map;
# get list of request ids with BMA/BMAT sample:
my $bone_marrow_map = _get_bone_marrow_requests_map(); # p $bone_marrow_map;
# local network locations:
my @local_network_locations = _get_local_network_locations(); # p @local_network_locations;
# skipped organisation codes => source name map:
my $organisation_name = _get_skipped_locations(); # p $organisation_name;
my @rows = ();
my %bmaseq; # to keep track of requests where new row generated for BMASEQ
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) { # p $vars; next;
# next if $vars->{presentation} eq 'HTS myeloid only';
my $request_id = $vars->{id}; # p $request_id; # next unless $request_id == 363079;
my $org_code = $vars->{organisation_code};
my $lab_no = join '/', $vars->{request_number}, ($vars->{year} - 2000);
# log & skip unknown referral_source:
if ( grep $org_code eq $_, @$skip_orgs ) {
my %h = (
labno => $lab_no,
source => $organisation_name->{$org_code},
);
$h{trial} = $vars->{trial_name} if $vars->{trial_name};
push @{ $log{unsourced} }, \%h;
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'; # p $request_id;
}
{ # get lab-tests:
my $lab_tests = _get_lab_tests($request_id);
$vars->{request_lab_tests} = $lab_tests;
}
# 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 successfully 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/unwanted 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,
); # p %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};
my $lab_tests = $vars->{request_lab_tests};
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 ) { # p $dob;
$vars->{dob} = $vars->{age} = undef; # p @{$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';
}
}
# Birmingham Royal Orthopaedic Hospital - handles Leeds cases so don't charge:
elsif ( $vars->{organisation_code} eq 'RRJ05' ) {
$vars->{category} = 'ST';
}
{ # branch => parent practices map:
my $org_code = $vars->{organisation_code};
if ( my $parent = $settings->{location_codes_map}->{$org_code} ) {
$vars->{organisation_code} = $parent;
}
}
# 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 ( grep $mol_seq_map->{$_}, @$lab_tests ) { # warn '=' x 30;
$vars->{sample_code} = 'PBSEQ'; # p $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}/; # p $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';
}
# presentation / screened as:
#===============================================================================
# Outreach:
if ( $vars->{presentation} =~ /Outreach/ ) { # billed directly now
$vars->{category} = 'ST';
}
# NCG PNH (PB & BMAT):
# TODO: change to /^PNH NCG/ after April 2019 run:
elsif ( $vars->{presentation} =~ /^(?:NCG )?PNH(?: NCG)?$/ ) { # billed directly now
$vars->{category} = 'ST';
}
#elsif ( $vars->{presentation} eq 'HTS myeloid only' ) { # until April 2017:
# $vars->{sample_code} = 'BMASEQ' unless
# grep $vars->{parent_organisation_id} eq $_, @local_network_locations;
#}
#===============================================================================
# HTS myeloid test (from Apr/17) needs to generate a new request for all
# locations if HTS myeloid requested *in addition to* any other test(s)
# except molecular srsf2 (which is also part of HTS section but never
# requested individually) and hts_quantification & dna_extraction, unless
# screened as HTS myeloid only (which gets BMASEQ sample only):
if ( grep $_ eq 'hts_myeloid', @$lab_tests ) { # p $request_id;
my @non_hts_myeloid_tests = grep { # exclude these:
$_ !~ /^(srsf2|hts_myeloid|dna_extraction|hts_quantification)/
} @$lab_tests; # p @other_tests;
# make a new row if any other tests, not screened as 'HTS myeloid only'
# and not aleady done for this request (ie has multiple samples):
my $require_new_row = (
( scalar @non_hts_myeloid_tests ) # any other tests
&& ( $vars->{presentation} ne 'HTS myeloid only' ) # not screened as
&& ( ! $bmaseq{$request_id}++ ) # not already done
);
if ( $require_new_row ) { # warn 'require new row';
# clone data and change sample type to BMASEQ:
my $ref = LIMS::Local::Utils::clone $vars;
$ref->{sample_code} = 'BMASEQ'; # p $ref;
# !!! this action will skip all further local rules on this new sample:
push @rows, parse_data($ref);
}
# change existing sample code to BMASEQ if we don't already have one:
elsif (! $bmaseq{$request_id} ) { # warn 'no previous BMASEQ';
$vars->{sample_code} = 'BMASEQ';
}
# ignore, will retain existing sample type:
# else { warn 'no new row and has previous BMASEQ' }
} # p @rows;
# 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/ ) {
my @flair_followups = ( # FLMRD
'FLAIR follow-up (I/IR/I+V/unstated)',
'FLAIR MRD confirmation/EoT',
'FLAIR response BM',
);
# 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} = 'FLBSL'; $vars->{category} = '01' }
if $sample =~ /^BMA/
|| ( $sample =~ /^PB/ && ! $bone_marrow_map->{$request_id} );
}
# disease progression:
elsif ( $vars->{presentation} eq 'FLAIR disease progression' ) {
if ( $sample =~ /^BMA/ ) { # should never get BM for this screen
$vars->{sample_code} = 'FLMRD'; $vars->{category} = '01';
}
# PB only (ie without a BMA/T - don't want FLMRD as well as FLRES:
elsif ( $sample =~ /^PB/ && ! $bone_marrow_map->{$request_id} ) {
$vars->{sample_code} = 'FLMRD'; $vars->{category} = '01'
}
}
# other follow-ups:
elsif ( grep $vars->{presentation} eq $_, @flair_followups ) {
# BMA/T:
if ( $sample =~ /^BMA/ ) { # should never get BM for these screens
$vars->{sample_code} = 'FLRES'; $vars->{category} = '01';
}
# PB only (ie without a BMA/T - don't want FLMRD as well as FLRES:
elsif ( $sample =~ /^PB/ && ! $bone_marrow_map->{$request_id} ) {
$vars->{sample_code} = 'FLMRD'; $vars->{category} = '01'
}
}
# warn Dumper [$request_id, $vars->{sample_code}, $vars->{category} ];
}
}
sub get_unsourced_requests {
my $data = shift; # arrayref of hashrefs (labno & trial)
my @d = map {
sprintf '%s %s [%s]',
$_->{labno},
$_->{source},
$_->{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; # p $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
}
}
sub _get_lab_tests {
my $request_id = shift; # p $request_id;
my $sql = $sql_lib->retr('activity_request_lab_tests');
my $ref = $dbix->query($sql, $request_id)->flat; # aref
return $ref;
}
# some request.id maps:
sub _get_mol_seq_map { # only returning map of molecular_sequencing_tests now:
my $test_names = $settings->{molecular_sequencing_tests}; # p $test_names;
# my $sql = $sql_lib->retr('activity_molecular_sequencing'); # p $sql;
# my $map = $dbix->query($sql, $duration, $duration, @$test_names)->map;
my %map = map { $_ => 1 } @$test_names; # p %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_skipped_locations {
my $map = $dbix->select( 'referral_sources',
[ 'organisation_code', 'display_name' ],
{ organisation_code => { -in => $skip_orgs } },
)->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
}
