#!/usr/bin/env perl
=begin -------------------------------------------------------------------------
function to email reports to:
1) location options:
* specific hospital department (eg Pinderfields/Haem)
* specific organisation department (eg Leeds/Haem)
* a hospital (all departments)
* an organisation (all departments)
2) request status options:
* new
* all
only using basic DBIx::Simple methods (hashes) so son't need Local::DB
how to deal with reports where a departmental contact exists, and a
hospital/organisation contact (do they also get the dept report?), and also a
CWT contact (usually needs all 'new' reports)
* can manually run script using --re-run flag to dispatch any unsent reports on
same day: CENTRE=xxxx perl email_reports.pl --re-run >> ~/crons/cron.log 2>&1
--------------------------------------------------------------------------------
=cut
BEGIN {
use lib '/home/raj/perl5/lib/perl5'; # *must* come before FindBin($Bin)
use FindBin qw($Bin); # warn $Bin; exit;
use lib ("$Bin/../../../lib", '/home/raj/perl-lib');
# override default db test:
$ENV{ROSEDB_DEVINIT} = "$Bin/../../../config/rosedb_devinit_prod.pl";
}
my($opt_d,$opt_t,$rerun);
use Getopt::Long;
GetOptions (
"days|d=s" => \$opt_d, # string
"testing|t" => \$opt_t, # flag
"re-run" => \$rerun, # flag
); # warn $opt_d; warn $opt_t; warn $rerun; exit;
# emails only 'service_email' addr in config, dumps history data to lims_test db:
my $JUST_TESTING = $opt_t || 0;
my $delta = $opt_d || 1; # warn $delta; # days ago (1 for production)
use IO::All;
use File::Slurp;
use Config::Auto;
use Modern::Perl;
use Data::Printer;
use SQL::Abstract::More;
use DateTime::Format::MySQL;
use LIMS::Local::Reports;
use LIMS::Local::ScriptHelpers;
my $cfg_file = "$Bin/../lib/settings.cfg";
my $settings = Config::Auto::parse($cfg_file); # p $settings;
# 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;
my $sqla = SQL::Abstract::More->new;
my $date = $tools->date_subtract( days => $delta )->ymd; # warn $date;
# substitutes LIMS methods required by Role::RecordHandler:
my $lims = LIMS::Local::Reports->new({tools => $tools});
# localhost http address - for charts; is_print_request for tt formatting:
$lims->tt_params(
app_url => 'http://localhost/hilis4',
is_print_request => 1, # otherwise it loads guest view template by default
);
# load exemptions:
my $skip_reports = $tools->get_yaml_file('skip_email_reports') || {}; # hashref or 0
#===============================================================================
# get all requests authorised/modified yesterday as AoH:
# [request_id, status, referral_source_id, parent_organisation_id & department_id]
my @requests = do {
my @cols = qw( r.id rr.status rs.id|referral_source_id|ref_src_id
hd.id|department_code rs.parent_organisation_id|parent_id );
my @rels = (
'requests|r' => 'ris.request_id=r.id' ,
'request_initial_screen|ris' => 'ris.screen_id=s.id' ,
'screens|s' => 'r.patient_case_id=pc.id' ,
'patient_case|pc' => 'pc.referral_source_id=rs.id' ,
'referral_sources|rs' => 'r.referrer_department_id=rd.id' ,
'referrer_department|rd' => 'rd.hospital_department_code=hd.id' ,
'hospital_departments|hd' => 'rr.request_id=r.id' ,
'request_report_view|rr' => 'r.status_option_id=so.id' ,
'status_options|so' => '=>rt.request_id=r.id' ,
'request_trial|rt' => '=>rt.trial_id=ct.id' ,
'clinical_trials|ct'
);
my @status = ( 'complete' );
push @status, $tools->does_authorisation ? 'authorised' : 'reported';
my %where = (
'DATE(rr.updated_at)' => $date,
'so.description' => { -in => \@status },
);
# skip screened_as/presentation:
if ( my $presentation = $skip_reports->{presentation} ) { # aref
$where{'s.description'} = { -not_in => $presentation };
}
# skip clinical trials:
if ( my $trials = $skip_reports->{clinical_trial} ) { # aref
$where{'ct.trial_name'} = # needs an undef or lose all non-ct entries
[ -or => { -not_in => $trials }, undef ];
}
my @args = (
-columns => \@cols,
-from => [ -join => @rels ],
-where => \%where,
);
my ($sql, @bind) = $sqla->select(@args); # p $sql; # p \@bind;
# $dbix->dump_query($sql, @bind); exit;
$dbix->query($sql, @bind)->hashes; # AoH
}; # p \@requests;
#===============================================================================
# get list of report email contact details as AoH:
my @contacts = do {
my @cols = qw(
ec.display_name
ec.referral_source_id|source_id
rs.parent_organisation_id|parent_id
ec.scope
ec.department_id
ec.contact_address
ec.status
);
my @rels = (
'email_contacts|ec' => 'ec.referral_source_id=rs.id',
'referral_sources|rs'
);
my @args = (
-columns => \@cols,
-from => [ -join => @rels ],
-where => { 'ec.type' => 'report', 'ec.is_active' => 'yes' },
); # p @args;
my ($sql, @bind) = $sqla->select(@args); # p $sql; # p \@bind;
# $dbix->dump_query($sql, @bind); exit;
$dbix->query($sql, @bind)->hashes; # AoH
}; # p \@contacts;
my %reports; # hash of contact addresses => [ request.ids ]
my @request_cols = qw( id status ref_src_id department_code parent_id );
my @contact_cols
= qw( scope contact_address parent_id department_id source_id status );
# for each contact address, assign any matching request ids from $requests
# involves looping through each request for each contact (but very fast):
for my $contact (@contacts) {
my ($scope, $email, $parent_id, $department_id, $location_id, $want_status)
= @{$contact}{@contact_cols};
REQ:
for my $req (@requests) {
my ($req_id, $req_status, $req_refsrc_id, $req_department_code,
$req_parent_id) = @{$req}{@request_cols};
# first deal with request status (requires new diagnoses or not):
if ( $want_status eq 'new' ) {
next REQ unless $req_status eq 'new';
}
# next deal with contacts for specific departments:
if ( $department_id ) { # 823, 824, etc
next REQ unless $req_department_code == $department_id;
}
# contact 'scope' is either hospital or organisation:
if ( $scope eq 'hospital' ) {
next REQ unless $req_refsrc_id == $location_id;
}
else { # scope = 'organisation'
next REQ unless $req_parent_id == $parent_id;
}
if ($rerun) { # manual command using --re-run flag
# has report already been sent today?
my $dispatched = $dbix->select('request_dispatch_log', 1,
{
'DATE(time)' => $today->ymd,
request_id => $req_id,
recipient => $email,
})->list;
next REQ if $dispatched;
}
# now have required combination of hospital/organisation + optional dept:
# my $label = join '::', $email, $contact->{display_name}; # for debug use only
# push @{ $reports{$label} }, $req_id;
push @{ $reports{$email} }, $req_id;
}
} # p \%reports; exit;
=begin #========================================================================
# for testing using known requests:
%reports = ( 'hmds.lth@nhs.net' => [
# 307257 # NEQAS request - anonymised patient
# 308979 # PenENRICH trial - unknown referrer
# 309256 # Imatinib chart
308502 # Outreach
]);
#===============================================================================
=cut
# common vars for email message:
my %mail = ( config => $config );
# now get pdf's as in-memory object for each contact - may involve compiling
# some reports more than once but alternative is save to disk and clean up after
while ( my ($email, $ref) = each %reports ) { # aref of request_id's
REQ:
for my $req_id (@$ref) {
my $pdf = $lims->format_report($req_id); # L::C::Roles::RecordHandler
# $pdf > io("$Bin/$req_id.pdf"); warn 'for test only'; next REQ;
$mail{attachment} = $pdf;
# retrieve request data object stashed in Recordhandler::_format_report():
my $data = $lims->stash->{request_data};
{ # add subject line:
my $referrer_department = $data->referrer_department;
my $subject = sprintf 'HMDS Report for %s / %s',
$referrer_department->hospital_department->display_name, # speciality
$referrer_department->referrer->name; # referrer
# doesn't work properly if unknown clinician - uses referrer_department.id 31116:
if ( $subject =~ /Unknown clinician/ ) { # "Unknown/Other / Unknown clinician"
$subject = 'HMDS Report [referrer unknown]'
}
$mail{subject} = $subject;
}
{ # add filename:
my $filename = sprintf '%02d_%05d.pdf',
$data->year - 2000,
$data->request_number;
$mail{filename} = $filename;
} # p \%mail;
# send report to recipient:
$mail{recipient} = $email; # p \%mail;
dispatch_report({ request_id => $req_id, message => \%mail });
}
}
sub dispatch_report {
my $args = shift;
my $request_id = $args->{request_id};
my $message = $args->{message};
# substitute recipient address here if $JUST_TESTING (L::L::Mail doesn't any more):
if ($JUST_TESTING) {
my $safe_address = $config->{service_email};
die "unsafe recipient address $safe_address"
unless $safe_address =~ /\@nhs.net\Z/;
$message->{recipient} = $safe_address;
}
my $result = LIMS::Model::Email->send_message($message); # Return::Value
my $centre = $ENV{CENTRE} || 'leeds';
if ( $result->type eq 'success' ) {
my $recipient = $message->{recipient};
my $filename = $message->{filename};
my $str = $result->string; # rs = 'message sent'; can't substitute direct on rs, so:
$str =~ s/message/$filename [$centre]/i; # str = eg '12_01234.pdf [uclh] sent'
printf "%s %s to %s\n", $tools->script_filename, $str, $recipient;
my %data = (
request_id => $request_id,
recipient => $recipient,
);
# log details in request_dispatch_log & request_history tables:
unless ($JUST_TESTING) {
my $rtn = $lims->model('Request')->update_request_dispatch_log(\%data);
warn "Error in $0: $rtn" if $rtn;
}
else { # manual input into lims_test db:
$dbix->insert('lims_test.request_dispatch_log', \%data);
my $service_user = $tools->get_server_user_details();
$data{user_id} = $service_user->{id};
$data{action} = 'dispatched report to ' . $recipient;
delete $data{recipient};
$dbix->insert('lims_test.request_history', \%data);
}
}
else {
warn $result->string;
$tools->mail_admin({ script => $0, msg => $result->string });
}
}
