• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/perl

=begin -------------------------------------------------------------------------
Generates spreadsheet on Roche Gallium trial cases. Assumptions for cases referred
to Kiel: if diagnosis is, or was, "Gallium trial - referred to Kiel", date of
referral = authorisation date. If diagnosis subsequently updated, then return date
assumed to be date of diagnosis change (taken from request_diagnosis_history table
where entry = "Gallium trial - referred to Kiel")
=cut ---------------------------------------------------------------------------

use strict;
use warnings;

my $JUST_TESTING = 1; # email to ra.jones only

use lib '/home/raj/perl5/lib/perl5';
use FindBin qw($Bin); # warn $Bin;
use lib "$Bin/../../../lib";

use Data::Dumper;
use LIMS::Local::Utils;
use LIMS::Local::ScriptHelpers;
use Spreadsheet::WriteExcel::Simple;

my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);

################################################################################
my @recipients = qw(archana.ambily hmds.lth@nhs.net); 
my $filename = 'gallium_data.xls';
my $subject  = 'GALLIUM trial data';
################################################################################

# xl file headers:
my @cols = <DATA>; chomp(@cols); # warn Dumper @cols;

push @recipients, 'raj' if $JUST_TESTING; # will be sole recipient

# get tools from LIMS::Local::ScriptHelpers:
my $sql_lib = $tools->sql_lib();
my $config  = $tools->config(); 
my $dbix    = $tools->dbix();

# get cases referred to Kiel:
my $referrals = do {
    my $sql = $sql_lib->retr('gallium_trial_referred_to_kiel');
    $dbix->query($sql)->map;
};
my $requests = do {
    my $sql = $sql_lib->retr('gallium_trial_data_roche'); # warn $sql;
    $dbix->query($sql);
};
# get specimens - can't combine GROUP_CONCAT with MAX(CASE .. WHEN .. THEN ..END)
# used for results_summaries
my $specimens = do {
	my $sql = $sql_lib->retr('gallium_trial_request_specimen');
	$dbix->query($sql)->map_hashes('request_id');
};

my $trim = sub { LIMS::Local::Utils::trim(@_) };

my @rows;
while ( my $vars = $requests->hash ) { # warn Dumper $vars;
    my $request_id = $vars->{request_id};

	{ # specimen (from separate query):
		$vars->{'specimen_'.$_} = $specimens->{$request_id}{$_}
			for qw(code description);
	}
    # extract block ref + number of slides & blocks from external_ref:
    if ( my $exref = $vars->{external_reference} ) {
        # just capture 1st item of block_ref eg (125-16696) x20uss
        my ($block_ref) = split /\sx(:?\d+)[spu]/, $exref; # warn $block_ref; 

        my ($unstained_slides) = $exref =~ /x(\d+)uss/; # warn $unstained_slides 
        my ($stained_slides)   = $exref =~ /x(\d+)ss/; # warn $stained_slides
        my ($blocks)           = $exref =~ /x(\d+)p/; # warn $blocks;
        
        my $slides = do {
            no warnings 'uninitialized';
            $unstained_slides + $stained_slides;
        }; # warn Dumper [$block_ref, $slides, $blocks];
        
        $vars->{block_id} = &$trim($block_ref);
        $vars->{slides}   = $slides || 0;
        $vars->{blocks}   = $blocks || 0; 
    }
	# molecular result:
    if ( my $result = $vars->{molecular_summary} ) {
		if ( $result =~ /RNA volume\:(.*)ul/ ) { # warn $1
			$vars->{rna_volume} = &$trim($1);
		}
		if ( $result =~ /RNA concentration\:(.*)ng/ ) { # warn $1;
			$vars->{rna_concentration} = &$trim($1);
		}
		if ( $result =~ /OD260\/280\:\s?(\d*\.\d+)/ ) { # warn $1;
			$vars->{rna_purity} = $1;
		}
		if ( $result =~ /RNA sections\:(.*)micron/ ) { # warn $1
			$vars->{rna_sections} = &$trim($1);
		} # warn Dumper [@{$vars}{qw(rna_volume rna_concentration rna_purity rna_sections)}];
	}
    { # referred to Kiel?
        my $diagnosis  = $vars->{diagnosis} || ''; # avoid uninitialized warning
        
        if ( $referrals->{$request_id} || $diagnosis =~ /referred to kiel/i ) {
            $vars->{referred_to_kiel} = $vars->{reported}; # date
        }
        if ( my $return_date = $referrals->{$request_id} ) { # assume diagnosis change date
            $vars->{returned_from_kiel} = $return_date; 
        }
    }
    
    my @data = @{$vars}{@cols}; # warn Dumper $vars;
    push @rows, \@data;
}

exit if ! @rows;
	
{ # construct excel spreadsheet:
    my $xl = Spreadsheet::WriteExcel::Simple->new;
	$xl->write_bold_row(\@cols);
	$xl->write_row($_) for @rows;
    # save to file if just testing:
    $xl->save($Bin.'/'.$filename) if $JUST_TESTING;

    my %mail = (
        attachment  => $xl->data,
        filename    => $filename,
        subject     => $subject,
        config      => $config,
    ); # warn Dumper \%mail;
#    $tools->send_mail(\%mail, \@recipients);
}

__DATA__
hmds_ref
accession_number
site_id
patient_id
dob
gender
specimen_code
specimen_description
specimen_quality
registered
reported
slides
blocks
block_id
consent
immuno_status
immuno_summary
fish_summary
rna_volume
rna_concentration
rna_purity
rna_sections
referred_to_kiel
returned_from_kiel
diagnosis
comment