#!/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 = 1; # skips ftp, sets /tmp dir for data file, emails just raj
#######################################
my @recipients = qw(douglas raj); #
my $duration = 1; # months ago #
#######################################
BEGIN {
use FindBin qw($Bin); # warn $Bin;
use lib "$Bin/../../../lib";
}
use IO::All;
use Data::Dumper;
use DateTime::Format::MySQL;
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();
# get tools from LIMS::Local::ScriptHelpers:
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
my $query = $sql_lib->retr('activity_data');
my $delimiter = '|';
my (@rows, %request_numbers, %log);
my $result = $dbix->query($query, $duration, $duration); # needs duration twice
my $is_private = q!select 1 from request_option ro join additional_options ao on
ro.option_id = ao.id where ro.request_id = ? and ao.option_name = 'private'!;
ROW:
while (my $vars = $result->hash) { # warn Dumper $vars; next;
my $id = $vars->{id};
my $lab_no = join '/', $vars->{request_number}, ($vars->{year} - 2000);
# log & skip unknown referral_source:
if ( grep $vars->{organisation_code} eq $_, qw/X99999 V81999/ ) {
push @{ $log{unsourced} }, $lab_no;
next ROW;
}
# log failures (unknown clinicians for non-study requests):
if ( $vars->{referrer_code} =~ /9999998\Z/ && $vars->{category} ne 'ST' ) {
next if $log{seen}{$id}++; # duplicates if request has >1 specimen
push @{ $log{failed} }, $lab_no;
my $location = $vars->{display_name};
$log{unknown}{$location}++;
}
# non-NHS sources:
if ( $vars->{organisation_code} =~ /^NT\d{3}|8EQ15/ ) {
$vars->{category} = '04';
}
# private patient in NHS hospital:
elsif ( $dbix->query($is_private, $vars->{id})->list ) {
$vars->{category} = '02'; # warn $vars->{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 = $JUST_TESTING
? '/tmp/hmds.dat' # 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
}
}
my $month = DateTime->today->subtract(months => $duration)->month_name;
print "$0 - data for $month succesfully uploaded\n"; # for cron log
# calculate some vars for email message:
my $total_requests = scalar @rows;
my $number_unsourced = scalar @{ $log{unsourced} };
my $unsourced_labnos = join "\n\t", map "$_ - WILL NOT BE BILLED", @{ $log{unsourced} };
my $number_failed = scalar @{ $log{failed} };
my $percent_failed = 100 * $number_failed / $total_requests;
my $no_referrer_reqs = join "\n\t", @{ $log{failed} };
my $no_referrer_src = join "\n\t", map "$_: $log{unknown}{$_}",
reverse sort {
$log{unknown}{$a} <=> $log{unknown}{$b}
} keys %{ $log{unknown} };
# 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,
$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;
foreach (@recipients) { warn Dumper $_; next unless $_ eq 'raj';
$mail{recipient} = $tools->get_email_address($_); # warn Dumper $mail{recipient}; next;
my $rtn = LIMS::Model::Email->send_message(\%mail);
warn "Error in $0: $rtn" if $rtn;
}
sub parse_data {
my $vars = shift; # hashref
$vars->{first_name} = uc $vars->{first_name} if $vars->{first_name} =~ /\A(lgi|pin)\Z/i;
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} ? DateTime::Format::MySQL->parse_date($vars->{dob})->dmy('/') : '', # have to handle default unknown
$vars->{age} || '',
$vars->{gender} || 'U',
$vars->{organisation_code} =~ /\A(RR8|RAE)/ ? $vars->{hospital_department_code} : '',
$vars->{referrer_code},
$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
# 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';
}
}
# special case for outreach samples:
if ( $vars->{trial_name} eq 'HMDS outreach' && $vars->{sample_code} eq 'PB') {
$vars->{category} = '01'; # set sample type to chargeable
$vars->{sample_code} = 'CMPB'; # set special sample_type
}
# override ST category for research PB samples from non-LTH source:
if ( $vars->{sample_code} eq 'RXPB' && $vars->{organisation_code} !~ /^RR8/) {
$vars->{category} = '01';
}
# NCRI Arctic trials billed as normal:
if ( $vars->{trial_name} eq 'NCRI CLL ARCTIC' ) {
$vars->{category} = '01';
}
}
