#!/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
=cut ---------------------------------------------------------------------------
use strict;
use warnings;
my $JUST_TESTING = 1; # skips ftp, puts data files in /tmp, emails just raj
BEGIN {
use FindBin qw($Bin); # warn $Bin; exit;
use lib "$Bin/../../../lib";
}
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 $delimiter = '|'; #
my $duration = 2; # months ago #
#################################
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();
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
my $today = $tools->time_now();
my $data_filename = sprintf 'hmds_%s', $today->ymd('_');
my @data = ();
# go:
{
# get request ID's for horizontal & vertical tables:
my $request_ids = get_request_ids(); # warn Dumper $request_ids;
# get data maps of vertical tables - much faster than tying into main query:
my $data_map = get_data_map($request_ids); # warn Dumper $data_map;
# get request result 1-to-1 data:
my $query = $sql_lib->retr('nycris_data');
my $result = $dbix->query($query, @$request_ids);
while ( my $vars = $result->hash ) { # warn Dumper $vars; next;
my $row = parse_data($vars, $data_map); # combine horizontal & vertical tbls
push @data, $row; # warn $row;
} # warn Dumper \@data;
}
{ # create file & FTP:
my $file_path = '/tmp/' . $data_filename;
my $contents = join "\n", @data;
$contents > io($file_path); # warn $contents;
# ftp file:
unless ($JUST_TESTING) {
my %args = (
local_filename => $file_path,
remote_filename => $data_filename,
);
ftp_file(\%args);
}
}
# archive results file:
unless ($JUST_TESTING) {}
# combine horizontal & vertical tables:
sub parse_data {
my ($vars, $data_map) = @_;
{ # add data-map fields:
my $request_id = $vars->{request_id};
# specimen code(s):
$vars->{specimen_code}
= $data_map->{specimen}->{$request_id}->{specimen_code};
# result summaries:
map $vars->{$_} = $data_map->{result_summary}->{$request_id}->{$_},
qw(immunocytochemistry flow_cytometry fish cytogenetics molecular);
# reporter:
map $vars->{$_} = $data_map->{reporter_data}->{$request_id}->{$_},
qw(reporter_name reporter_code);
}
# 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';
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
clinical_details
gross_description
specimen_quality
comment
diagnosis
icdo3
flow_cytometry
immunohistochemistry
molecular
cytogenetics
fish
reporter_name
reporter_code
authorisation_date
);
no warnings 'uninitialized'; # lots in $vars
my $row = join $delimiter, map $vars->{$_}, @fields;
# row needs to start with request ID - in case unescaped new-line marker present
die unless $row =~ /\A\d{6,}/;
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; # warn Dumper $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; # warn Dumper $request_ids;
}
# combine & eliminate duplicates
my %request_ids = map { $_ => 1 } @request_ids; # warn Dumper \%request_ids;
return [ keys %request_ids ];
}
sub ftp_file { return 0;
my $args = shift;
my $cfg = $settings->{nycris_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) {
$tools->mail_admin({ script => $0, msg => $rtn });
warn "$0 - $rtn\n"; # dump to logs but don't die!!
}
else {
io($args->{local_filename})->unlink;
}
}
sub user_codes {
my $username = shift;
my $national_codes = {
swirsky => 'C2202309',
burton => 'C4370806',
tooze => 'C3664265',
cargo => 'C6050871',
jack => 'C2547174',
owen => 'C3271078',
richards => 'CS01892',
rawstron => 'CS01874',
oconnor => 'CS01696',
evans => 'CS09254',
};
return $national_codes->{$username}
|| 'H9999998'; # OTHER HEALTH CARE PROFESSIONAL
}
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};
}
{ # reporter data:
my $sql = q!select rh.request_id, u.username, u.first_name, u.last_name
from request_history rh join users u on ( rh.user_id = u.id and
action = 'reported' ) where 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 = user_codes($vars->{username});
my %data = (
reporter_name => $reporter,
reporter_code => $reporter_code,
);
$map->{reporter_data}->{$request_id} = \%data;
} # warn Dumper $map->{reporter_data};
}
{ # 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};
$section =~ s/ /_/g;
$map->{result_summary}->{$request_id}->{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]/g; # substitute new-line marker
return $str;
}
=begin
# 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';
}
=cut
