#!/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; }