#!/usr/bin/perl
=begin -------------------------------------------------------------------------
generates NYCRIS data feed for new and revised diagnoses during previous 1 month
creates pipe-delimited rows, one row per request. Email file transfer (SCP broken).
command-line: nycris.pl [duration in months - optional]
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!! for new server: need to manually ssh into server once to add key to known_hosts
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
=cut
use Getopt::Std;
getopts('m:t'); # months, testing
our($opt_m,$opt_t); # warn $opt_m; exit;
use strict;
use warnings;
my $JUST_TESTING = $opt_t || 0; # skips file transfer & file archive
use lib '/home/raj/perl5/lib/perl5';
use IO::All;
use Config::Auto;
use IPC::System::Simple qw(capture);
use Data::Printer alias => 'p';
use FindBin qw($Bin); # warn $Bin;
use lib $Bin . '/../../../lib';
use LIMS::Local::ScriptHelpers;
#############################################
my $delimiter = q{|}; #
my $duration = $opt_m || 1; # months ago #
my $new_line_marker = '[NEW_LINE]'; #
#############################################
my $cfg_file = "$Bin/../lib/settings.cfg";
my $settings = Config::Auto::parse($cfg_file); # p $settings;
# get tools from LIMS::Local::ScriptHelpers:
my $tools = LIMS::Local::ScriptHelpers->new();
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
# get date last month - handles BST:
my $ref_date = $tools->date_subtract(months => $duration); # warn ref_date; exit;
my $data_filename = sprintf 'hmds_%s_%02d.txt',
$ref_date->year, $ref_date->month; # warn $data_filename;
use constant TMP_DIR => '/tmp'; # where to create temp data file
my @data = ();
# go:
{
# get request ID's for horizontal (1-to-1) & vertical (1-to-many) tables:
my $request_ids = get_request_ids(); # p $request_ids;
# get request result 1-to-1 data:
my $query = $sql_lib->retr('nycris_data');
my $result = $dbix->query($query, @$request_ids);
# get data maps of vertical tables - much faster than tying into main query:
my $data_map = get_data_map($request_ids); # p $data_map;
while ( my $vars = $result->hash ) { # p $vars; next;
my $request_id = $vars->{request_id};
# combine horizontal & vertical table data:
my $row = combine_data($vars, $data_map->{$request_id});
push @data, $row; # warn $row;
} # p \@data;
}
{ # create output file & push to remote server:
my $file_path = join '/', TMP_DIR, $data_filename;
my $contents = join "\n", @data;
$contents > io($file_path); # warn $contents;
# transfer file:
unless ($JUST_TESTING) {
transfer_file({ local_filename => $file_path });
}
}
# combine horizontal & vertical table data & return formatted row:
sub combine_data {
my ($vars, $supplimentary_data) = @_;
{ # add data-map fields:
# result summaries:
map $vars->{$_} = $supplimentary_data->{result_summary}->{$_},
qw(immunocytochemistry flow_cytometry fish cytogenetics molecular);
# reporter:
map $vars->{$_} = $supplimentary_data->{reporter_data}->{$_},
qw(reporter_name reporter_code);
# specimen code(s) & decode(s):
$vars->{specimen_code}
= $supplimentary_data->{specimen}->{specimen_code};
$vars->{specimen_decode}
= $supplimentary_data->{specimen}->{description};
}
# tidy up (trim content & substitute new-line markers):
map { $vars->{$_} = tidy($vars->{$_}) }
grep $vars->{$_},
qw(comment immunocytochemistry flow_cytometry fish cytogenetics
gross_description molecular);
$vars->{gender} ||= 'U';
$vars->{hmds_org_code} = 'RR813';
my @fields = qw(
request_id
labno
request_date
last_name
first_name
middle_name
unit_number
dob
nhs_number
gender
referrer
referrer_code
location
organisation_code
specimen_code
specimen_decode
clinical_details
gross_description
specimen_quality
comment
diagnosis
icdo3
flow_cytometry
immunohistochemistry
molecular
cytogenetics
fish
reporter_name
reporter_code
authorisation_date
hmds_org_code
);
no warnings 'uninitialized'; # lots in $vars
my $row = join $delimiter, map $vars->{$_}, @fields;
# row needs to start with request ID - in case of unescaped new-line marker:
die 'malformed row detected' unless $row =~ /\A\d{6,}$delimiter/;
return $row;
}
sub get_request_ids {
my @request_ids = ();
{ # new diagnoses:
my $sql = $sql_lib->retr('nycris_new_diagnosis_request_ids');
my $request_ids = $dbix->query($sql, $duration, $duration)->flat;
push @request_ids, @$request_ids; # p $request_ids;
}
{ # get revised diagnoses:
my $sql = $sql_lib->retr('nycris_revised_diagnosis_request_ids');
my $request_ids = $dbix->query($sql, $duration, $duration)->flat;
push @request_ids, @$request_ids; # p $request_ids;
}
# combine new & revised diagnosis request ID's; eliminate duplicates:
my %request_ids = map { $_ => 1 } @request_ids; # p \%request_ids;
# return unique ID's as arrayref:
return [ keys %request_ids ];
}
# scp function broken, replaced by email 07/2016
sub transfer_file { # only called if not $JUST_TESTING
my $args = shift; # p $args;
my $cfg = $settings->{nycris_server};
my %params = (
local_filename => $args->{local_filename},
server_addr => $cfg->{remote_address},
username => $cfg->{username},
password => $cfg->{password},
);
# scp file (returns str on failure, undef on success):
# my $rtn = $tools->scp_file(\%params); scp function broken;
my $rtn = email_file(); # 05/07/2016
my $script = $tools->script_filename;
if ($rtn) {
$tools->mail_admin({ script => $0, msg => $rtn });
warn "$script - $rtn\n"; # dump to logs but don't die!!
}
else {
archive_and_delete_file($args->{local_filename});
my $month = $ref_date->month_name; # for cron log:
print "$script reports data for $month successfully uploaded\n";
}
}
sub email_file { # email a password-protected file:
( my $zip_filename = $data_filename ) =~ s/txt$/zip/; # warn $zip_filename;
( my $subject = $data_filename ) =~ s/\.txt$//; # warn $subject;
my @cmd = ('/usr/bin/zip');
push @cmd, '-q'; # quiet
push @cmd, '-j'; # junk dir name
push @cmd, '--password';
push @cmd, ucfirst $subject; # using subject title as passwd
# --------------------------------------------------------------------------
push @cmd, '-'; # only needed to allow piping of content if using capture()
# --------------------------------------------------------------------------
push @cmd, TMP_DIR . '/' . $zip_filename;
push @cmd, TMP_DIR . '/' . $data_filename; # p @cmd;
=begin # method to save zip file to disk & then use io() for $content:
# system(@cmd);
# my $content = io->file(TMP_DIR . '/' . $zip_filename)->all;
=cut
# use IPC::System::Simple to cature zip output:
my $content = capture(@cmd);
my %mail = (
config => $config,
subject => $subject,
filename => $zip_filename,
attachment => $content,
); # p %mail;
$tools->send_mail(\%mail, [ $settings->{ncrs_data}->{leeds}->{recipient} ]);
return 0; # to trigger archive & delete
}
# archive data file (only called if not $JUST_TESTING):
sub archive_and_delete_file {
my $src_file = shift; # warn $src_file;
my $path_to_archive = $settings->{nycris_server}->{path_to_archive};
# make sure it exists otherwise get error trying to tar non-existant file
if (-e $src_file ) { # warn 'it exists';
my $tar_file = sprintf '%s/%s.tar',
$path_to_archive, $data_filename; # warn $tar_file;
chdir TMP_DIR; # 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
# delete source file:
io($src_file)->unlink;
}
}
sub get_user_code {
my $username = shift;
return $settings->{national_codes}->{$username}
|| 'H9999998'; # OTHER HEALTH CARE PROFESSIONAL
}
sub get_data_map {
my $request_ids = shift;
my $map = {};
{ # request_specimens:
my $sql = $sql_lib->retr('nycris_request_specimens'); # warn $sql;
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},
); # warn Dumper \%data;
$map->{$request_id}->{specimen} = \%data;
}
}
{ # reporter data:
my $sql = q!
select rh.request_id, u.username, u.first_name, u.last_name,
ur.registration_number
from request_history rh join users u on rh.user_id = u.id
left join user_registration ur on ur.user_id = u.id
where rh.action = 'reported' and 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 $reporter = join ' ',
ucfirst $vars->{first_name},
ucfirst $vars->{last_name};
my $reporter_code = $vars->{registration_number} || 'H9999998'; # OTHER HEALTH CARE PROFESSIONAL;
my %data = (
reporter_name => $reporter,
reporter_code => $reporter_code,
);
$map->{$request_id}->{reporter_data} = \%data;
} # warn Dumper $map->{reporter_data};
}
{ # result summaries:
my $sql = $sql_lib->retr('nycris_result_summaries');
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};
$section =~ s/ /_/g; # make section suitable for use as hash key
$map->{$request_id}->{result_summary}->{lc $section} = $result;
} # warn Dumper $map->{result_summary};
}
return $map;
}
sub tidy {
my $str = shift;
# trim:
$str =~ s/\A\s+//; # leading
$str =~ s/\s+\Z//; # trailing
# $str =~ s/(\r\n)/$new_line_marker/g; # doesn't capture just \n
$str =~ s/\r?\n/$new_line_marker/g; # captures both \r\n & \n
return $str;
}
