#!/usr/bin/env perl
=begin -------------------------------------------------------------------------
1) function to email reports to:
a) location options:
* specific hospital department (eg Pinderfields/Haem)
* specific organisation department (eg Leeds/Haem)
* a hospital (all departments)
* an organisation (all departments)
b) request status options:
* new
* all
2) generates PDF of non-emailed & non-trial reports for manual printing
3) emails list of clinical trial reports
4) replaces crons/daily/email_reports.pl (LEEDS only) & crons/daily/print_run.pl
* ensure fastcgi started if run on test system (http://localhost for charts)
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: perl reports.pl --re-run >> ~/crons/cron.log 2>&1
--------------------------------------------------------------------------------
=cut
#===============================================================================
my @recipients = qw(hmds.secure raj); # for clinical trial list
#===============================================================================
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;
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;
# calculate dates --------------------------------------------------------------
# delta for how many days to subtract (default 1), adjust if $opt_d supplied:
my $delta = $opt_d || 1; # warn $delta; # days ago (1 for production)
# ref_date (normally yesterday):
my $ref_date = $tools->date_subtract( days => $delta ); # warn $ref_date;
# get last working day from ref_date:
my $lwd = LIMS::Local::Utils::last_working_date($ref_date); # warn $lwd;
#-------------------------------------------------------------------------------
# substitutes LIMS methods required by Role::RecordHandler:
my $lims = LIMS::Local::Reports->new({tools => $tools});
my $sqla = SQL::Abstract::More->new;
# 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
);
# common vars for email message:
my %mail = ( config => $config );
# load exemptions - never printed or emailed:
my $skip_reports = $tools->get_yaml_file('skip_email_reports') || {}; # hashref or 0
my $service_user = $tools->get_server_user_details();
# go:
#===============================================================================
# send reports by email; runs every day:
do_email_reports();
#===============================================================================
# generate PDF of any non-emailed, non-trial reports, for printing as PrintRun
# function; runs only on weekdays:
do_print_run_pdf() if $today->day_of_week() ~~ [1 .. 5]; # Mon - Fri
#===============================================================================
# generate list of trial cases for email; runs only on weekdays:
do_clinical_trials_list() if $today->day_of_week() ~~ [1 .. 5]; # Mon - Fri
#===============================================================================
#------------------------------------------------------------------------------
sub do_email_reports {
# get all requests authorised/modified yesterday as AoH [request_id, status,
# referral_source_id, department_code, parent_organisation_id, trial_name]
my $requests = get_requests($ref_date); # p $requests; # AoH
# get list of report email contact details as AoH:
my $contacts = get_contacts(); # p $contacts; # AoH
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, $dept_id, $location_id, $want_status)
= @{$contact}{@contact_cols};
my @request_ids = (); # list of request id's for this contact address
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 ( $dept_id ) { # 823, 824, etc
next REQ unless $req_department_code == $dept_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:
push @request_ids, $req_id;
}
# send email address & list of request_id's to function for creating pdf's:
generate_reports($email, \@request_ids);
}
}
#------------------------------------------------------------------------------
sub generate_reports { # creates pdf's for handing to dispatch_report()
my ($email, $request_ids) = @_; # contact address, [ request.ids ]
=begin #========================================================================
# for testing using known requests:
$email = 'hmds.lth@nhs.net';
$request_ids = [
# 307257 # NEQAS request - anonymised patient
# 308979 # PenENRICH trial - unknown referrer
# 309256 # Imatinib chart
# 308502 # Outreach
];
#===============================================================================
=cut
# 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
REQ:
for my $req_id (@$request_ids) {
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 do_print_run_pdf {
my $pdf_title = ( $lwd->ymd eq $ref_date->ymd )
? sprintf ( 'Print run [%s]', $ref_date->dmy('.') )
: sprintf ( 'Print run [%s - %s]', $lwd->dmy('.'), $ref_date->dmy('.') ); # p $pdf_title;
my $pdf_name = 'printrun_' . $today->ymd . '.pdf'; # p $pdf_name;
my $pdf_path = $JUST_TESTING ? '/tmp' : '/backups/print_run'; # p $pdf_path;
my $pdf = PDF::API2->new(-file => join '/', $pdf_path, $pdf_name);
$pdf->info( Title => $pdf_title );
my $add_new_pdf = sub {
my $data = shift;
my $pdf_string = $lims->format_print_run_report($data);
my $api = PDF::API2->open_scalar($pdf_string);
$pdf->importpage($api, $_) for (1 .. $api->pages);
};
my $ref = get_request_ids('non-trial'); # href of request_ids & ccs
for my $request_id ( @{ $ref->{request_ids} } ) { # warn $request_id; # next;
my $req = $lims->get_single_request_data($request_id); # L::C::Roles::RecordHandler
&$add_new_pdf($req);
}
for my $request_id ( @{ $ref->{ccs} } ) {
my $req = $lims->get_single_request_data($request_id);
my $o = $req->{data};
$o->referrer_department->referrer->name('cc'); # replace referrer name
&$add_new_pdf($req);
}
$pdf->save; # to $pdf_path
}
#------------------------------------------------------------------------------
sub do_clinical_trials_list {
my $ref = get_request_ids('clinical-trial'); # href of request_ids & ccs (don't need)
my @rows;
for my $request_id ( @{ $ref->{request_ids} } ) { # warn $request_id; # next;
my $req = $lims->get_single_request_data($request_id); # L::C::Roles::RecordHandler
my $data = $req->{data}; # RDBO
push @rows, sprintf '%s :: %s/%s :: %s',
$data->request_trial->trial->trial_name,
$data->request_number,
$data->year - 2000,
$data->patient_case->referral_source->display_name;
}
if (@rows) {
my $subject = sprintf 'Clinical trial reports [%s]',
( $lwd->ymd eq $ref_date->ymd )
? sprintf $ref_date->dmy('.')
: join ' to ', $lwd->dmy('.'), $ref_date->dmy('.'); # p $subject;
my %mail = (
config => $config,
subject => $subject,
message => join "\n", @rows,
); # p %mail;
$tools->send_mail(\%mail, \@recipients);
}
}
#------------------------------------------------------------------------------
sub get_contacts {
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 = qw(
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;
my $ref = $dbix->query($sql, @bind)->hashes;
return $ref;
}
#------------------------------------------------------------------------------
sub get_request_ids { # used by do_print_run_pdf() & do_clinical_trials_list()
my $type = shift;
my %h = (
start_date => $lwd,
end_date => $ref_date,
type => $type,
);
my ($request_ids, $ccs) = $lims->model('PrintRun')->get_print_run_request_ids(\%h);
return { request_ids => $request_ids, ccs => $ccs };
}
#------------------------------------------------------------------------------
sub get_requests {
my $start_date = shift;
my $end_date = shift; # optional, absence implies single day, presence = date range
my @cols = qw(
r.id
rr.status
rs.id|ref_src_id
hd.id|department_code
rs.parent_organisation_id|parent_id
ct.trial_name
);
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 $date_restriction = $end_date # implies date range
? { -between => [ $start_date->ymd, $end_date->ymd ] }
: $start_date->ymd;
my %where = (
'DATE(rr.updated_at)' => $date_restriction,
'so.description' => { -in => [ qw(authorised complete) ] },
);
# skip specified screened_as/presentations:
if ( my $presentation = $skip_reports->{presentation} ) { # aref
$where{'s.description'} = { -not_in => $presentation };
}
# skip specified 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;
my $ref = $dbix->query($sql, @bind)->hashes; # AoH
return $ref;
}
#------------------------------------------------------------------------------
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);
$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 });
}
}
