#!/usr/bin/perl
=begin -------------------------------------------------------------------------
Generates pipe-delimited txt & xls files on Roche Gallium trial cases for
Quintiles. Record must be authorised and referred from Quintiles to be included
in data feed. Later requests on same QLABS accession number (eg Ennnnnnn) supercede
earlier ones. Quintiles require unique accession number / test code combination
- tested for at end
=cut ---------------------------------------------------------------------------
use strict;
use warnings;
my $JUST_TESTING = 0; # dump data to file
use lib '/home/raj/perl5/lib/perl5';
use FindBin qw($Bin); # warn $Bin;
use lib "$Bin/../../../lib";
use IO::All;
use Data::Dump qw(dump);
use LIMS::Local::Utils;
use DateTime::Format::MySQL;
use LIMS::Local::GalliumTrial;
use LIMS::Local::ScriptHelpers;
use Spreadsheet::WriteExcel::Simple;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);
################################################################################
my @recipients = qw(
marvin.marcellana
hmds.lth@nhs.net
archana.ambily
irfan.shaikh
);
my $filename = sprintf 'BO21223_%s', $tools->time_now->ymd;
my $subject = $filename;
################################################################################
# get tools from LIMS::Local::ScriptHelpers:
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
# ensure case-sensitivity of col names preserved (eg bcl2 & BCL2):
$dbix->lc_columns = 0;
my $results = do {
my $sql = $sql_lib->retr('gallium_trial_data'); # warn $sql;
$dbix->query($sql)->hashes;
};
my %results; # AoH
ROW: # group data by accession number:
for my $row ( @$results ) { # warn dump $row;
# must be authorised (= reported col), but exclude Kiel data:
next ROW unless $row->{reported} && $row->{location} =~ /Quintiles/;
my $accession_number = $row->{accession_number} || next ROW;
# collect as array of datasets for each accession number:
push @{ $results{$accession_number} }, $row;
}
my $trim = sub { LIMS::Local::Utils::trim(@_) };
my $NULL = ""; # to avoid need for no warnings 'uninitialized'
my @rows;
# process sole - or most recent if >1 - dataset for each accession number:
for my $accession_number ( sort keys %results ) { # warn dump $accession_number;
my $data = $results{$accession_number};
# $data is either hashref or array(ref) of hashrefs:
my $vars = ref $data eq 'ARRAY'
? $data->[-1] # use most recent dataset (query ensures request.id order)
: $data; # warn dump $vars;
my $dob;
if ( my $date = $vars->{dob} ) { # dd-MON-YYYY format required !!
$dob = DateTime::Format::MySQL->parse_date($date)->strftime('%d-%b-%Y');
$dob =~ tr/[a-z]/[A-Z]/; # warn $dob; # dd-mon-yyyy -> dd-MON-yyyy
}
my @common = ( # common fields for all rows:
'Leeds', # referring lab
$vars->{hmds_ref}, # HMDS number
$accession_number, # QLABS accession number (1st 8 chars only)
$vars->{patient_id} || $NULL, # subject ID
$dob || $NULL, # dd-MON-YYYY format required !!
'TISSUE FOR PATH REVIEW',
);
my $gallium = LIMS::Local::GalliumTrial->new(data => $vars);
# SDL2087: [First Time Reviewer / Adjudicator]
if ( my $result = $gallium->get_lab_role ) { # warn Dumper $result;
push @rows, join '|', @common, ( 'SDL2087', $result, $NULL );
}
# SDL2088: [Anatomical localisation of biopsy]
if ( my $site = $gallium->get_biopsy_site ) { # warn Dumper $site;
push @rows, join '|', @common, ( 'SDL2088', $site, $NULL );
}
# SDL2093: [Pattern of involvement: interstitial, diffuse, etc]
if ( my $pattern = $gallium->get_involvement_pattern ) {
push @rows, join '|', @common, ( 'SDL2093', $pattern, $NULL );
}
# SDL2090: [Follicular lymphoma grade: 1, 2, 3a, 3b]
if ( my $grade = $gallium->get_lymphoma_grade ) { # extract grade (only if FL):
push @rows, join '|', @common, ( 'SDL2090', $grade, $NULL ); # warn $grade;
}
# SDL2089: [Sample quality: Good/Average/Poor]
if ( my $result = $gallium->get_sample_quality ) {
push @rows, join '|', @common, ( 'SDL2089', $result, $NULL );
}
# SDL2091: Morphology comment [free text]
if ( my $comment = $gallium->get_morphology_comment ) {
push @rows, join '|', @common, ( 'SDL2091', $comment, $NULL );
}
# SDL2092: Lymphoma involvement [%]
if ( my $num = $gallium->get_lymphoma_involvment ) {
push @rows, join '|', @common, ( 'SDL2092', $num, $NULL );
}
# SDL2099 - SDL2134 marker results [+, -, +/-, Not Evaluable]
if ( my $results = $gallium->get_test_results ) {
push @rows, join '|', @common, ( $_, $results->{$_} ) for keys %$results;
}
# SDL2111: IgH-ASO-PCR [Done / Not Done]
# SDL2112: IgH-ASO-PCR Result [not evaluable, monoclonal, oligoclonal, polyclonal]
# SDL2113: IgH-ASO-PCR Base-pair length [only if monoclonal; numeric]
# SDL2114: IgH-ASO-PCR Comment [free text]
if ( my $result = $gallium->get_igh_pcr ) {
if ( my $str = $result->{igh_pcr_assay} ) { # warn $str;
push @rows, join '|', @common, ( 'SDL2111', $str, $NULL );
}
if ( my $str = $result->{igh_pcr_result} ) { # warn $str;
push @rows, join '|', @common, ( 'SDL2112', $str, $NULL );
}
if ( my $int = $result->{igh_pcr_bp_length} ) { # warn $int;
push @rows, join '|', @common, ( 'SDL2113', $int, $NULL );
}
if ( my $str = $result->{igh_pcr_comment} ) { # warn $str;
push @rows, join '|', @common, ( 'SDL2114', $str, $NULL );
}
}
# SDL2115: BCL2 break-apart [Positive, Negative, Not Evaluable]
if ( my $result = $gallium->get_fish_break_apart_result('BCL2') ) {
push @rows, join '|', @common, ( 'SDL2115', $result, $NULL );
}
# SDL2116: BCL6 break-apart [Positive, Negative, Not Evaluable]
if ( my $result = $gallium->get_fish_break_apart_result('BCL6') ) {
push @rows, join '|', @common, ( 'SDL2116', $result, $NULL );
}
# SDL2117: t(14;18) fusion assay [Positive, Negative, Not Evaluable]
if ( my $result = $gallium->get_fish_fusion_assay_result('BCL2_IgH') ) {
push @rows, join '|', @common, ( 'SDL2117', $result, $NULL );
}
# SDL2118: FISH comment [free text]
if ( my $result = $gallium->get_fish_summary ) {
push @rows, join '|', @common, ( 'SDL2118', $result, $NULL );
}
# SDL2094: Final diagnosis
if ( my $diagnosis = $gallium->get_diagnosis ) {
push @rows, join '|', @common, ( 'SDL2094', $diagnosis, $NULL );
}
# SDL2095: Discrepancy with local diagnosis [Yes, No]
if ( my $result = $gallium->is_discrepant_diagnosis ) {
push @rows, join '|', @common, ( 'SDL2095', $result, $NULL );
}
# SDL2096: Urgent report required [Yes, No]
if ( my $result = $gallium->is_urgent_report ) {
push @rows, join '|', @common, ( 'SDL2096', $result, $NULL );
}
# SDL2097: Urgent block return required [Yes, No]
if ( my $result = $gallium->is_urgent_block_return ) {
push @rows, join '|', @common, ( 'SDL2097', $result, $NULL );
}
# SDL2098: Insufficient material, retest required [Yes, No]
if ( my $result = $gallium->is_retest_required ) {
push @rows, join '|', @common, ( 'SDL2098', $result, $NULL );
}
# SDL2125: ICDO3 code
if ( my $icdo3 = $gallium->get_icdo3 ) {
push @rows, join '|', @common, ( 'SDL2125', $icdo3, $NULL );
}
}
exit if ! @rows;
{ # check accession number / test code is unique:
my %h;
for (@rows) {
my @data = split '\|'; # warn dump @data;
die "duplicate $data[2] / $data[6] combination"
if $h{$data[2]}{$data[6]}++; # [2] = accession number; [6] = test code
}
}
{ # xl spreadsheet (do this before .dat)
my $xl = Spreadsheet::WriteExcel::Simple->new;
for (@rows) {
my @row = split '\|';
$xl->write_row(\@row);
}
# save to file if just testing:
$xl->save("$Bin/$filename.xls") if $JUST_TESTING;
my %mail = (
attachment => $xl->data,
filename => "$filename.xls", # BO21223_yyyymmdd
subject => $subject,
config => $config,
);
$tools->send_mail(\%mail, \@recipients);
}
=begin
{ # pipe-delimited file:
my $data = join "\n", @rows;
$filename .= '.dat'; # can append now
$data > io($Bin.'/'.$filename) if $JUST_TESTING;
my %mail = (
attachment => $data,
filename => $filename, # BO21223_yyyymmdd.dat
subject => $subject,
config => $config,
);
$tools->send_mail(\%mail, \@recipients);
}
=cut
# any duplicate accession numbers:
my @ary = map $results{$_}, grep { scalar @{ $results{$_} } > 1 } keys %results;
if (@ary) { # alert admin if any duplicate accession numbers:
( dump @ary ) > io($Bin.'/quintiles_duplicates.txt') if $JUST_TESTING;
my %args = (
subject => 'QLABS accession number duplicates', # can supply instead of 'script'
msg => dump(@ary),
);
$tools->mail_admin(\%args);
}
=begin fields:
SDL2086: HMDS
SDL2087: [First Time Reviewer / Adjudicator]
SDL2088: [Anatomical localisation of biopsy: see list]
SDL2089: [Sample quality: Good/Average/Poor]
SDL2090: [Follicular lymphoma grade: 1, 2, 3a, 3b]
SDL2091: Morphology comment [free text]
SDL2092: Lymphoma involvement [%]
SDL2093: Pattern of involvement [interstitial, diffuse, nodular, intrasinusoidal]
SDL2099 - SDL2110 - test results [+, -, +/-, Not Evaluable]
SDL2111: IgH-ASO-PCR [Done / Not Done]
SDL2112: IgH-ASO-PCR Result [not evaluable, monoclonal, oligoclonal, polyclonal]
SDL2113: IgH-ASO-PCR Base-pair length [only if monoclonal; numeric]
SDL2114: IgH-ASO-PCR Comment [free text]
SDL2115: BCL2 break-apart [Positive, Negative, Not Evaluable]
SDL2116: BCL6 break-apart [Positive, Negative, Not Evaluable]
SDL2117: t(14;18) fusion assay [Positive, Negative, Not Evaluable]
SDL2118: FISH comment [free text]
SDL2094: Final diagnosis
SDL2095: Discrepancy with local diagnosis [Yes, No]
SDL2096: Urgent report required [Yes, No]
SDL2097: Urgent block return required [Yes, No]
SDL2098: Insufficient material, retest required [Yes, No]
SDL2125: ICDO3 code
SDL2123: Kappa light chain [+, -, +/-, Not Evaluable]
SDL2134: Lambda light chain [+, -, +/-, Not Evaluable]
9-field data file:
1: HMDS
2: HMDS_ref [optional]
3: accession number ie pc.unit_number
4: Patient ID [optional]
5: DoB [optional]
6: Visit description [optional]
7: QLAB test code ie SDLxxxx
8: Test result [or CANCELLED + comment in next field]
9: Comment [only for cancelled results]
=cut
