#!/usr/bin/perl
=begin
--------------------------------------------------------------------------------
generates NCRS XML data feed for new and revised diagnoses [or all icdo3 '/3' reports
authorised or revised - change nycris to ncrs in libray.sql] during previous 1 month
SCP file transfer
manual command-line:
ncrs_cosd.pl [duration in months - optional (defaults to 1)]
scp /tmp/<filename> hmds@163.160.247.17:<filename>
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!! for new server: need to manually ssh into server once to add key to known_hosts
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
online reference:
ICDO3 topographical codes: http://codes.iarc.fr/topography
ICDO3 morphological codes: http://codes.iarc.fr/codegroup/2
--------------------------------------------------------------------------------
=cut
my $JUST_TESTING = 1; # skips file transfer & file archive
use lib '/home/raj/perl5/lib/perl5';
use XML::Simple qw(:strict); # need to specify ForceArray & KeyAttr if using :strict here
use Data::Printer;
use Config::Auto;
use Data::Dumper;
use Modern::Perl;
use DateTime; # for last_day_of_month()
use IO::All;
use FindBin qw($Bin); # warn $Bin;
use lib $Bin . '/../../../lib';
use LIMS::Local::ScriptHelpers;
#############################################
my $delimiter = q{|}; #
my $duration = $ARGV[0] || 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();
# dates ========================================================================
# get date last month - handles BST:
my $ref_datetime = $tools->date_subtract(months => $duration);
my $timestamp = $tools->time_now->datetime;
my $start_date = $ref_datetime->strftime('%Y-%m-01');
my $end_date = DateTime->last_day_of_month(
year => $ref_datetime->year,
month => $ref_datetime->month,
)->ymd; # p $start_date; p $end_date;
# ==============================================================================
my $data_filename = sprintf 'hmds_%s_%02d.txt',
$ref_datetime->year, $ref_datetime->month; # p $data_filename;
# $data_filename = 'hmds_test_cosd.xml';
use constant HMDS_ORG_CODE => 'RR813'; # OrgCodePathReport & OrgCodeSubmitter
use constant TMP_DIR => '/tmp'; # where to create temp data file
# decode for biopsy_site info:
my $anatomical_site_map =
$dbix->select('anatomical_sites', [qw(site_name snomed)])->map;
# p $anatomical_site_map;
# for non-histology specimens (sample_code NOT RLIKE '[DGLRX]([BS]L|F|U)'):
# NB these are ICDO3 topography codes for site of tumour origin
my %specimen_topography = (
BMA => 'C42.1',
BMAT => 'C42.1',
CF => '',
CHIA => 'C42.0', # should never issue new diagnosis on CHIA
CHIB => 'C42.0', # should never issue new diagnosis on CHIB
CHIM => 'C42.0', # should never issue new diagnosis on CHIM
CMP => '', # should never issue new diagnosis on CMP
EF => '',
# HS => '', # require biopsy_site now
# LA => 'C77.9', # require biopsy_site now
PB => 'C42.0',
SE => '', # never issue new diagnosis on SE
TBL => 'C42.1',
TBP => 'C42.1',
TSL => 'C42.1',
URI => '', # never issue new diagnosis on URI
# XA => '', # require biopsy_site now
RXPB => 'C42.0', # should never issue new diagnosis on RXPB
TSM => '', # never issue new diagnosis on TSM
);
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('ncrs_data'); # p $query;
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};
# merge vertical table data with $vars:
combine_data($vars, $data_map->{$request_id}); p $vars;
push @data, $vars;
} # p @data;
}
{ # create output file & push to remote server:
my $file_path = join '/', TMP_DIR, $data_filename;
my $content = to_xml(\@data); # p $content;
$content > io($file_path);
# transfer file:
unless ($JUST_TESTING) {
my %args = ( local_filename => $file_path );
transfer_file(\%args);
}
}
#-------------------------------------------------------------------------------
sub to_xml {
my $data = shift; # arrayref of request datasets
my $count = @$data;
# options for XMLout (needs array or hash):
my %xs_opts = xs_options(); # p %xs_opts;
my $xs = XML::Simple->new(%xs_opts);
my $ref = {
Id => {
root => '18DA78B8-44A4-4AA7-95B0-87C198E6B0AE', # where does this come from ?
},
OrgCodeSubmitter => {
extension => HMDS_ORG_CODE,
},
RecordCount => {
value => $count,
},
ReportingPeriodStartDate => $start_date,
ReportingPeriodEndDate => $end_date,
FileCreationDateTime => $timestamp,
};
push @{ $ref->{COSDRecord} }, format_cosd_unit($_) for @$data; # p $ref;
# enclose xml in outer <add> block; add ulisa 'version' inline:
# my $input = { add => $vars, version => 2 };
my $xml_out = $xs->XMLout($ref); # p $xml_out;
return $xml_out;
}
#-------------------------------------------------------------------------------
# formats repeating COSDRecord blocks:
sub format_cosd_unit {
my $v = shift;
my %COSDRecord = (
Id => {
root => 'B63AFD92-568E-4845-A0CE-2643FE15DE08', # where does this come from ?
},
);
my %HAEM;
{ # COSDRecord/Haematology/HaematologyCore:
my %h = (
HaematologyCoreLinkagePatientId => {
NHSNumber => {
extension => $v->{nhs_number},
},
NHSNumberStatusIndicator => {
code => '02', # Number present but not traced
},
LocalPatientId => $v->{unit_number},
Birthdate => $v->{dob},
OrgCodeOfProvider => {
extension => $v->{organisation_code},
},
},
HaematologyCoreLinkageDiagnosis => {
InvestigationResultDate => $v->{authorisation_date},
ServiceReportId => $v->{labno},
},
HaematologyCoreDemographics => {
PersonFamilyName => {
family => $v->{last_name},
},
PersonGivenName => {
given => given_name($v),
},
Address => {
UnstructuredAddress => {
streetAddressLine => $v->{address},
},
},
Postcode => {
postalCode => $v->{post_code},
},
Gender => {
code => gender_code($v->{gender}),
},
},
HaematologyCorePathology => {
PathologistConsultantCode => { extension => $v->{reporter_code} },
PathTestReqCareProfCode => { extension => $v->{referrer_code} },
SampleCollectionDate => { extension => $v->{sample_date} },
OrgCodePathReport => { extension => HMDS_ORG_CODE },
ServiceReportStatus => { code => 1 }, # final (complete)
PathTestReqSiteCode => { extension => $v->{organisation_code} },
PathologyReportText => free_text_report($v),
SampleReceiptDate => $v->{request_date},
MorphologySNOMED => icdo3_to_snomed($v->{icdo3}), # ICDO3
# useless for haematology - refers to solid tumours:
# 1 = primary, 4 = region LN, 5 = metastatic, 9 = not known
SpecimenNature => { code => 9 },
# specimen code (maybe multiple) - not sure yet which to use:
# TopographySNOMED => sample_to_snomed($v),
# PrimaryDiagnosisICDPath => sample_to_snomed($v),
},
);
$HAEM{HaematologyCore} = \%h;
}
{ # COSDRecord/Haematology/HeamatologyContent/LaboratoryResults:
my %h = (
HighThroughputSequencing => $v->{high_throughput_sequencing},
Immunocytochemistry => $v->{immunocytochemistry},
FlowCytometry => $v->{flow_cytometry},
Cytogenetics => $v->{cytogenetics},
MicroArray => $v->{micro_array},
Molecular => $v->{molecular},
FISH => $v->{fish},
);
$HAEM{HaematologyContent}{LaboratoryResults} = \%h;
}
$COSDRecord{Haematology} = \%HAEM;
return \%COSDRecord;
}
#-------------------------------------------------------------------------------
# free-text specimen/biopsy_site/morphology/comment, etc:
sub free_text_report {
my $vars = shift;
my @rows;
push @rows, ( 'SPECIMEN(S): ' . $vars->{specimen_decode} );
if ( my $biopsy_site = $vars->{biopsy_site} ) {
push @rows, ( 'ANATOMICAL SITE(S): ' . $biopsy_site );
}
push @rows, ( 'SPECIMEN QUALITY: ' . $vars->{specimen_quality} );
if ( my $gross_desc = $vars->{gross_description} ) {
push @rows, ( 'GROSS DESCRIPTION: ' . $gross_desc );
}
if ( my $morphology = $vars->{morphology} ) {
push @rows, ( 'MORPHOLOGY: ' . $morphology );
}
if ( my $comment = $vars->{comment} ) {
push @rows, ( 'COMMENT: ' . $comment );
}
push @rows, ( 'DIAGNOSIS: ' . $vars->{diagnosis} );
return join "\n", @rows;
}
#-------------------------------------------------------------------------------
# merge vertical table data with $vars - no return needed (working on hashref)
sub combine_data {
my ($vars, $supplimentary_data) = @_; # p $supplimentary_data;
{ # add data-map fields:
# result summaries:
map $vars->{$_} = $supplimentary_data->{result_summary}->{$_},
qw( immunocytochemistry flow_cytometry fish cytogenetics molecular
micro_array high_throughput_sequencing );
# 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} # not needed ?
= $supplimentary_data->{specimen}->{description};
} # p $vars;
# tidy up (trim content & substitute new-line markers):
map { $vars->{$_} = tidy($vars->{$_}) }
grep $vars->{$_},
qw(comment immunocytochemistry flow_cytometry fish gross_description
micro_array high_throughput_sequencing cytogenetics molecular);
$vars->{gender} ||= 'U'; # p $vars;
return 0; # updating $vars hashref, return not required
}
#-------------------------------------------------------------------------------
sub sample_to_snomed {
my $vars = shift;
my @snomed;
# get info from biopsy_site if available, otherwise specimen code(s):
if ( my $biopsy_site = $vars->{biopsy_site} ) { # optional
my @sites = split '; ', $biopsy_site; # maybe multiple
push @snomed, $anatomical_site_map->{$_} for @sites;
}
else {
my @specimens = split ',', $vars->{specimen_code};
push @snomed, $specimen_topography{$_} for @specimens;
} # p @snomed;
# legacy biopsy site that doesn't match anatomical_sites.site_name:
return { code => 'C80.9' } unless @snomed; # site unknown
return scalar @snomed == 1
? { code => $snomed[0] }
: [ map { code => $_ }, @snomed ];
}
#-------------------------------------------------------------------------------
sub icdo3_to_snomed { # eg 9960/3 -> M99603
local $_ = shift || return undef; # p $icdo3;
m!(\d{4})/(\d)!;
return 'M' . $1 . $2;
}
#-------------------------------------------------------------------------------
sub gender_code {
my $gender = shift;
return 1 if $gender eq 'M';
return 2 if $gender eq 'F';
return 9; # x = not known, 9 = not specified
}
#-------------------------------------------------------------------------------
# first + optional middle names
sub given_name {
my $vars = shift;
return join ' ', grep $_, @{$vars}{ qw/first_name middle_name/ };
}
#-------------------------------------------------------------------------------
sub xs_options {
my %opts = (
SuppressEmpty => 0, # ? only works for xml_in
RootName => 'COSD',
XMLDecl => q!<?xml version="1.0" encoding="UTF-8"?>!,
KeyAttr => [],
NoAttr => 1, # gives inline (scalar) AND nested (arrayref) attributes
);
return %opts;
}
#-------------------------------------------------------------------------------
sub get_request_ids {
my @request_ids = (); # return [ 264710, 204466 ];
{ # new diagnoses:
my $sql = $sql_lib->retr('ncrs_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('ncrs_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 ];
}
#-------------------------------------------------------------------------------
sub transfer_file { # only called if not $JUST_TESTING
my $args = shift;
my $cfg = $settings->{nycris_server};
my %params = (
local_filename => $args->{local_filename},
server_addr => $cfg->{remote_address},
username => $cfg->{username},
password => $cfg->{password},
); # p %params;
# scp file (returns str on failure, undef on success):
my $rtn = $tools->scp_file(\%params); # p $rtn;
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_datetime->month_name; # for cron log:
print "$script reports data for $month succesfully uploaded\n";
}
}
#-------------------------------------------------------------------------------
# archive data file (only called if not $JUST_TESTING):
sub archive_and_delete_file {
my $src_file = shift; # p $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; # p $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 $result = do {
my $sql = $sql_lib->retr('nycris_request_specimens'); # p $sql;
$dbix->query($sql, @$request_ids);
};
while ( my $vars = $result->hash ) { # p $vars;
my $request_id = $vars->{request_id};
my %data = (
specimen_code => $vars->{code},
description => $vars->{description},
); # p %data;
$map->{$request_id}->{specimen} = \%data;
}
}
{ # reporter data:
my $result = do {
my $sql = $sql_lib->retr('nycris_reporters'); # p $sql;
$dbix->query($sql, @$request_ids);
};
while ( my $vars = $result->hash ) { # p $vars;
my $request_id = $vars->{request_id};
my $reporter = join ' ',
ucfirst $vars->{first_name},
ucfirst $vars->{last_name};
my $reporter_code = get_user_code($vars->{username});
my %data = (
reporter_name => $reporter,
reporter_code => $reporter_code,
);
$map->{$request_id}->{reporter_data} = \%data;
} # p $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 ) { # p $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;
} # p $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;
}
