• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/perl

=begin -------------------------------------------------------------------------
records overdue for authorisation based on mean reporting time for sample:
generates 2 lists - outreach (> 21d overdue), and others (> sample_type mean + 2d)
=cut ---------------------------------------------------------------------------

use strict;
use warnings;

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

################################################################################
my %request_type = (
	outreach => {
		recipient => [ qw(andy.rawstron.secure raj.secure) ],
		subject   => q!Outreach records >21 days overdue!,
	},
	other => {
		recipient => [ qw(hmds.secure paul.evans.secure	raj.secure) ],
		subject   => q!HILIS records requiring attention!,
	},
);
my $duration = 6; # how many months to calculate mean time to authorisation
################################################################################

my @fields = qw(lab_number delta name location specimen);

use lib '/home/raj/perl5/lib/perl5';
use POSIX; # ceil
use Data::Dumper;
use Date::Calc qw(Delta_Days);

use FindBin qw($Bin); # warn $Bin;
use lib $Bin . '/../../../lib';
use LIMS::Local::Utils;
use LIMS::Local::ScriptHelpers;

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

my $sql_lib  = $tools->sql_lib();
my $config   = $tools->config();
my $today    = $tools->time_now();
my $dbix     = $tools->dbix();

# sample_type => mean duration to authorisation:
my $mean_duration_map = _get_mean_time_to_authorisation_by_sample_type();
	# warn Dumper $mean_duration_map; exit;

my %data;

my $query = $sql_lib->retr('overdue_for_authorisation');
my $result = $dbix->query($query);

RESULT:
while (my $ref = $result->hash) { # warn Dumper $ref; next;
	my $specimen = $ref->{specimen};
	my $screen   = $ref->{description};
	my $req_id   = $ref->{id};

    my $is_outreach = grep $screen eq $_, ('Outreach', 'Community monitoring');

	# don't want Outreach PB samples:
	next RESULT if $is_outreach && $specimen eq 'PB';

	# calculate age of request, and add to $ref as 'delta':
	my $delta = $ref->{delta} = Delta_Days(
		( split '-', $ref->{registered}   ), # from
		( split '-', $today->ymd ), # to
	); # warn Dumper [ $ref->{registered}, $delta ];

	# in case no similar samples over previous 180 days:
	$mean_duration_map->{$specimen}->{mean} ||= 7; # probably histology

	# skip if less than 3 days above mean time to auth for specimen type:
	next RESULT if $delta <= $mean_duration_map->{$specimen}->{mean} + 2;

	# 2 lists, 1 for Outreach, 1 for others:
	my $type = $is_outreach
		? 'outreach'
		: 'other';

	# skip if already have this request with another sample type with delta >= current
	my $previous_delta = $data{$type}{$req_id}[1] || 0; # warn $previous_delta;
	next RESULT if $delta <= $previous_delta; # skip unless this sample delta > previous || 0

	$data{$type}{$req_id} = [ @{ $ref }{@fields} ];
} # warn Dumper \%data;

my %mail = (
	config => $config,
);

my $msg_header = join ' :: ', @fields;

while ( my($type, $val) = each %request_type ) {
	# get request ids in numerical order (oldest 1st):
	my @request_ids = sort keys %{ $data{$type} };

	# join request data fields using | delimiter:
	my @msg_body = map {
			join ' | ', @{ $data{$type}{$_} }
		} @request_ids;

	my $message = @msg_body
        ? ( join "\n", @msg_body )
        : 'No requests outstanding';

	$mail{message} = $msg_header . "\n\n" . $message;
	$mail{subject} = $val->{subject}; # warn Dumper \%mail; next;

    $tools->send_mail(\%mail, $val->{recipient}); # hashref, arrayref
}

# create map of mean times to authorisation by sample type for last 180 days:
sub _get_mean_time_to_authorisation_by_sample_type {
	my $query = $sql_lib->retr('time_to_authorisation_by_specimen');
	my $result = $dbix->query($query, $duration);

	my %map;

	while (my $ref = $result->hash) { # warn Dumper $vars; next;
		my $specimen = $ref->{sample_code};

		my $from  = $ref->{registered};
		my $to    = $ref->{authorised};
		my $delta = LIMS::Local::Utils::delta_business_days($from, $to);

		$map{$specimen}{duration} += $delta; # increment total time for specimen type
		$map{$specimen}{total}++; # increment total count for specimen type
	}

	# calculate average duration for each sample type:
	while ( my($specimen, $data) = each %map ) {
		my $avg = ceil( $data->{duration} / $data->{total} );
		$map{$specimen}{mean} = $avg;
	}

	# make Outreach CMP samples 19 days (to make 21 after +2):
	$map{CMP}{mean} = 19;

	return \%map;
}