#!/usr/bin/perl
=begin -------------------------------------------------------------------------
generates 3 files for results server and ppm:
*.001 = new authorisations
*.002 = revised or final diagnoses
*.003 = previous reports for changed pid details
excludes:
* non RR8/RWY/RAE locations
* screened as Chimerism sample, Molecular miscellaneous & Community monitoring
* null NHS Number unless FName = LGI
run every day via cron - does not generate file if no reports so can run over
weekend/public hols
*** UPLOADED BY RESULTS SERVER AT 7AM - CRON NEEDS TO COMPLETE BEFOREHAND
PPM FTP server connection problems handled by non-fatal error() so results feed
can complete.
=cut ---------------------------------------------------------------------------
use strict;
use warnings;
my $JUST_TESTING = 0; # skips ftp, puts data files in /tmp with .PPM & .RESULTS suffixes
################################################################################
my $results_active = 1; # activate/deactivate results server feed
my $ppm_active = 1; # activate/deactivate ppm server feed
my $delta = 1; # days for date_sub calculations
################################################################################
BEGIN {
use FindBin qw($Bin); # warn $Bin; exit;
use lib (
"$Bin/../../../lib",
'/home/raj/perl5/lib/perl5',
);
}
use IO::All;
use Config::Auto;
use Data::Dumper;
use DateTime::Format::MySQL;
use LIMS::Local::ScriptHelpers;
use Text::Wrap qw($columns fill); $columns = 68;
my $cfg_file = "$Bin/../lib/settings.cfg";
my $settings = Config::Auto::parse($cfg_file); # warn Dumper $settings;
# get tools from LIMS::Local::ScriptHelpers:
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
my $today = $tools->time_now(); # warn $today->dmy;
# what date to get data from:
my $ref_date = $tools->date_subtract( days => $delta )->ymd; # warn $ref_date;
# options for 3 data files
# [ rh = request_history; rdh = request_diagnosis_history; p = patients ]
my %opts = (
new_cases => {
where => {
'rh.`action`' => 'authorised',
"DATE_FORMAT(rh.`time`, '%Y-%m-%d')" => $ref_date,
},
file_id => 1,
},
revisions => {
where => {
"DATE_FORMAT(rdh.`time`, '%Y-%m-%d')" => $ref_date,
},
file_id => 2,
},
demographics => {
where => {
'rh.`action`' => 'authorised',
"DATE_FORMAT(rh.`time`, '%Y-%m-%d')" => { '<' => $ref_date },
"DATE_FORMAT(p.`updated_at`, '%Y-%m-%d')" => $ref_date,
},
file_id => 3,
},
);
my $file_header = sprintf $settings->{header},
$today->day, $today->month, $today->year, $today->hour, $today->min;
my $file_footer = join "\n", @{ $settings->{footer} };
my $data_filename = sprintf 'hmds_%s%02d%02d',
$today->year, $today->month, $today->day;
my $query = $sql_lib->retr('results_and_ppm');
# go:
DATAFILE:
while ( my($type, $vals) = each %opts ) {
# query much faster passing list of request_ids to 'WHERE req.id IN (??)':
my $request_ids = _get_request_ids($vals->{where}); # arrayref
next DATAFILE unless @$request_ids;
# get data maps - much faster than tying vertical tables into main query:
my $data_map = _get_data_map($request_ids); # warn Dumper $data_map;
my %data = ( # reset:
results => undef, # not strictly required, but to show data keys
ppm => undef,
);
my $result = $dbix->query($query, @$request_ids);
ROW:
while (my $vars = $result->hash) { # warn Dumper $vars; next;
my $is_gum_request = ( # so ppm can skip GUM requests
lc $vars->{first_name} eq 'lgi' && $vars->{clinical_details} eq 'HIV'
);
# some data fields require manipulation for template:
_process_data($vars, $data_map); # warn Dumper $vars;
# results server requires LTH cases with nhs_number or GUM id:
if ( $vars->{organisation_code} =~ /^RR8/
&& ( $vars->{nhs_number} || $is_gum_request ) ) {
my $dataset = $tools->process_template('cron/results.tt', $vars);
push @{ $data{results} }, $dataset; # warn $dataset;
}
# ppm doesn't want GUM samples but does want null NHS numbers:
unless ($is_gum_request) {
my $dataset = $tools->process_template('cron/ppm.tt', $vars);
push @{ $data{ppm} }, $dataset; # warn $dataset;
}
} # warn Dumper \%data;
# PPM data:
if ( $data{ppm} && $ppm_active ) {
my $ppm_data = join "\n", @{ $data{ppm} };
my $file = sprintf '%s.%03d', $data_filename, $vals->{file_id};
my $file_path = '/tmp/' . $file;
if ($JUST_TESTING) { $file_path .= '.PPM' } # add suffix for testing
my $contents = join "\n", $file_header, $ppm_data, $file_footer;
$contents > io($file_path); # warn $contents;
# ftp ppm file:
unless ($JUST_TESTING) {
my %args = (
local_filename => $file_path,
remote_filename => $file,
);
_ftp_file(\%args);
}
}
# results data:
if ( $data{results} && $results_active ) {
my $results_data = join "\n", @{ $data{results} };
# set tmp file if in test mode:
my $path = $JUST_TESTING
? '/tmp' : $settings->{results_server}->{path_to_datafile};
my $file = sprintf '%s/%s.%03d',
$path, $data_filename, $vals->{file_id};
if ($JUST_TESTING) { $file .= '.RESULTS' } # add suffix for testing
my $contents = join "\n", $file_header, $results_data, $file_footer;
$contents > io($file); # warn $contents;
}
}
# archive results file:
unless ($JUST_TESTING) {
my $path_to_datafile = $settings->{results_server}->{path_to_datafile};
my $path_to_archive = $settings->{results_server}->{path_to_archive};
# make sure it exists otherwise get error trying to tar non-existant file
if (grep -e "$path_to_datafile/$data_filename.00$_", (1..3) ) {
my $tar_file = sprintf '%s/%s.%02d.%02d.tar',
$path_to_archive,
$today->year, $today->month, $today->day;
chdir $path_to_datafile; # so we can use relative path for source directory
system( sprintf 'tar -cf %s %s.*', $tar_file, $data_filename ); # using relative $data_file.* not full path
system( sprintf "gzip $tar_file" ); # compress tar file
}
}
# some $vars data fields require manipulation for template:
sub _process_data {
my ($vars, $data_map) = @_;
my $request_id = $vars->{request_id};
my $specimen_code = $data_map->{specimen}->{$request_id}->{specimen_code};
$vars->{request_history} = $data_map->{history}->{$request_id};
$vars->{specimen_details} = $data_map->{specimen}->{$request_id}->{description};
$vars->{specimen_summary} = _specimen_summary($specimen_code);
# re-arrange HIV's data:
if ( $vars->{last_name} =~ /^\d+$/ && uc $vars->{first_name} eq 'LGI' ) {
$vars->{unit_number} = 'GU' . $vars->{unit_number};
$vars->{first_name} = $vars->{last_name};
}
{ # ensure no line > 68 chars, wrap text, replace blanks, etc:
my $formatted_fields = $settings->{formatted_fields};
map $vars->{$_} = _format_text($vars->{$_}), @$formatted_fields;
}
{ # generate composite result from lab_section results_summaries:
my $result_summary_data = $data_map->{result_summary}->{$request_id};
# warn Dumper $result_summary_data;
my @results = map {
_format_text( $_ . ': ' . $result_summary_data->{$_} );
} keys %$result_summary_data;
$vars->{results_summary} = ( join $settings->{new_line}, @results )
|| $settings->{indent} . 'N/A';
}
}
# format text: indent, replace blanks with N/A, max 68 chars / line:
sub _format_text {
my $str = shift || ''; # needs to exist or uninitialized warnings below
# put '07|' after of new-line markers:
my $formatted_newline = $settings->{new_line};
$str =~ s/^(\s+|\t)//; # remove leading spaces or tabs
$str =~ s/\|//g; # remove pipes if used!!
$str ||= 'N/A'; # only applies to @formatted_fields, others already grepped
my $wrapped_text = fill($settings->{indent}, $settings->{indent}, $str); # Text::Wrap function
# new 07| in front of newly-wrapped lines:
$wrapped_text =~ s/\n/$formatted_newline/g; # print $wrapped_text;
return $wrapped_text;
}
sub _specimen_summary {
local $_ = shift; # specimen string
my @title;
push @title, 'peripheral blood' if /PB|CMP/; # CMP excluded
push @title, 'chimerism' if /CHI/; # currently excluding chimerism screen
push @title, 'bone marrow aspirate' if /BMA$|BMA\,/; # BMA[^T] doesn't work
push @title, 'bone marrow biopsy' if /BMAT|T[B|S][L|P]/;
push @title, 'tissue biopsy' if /[DGLRX][BL|F|SL|U|A]/;
push @title, 'effusion' if /EF/;
push @title, 'CSF' if /CF/;
push @title, 'slide' if /HS/;
push @title, 'serum' if /SE/;
push @title, 'urine' if /URI/;
# my $title = @title > 1 ? join (' & ' => join (', ' => @title[ 0 .. @title - 2 ]), $title[-1]) : $title[0];
my $title = join '/', @title; # print Dumper ($title, length $title) if length $title > 40;
$title ||= $_; # so var not empty if specimen doesn't match in regex's
return ( length $title < 41 )
? $title
: 'multiple blood/marrow/tissue specimens';
}
sub _get_request_ids {
my $restriction = shift;
my $excludes = $settings->{not_ins}; # arrayref
my $org_codes = $settings->{org_codes}; # arrayref
# add common restrictions:
$restriction->{'s.description' } = { 'NOT IN' => $excludes };
$restriction->{'po.parent_code'} = { IN => $org_codes };
my ($where, @bind) = $dbix->abstract->where($restriction);
my $stmt = $sql_lib->retr('results_and_ppm_request_ids');
my $sql = $stmt . $where; # warn $sql; warn Dumper \@bind;
my $request_ids = $dbix->query($sql, @bind)->flat; # warn Dumper $request_ids;
return $request_ids;
}
sub _get_data_map {
my $request_ids = shift;
my $map = {};
{ # request_specimens:
my $sql = q!select `request_id`,
group_concat(`description` separator '/') as 'description',
group_concat(`sample_code`) as 'code' from `request_specimen` rs
join `specimens` s on rs.`specimen_id` = s.`id`
where rs.`request_id` in (??) group by `request_id`!;
my $result = $dbix->query($sql, @$request_ids);
while ( my $vars = $result->hash ) { # warn Dumper $vars;
my $request_id = $vars->{request_id};
my %data = (
specimen_code => $vars->{code},
description => $vars->{description},
);
$map->{specimen}->{$request_id} = \%data;
} # warn Dumper $map->{specimen};
}
{ # request_history:
my $national_codes = $settings->{national_codes};
my $sql = q!select rh.`request_id`, rh.`action`, rh.`time`, u.`username`,
u.`first_name`, u.`last_name` from `request_history` rh join `users`
u on rh.`user_id` = u.`id` where rh.`action`
in ('registered','reported','authorised') and rh.`request_id` in (??)!;
my $result = $dbix->query($sql, @$request_ids);
while ( my $vars = $result->hash ) { # warn Dumper $vars;
my $request_id = $vars->{request_id};
my $user_id = $vars->{username}; # warn $username;
my $action = $vars->{action};
my $name = join ' ', map ucfirst $_,
$vars->{first_name}, $vars->{last_name};
my %data = (
datetime => DateTime::Format::MySQL->parse_datetime($vars->{time}),
user_code => $national_codes->{$user_id},
user_name => $name,
);
$map->{history}->{$request_id}->{$action} = \%data;
} # warn Dumper $map->{history};
}
{ # result_summaries:
my $sql = q!select rs.`request_id`, rs.`results_summary`, ls.`section_name`
from `request_result_summaries` rs join `lab_sections` ls on
rs.`lab_section_id` = ls.`id` where rs.`request_id` in (??)!;
my $result = $dbix->query($sql, @$request_ids);
while ( my $vars = $result->hash ) { # warn Dumper $vars;
my $request_id = $vars->{request_id};
my $section = $vars->{section_name};
my $result = $vars->{results_summary};
$map->{result_summary}->{$request_id}->{$section} = $result;
} # warn Dumper $map->{result_summary};
}
return $map;
}
sub _ftp_file {
my $args = shift;
my $cfg = $settings->{ppm_server};
my %params = (
local_filename => $args->{local_filename},
remote_filename => $args->{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(\%params);
if ($rtn) { # warn Dumper $rtn;
$tools->mail_admin({ script => $0, msg => $rtn });
warn "$0 - $rtn\n"; # dump to logs but don't die!!
}
else {
io($args->{local_filename})->unlink;
}
}
