• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/env perl

# alerts Outreach admins of low blood counts for Outreach patients
# requires heamatology result to be available at time of screening
# runs every 3 hrs

#===============================================================================
my @recipients = qw(rawstron martin raj detute);
my $low_neutr_threshold = 10; # equivalent to 1.0
my $low_plt_threshold   = 50;
my $low_hb_threshold    = 100;
#===============================================================================

use strict;
use warnings;

use lib '/home/raj/perl5/lib/perl5';

use FindBin qw($Bin); # warn $Bin; exit;
use Getopt::Std;
use Data::Printer;
use SQL::Abstract::More;

use lib ("$Bin/../../../lib", '/home/raj/perl-lib');
use LIMS::Local::ScriptHelpers;

getopts('d:qt:'); # duration (hours), query output, testing
our($opt_d,$opt_t,$opt_q); # warn $opt_d; exit;

# emails only raj:
my $JUST_TESTING = $opt_t || 0;
my $duration     = $opt_d || 3; # hours
my $query_output = $opt_q;

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

my $config = $tools->config();
my $dbix   = $tools->dbix;

my ($sql, @bind) = _get_query(); # p $sql; p @bind;
my @results = $dbix->query($sql, @bind)->arrays; # p @results; exit;
exit unless @results;

for my $aref (@results) {
    my ($request_number, $year, $hb, $plts, $neutr) = @$aref;
    my $labno = join '/', $request_number, $year - 2000;
    my $message = sprintf '%s: Hb = %s, Plts = %s, Neutr = %s',
        $labno,
        int $hb,
        int $plts,
        $neutr ne '*000' ? ( sprintf '%.1f', $neutr / 10 ) : 'FAIL'; # p $message;

    my %mail = (
        subject => 'Outreach patient low blood count alert',
        message => $message,
        config  => $config,
    ); # p %mail;
    $tools->send_mail(\%mail, \@recipients);
}

sub _get_query {  # request_haematology table vars don't work in placeholders - WTF??
#=begin
    return qq!
    SELECT r.request_number, r.`year`, rh2.hb, rh2.plt, rh2.neutr
    FROM requests r
        JOIN request_initial_screen ris ON ris.request_id = r.id
        JOIN screens s ON ris.screen_id = s.id
        JOIN request_history rh1 ON rh1.request_id = r.id
        JOIN request_haematology rh2 ON rh2.lab_number
            = CONCAT( r.`year` - 2000, '_', LPAD(r.request_number, 5, 0) )
    WHERE rh1.`action` = 'screened'
        AND rh1.`time` >= DATE_SUB(NOW(), INTERVAL ? HOUR)
        AND s.description RLIKE 'Outreach' /* to accommodate Outreach CML, etc */
        AND ( rh2.hb < $low_hb_threshold OR rh2.plt < $low_plt_threshold OR
            ( rh2.neutr <> '*000' AND rh2.neutr < $low_neutr_threshold )
        )!, $duration;
#=cut
    # this does not work - rh2 table variables are ignored in placeholders,
    # either when generated by SQLA or supplied direct as a query statement:
    my $rh_tbl_join = q!CONCAT(r.year - 2000, '_', LPAD(r.request_number,5,0))!;
    my $ref_time    = $tools->time_now->subtract( hours => $duration );

    my @cols = ('r.request_number', 'r.year', 'rh2.hb', 'rh2.plt', 'rh2.neutr');
    my @rels = (                       'requests|r'                     ,
        'ris.request_id=r.id'       => 'request_initial_screen|ris'     ,
        'ris.screen_id = s.id'      => 'screens|s'                      ,
        'rh1.request_id=r.id'       => 'request_history|rh1'            ,
        { # need to use operator/condition for complex CONCAT:
            operator  => '<=>', # options are <=>, <=, =>, ==
            condition => {
                'rh2.lab_number' => { # ident prevents addition to @bind:
                    '=' => { -ident => $rh_tbl_join },
                },
            },
        }                           => 'request_haematology|rh2'         ,
    );
    my %where = (
        'rh1.action' => 'screened',
        'rh1.time'   => { '>=' => $ref_time },
        's.description' => { -rlike => 'Outreach' }, # to accommodate Outreach CML, etc
        -or => {
            'rh2.hb'    => { '<' => $low_hb_threshold  },
            'rh2.plt'   => { '<' => $low_plt_threshold },
            -and => [
                'rh2.neutr' => { '!=' => '*000' },
                'rh2.neutr' => { '<' => $low_neutr_threshold },
            ],
        },
    );
    my @args = (
        -columns  => \@cols,
		-from     => [ -join => @rels ],
		-where    => \%where,
    ); # p @args;
    my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p \@bind;
         $dbix->dump_query($sql, @bind) if $query_output; # exit;
    return ($sql, @bind);
}