#!/usr/bin/env perl
=begin
daily Genomics notifications:
1) consent withdrawn
2) unsent sample reason given
=cut
my $JUST_TESTING = 0; # email to ra.jones only
use lib '/home/raj/perl5/lib/perl5';
use Modern::Perl;
use Data::Printer;
use SQL::Abstract::More;
use FindBin qw($Bin); # warn $Bin;
use lib "$Bin/../../../lib";
use LIMS::Model::Email; # can't use ScriptHelpers::send_mail due to distribution lists
use LIMS::Local::Utils; # get_unique_elements()
use LIMS::Local::ScriptHelpers;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);
my $config = $tools->config();
my $dbix = $tools->dbix();
my $script_name = $tools->script_filename; # warn $script_name; # contains timestamp also
my $yesterday = $tools->date_subtract(days => 1); # warn $yesterday;
# set db to genomics:
$dbix->dbh->do('use genomics'); # no need to set centre ENV param
# common contacts for both GMC centres & both arms:
my @common_contacts = qw(
emma.clossick@nhs.net
gill.wilson11@nhs.net
ra.jones@hmds.org.uk
); # denise.hancock3@nhs.net
# consent withdrawn (Full):
#===============================================================================
{
my @cols = (
'pc.unit_number|participant_id',
"CASE WHEN sc.name = 'Cancer' THEN 'cancer' ELSE 'rare_disease' END|arm",
'rs.organisation_code|org_code',
'u.email|user_email',
);
my @rels = (
# table|alias # FK-PK relationship
'requests|r' , 'r.patient_case_id = pc.id' ,
'patient_case|pc' , 'pc.referral_source_id = rs.id' ,
'referral_sources|rs' , 'tr.request_id = r.id' ,
'request_lab_test_results|tr' , 'tr.lab_test_id = lt.id' ,
'lab_tests|lt' , 'ris.request_id = r.id' ,
'request_initial_screen|ris' , 'ris.screen_id = s.id' ,
'screens|s' , 's.category_id = sc.id' ,
'screen_category|sc' , 'rh.request_id = r.id' ,
'request_lab_test_history|rh' , 'rh.user_id = u.id' ,
'users|u'
);
my %where = (
'rh.action' => { rlike => 'Consent withdrawal' },
'lt.test_name' => 'withdrawal_option',
'DATE(tr.time)' => $yesterday->ymd,
'tr.result' => 'Full',
'DATE(rh.time)' => \'= DATE(tr.time)', # literal (forces history date to
# be same as recording of result
# date)
);
my $subject = '100,000 Genomes Project: Participant Consent Withdrawn';
my ($sql, @bind) = format_query(\@cols, \@rels, \%where);
# $dbix->dump_query($sql, @bind); exit;
my $data = $dbix->query($sql, @bind)->objects; # p $data; exit;
for my $r (@$data) {
my $message = sprintf q!The following patient has withdrawn full consent !
. qq!to participate in the 100,000 Genomes Project on %s: %s. !
. q!Please now take any appropriate action (e.g. destroy samples).!,
$yesterday->dmy('/'), $r->participant_id; # p $message;
my ($org_code, $arm) = map $r->$_, qw(org_code arm); # p $org_code; p $arm;
my $centre = regional_centre($org_code)
or die "no regional centre for $org_code";
my $contacts = distribution_list($centre, $arm) # unlikely if above succeeds:
or die "cannot find distribution list contacts for $centre/$arm";
push @$contacts, ( @common_contacts, $r->user_email ); # p $contacts;
# get unique list (user_email may already exist in distribution list or
# common contacts):
my $recipients = LIMS::Local::Utils::get_unique_elements(\@$contacts); # p $recipients;
send_message($subject, $message, $recipients);
}
}
# unsent sample reason:
#===============================================================================
{
my @cols = (
'pc.unit_number|participant_id',
'rs.organisation_code|org_code',
'tr.result|reason',
'u.email|user_email',
);
my @rels = (
# table|alias # FK-PK relationship
'requests|r' , 'r.patient_case_id = pc.id' ,
'patient_case|pc' , 'pc.referral_source_id = rs.id' ,
'referral_sources|rs' , 'tr.request_id = r.id' ,
'request_lab_test_results|tr' , 'tr.lab_test_id = lt.id' ,
'lab_tests|lt' , 'rh.request_id = r.id' ,
'request_lab_test_history|rh' , 'rh.user_id = u.id' ,
'users|u'
);
my %where = (
'rh.action' => { rlike => 'Specimens - tumour' },
'lt.test_name' => 'unsent_sample_reason',
'DATE(tr.time)' => $yesterday->ymd,
'DATE(rh.time)' => \'= DATE(tr.time)', # literal (forces history date to
# be same as recording of result
# date)
);
my $subject = '100,000 Genomes Project: Sample Quality Issue';
my ($sql, @bind) = format_query(\@cols, \@rels, \%where);
# $dbix->dump_query($sql, @bind); exit;
my $data = $dbix->query($sql, @bind)->objects; # p $data; exit;
for my $r (@$data) {
my $message = sprintf q!The following Unsent Sample Reason has been set !
. q!for patient %s: %s. Please take the appropriate action !
. q!(e.g. inform the patient/destroy samples).!,
$r->participant_id, $r->reason; # p $message;
my $org_code = $r->org_code;
my $centre = regional_centre($org_code)
or die "no regional centre for $org_code";
# only applicable for cancer arm:
my $contacts = distribution_list($centre, 'cancer') # unlikely if above succeeds:
or die "cannot find distribution list contacts for $centre";
push @$contacts, ( @common_contacts, $r->user_email ); # p $contacts;
# get unique list (user_email may already exist in distribution list or
# common contacts):
my $recipients = LIMS::Local::Utils::get_unique_elements(\@$contacts); # p $recipients;
send_message($subject, $message, $recipients);
}
}
#===============================================================================
sub send_message { # can't use ScriptHelpers::send_mail due to distribustion lists
my $subject = shift; # say $subject; # str
my $message = shift; # say $message; # str
my $contacts = shift; # p $contacts; # aref
my %mail = (
config => $config,
subject => $subject,
message => $message,
); # p %mail;
for my $addr(@$contacts) {
if ($JUST_TESTING) { next unless $addr =~ /^ra\.jones/ } # sole contact
$mail{recipient} = $addr; # p %mail; next;
my $rtn = LIMS::Model::Email->send_message(\%mail); # Return::Value object
my $result = $rtn->string;
$rtn->type eq 'success'
? printf "%s reports %s to %s\n", $script_name, lc $result, $addr
: printf "%s reports %s\n", $script_name, $result;
}
}
sub format_query {
my ($cols, $rels, $where, $sort) = @_; # $sort optional
my @args = (
-columns => $cols,
-from => [ -join => @$rels ],
-where => $where,
); # p @args;
push @args, ( -order_by => $sort ) if $sort;
my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p @bind;
return ($sql, @bind);
}
sub regional_centre {
my $org_code = shift;
my %h = (
RAE01 => 'leeds',
RAE05 => 'leeds',
RCB55 => 'leeds',
RCD01 => 'leeds',
RCF22 => 'leeds',
RCUEF => 'sheffield',
RFFAA => 'sheffield',
RFRPA => 'sheffield',
RHQHH => 'sheffield',
RHQNG => 'sheffield',
RHQNN => 'sheffield',
RHQPH => 'sheffield', # Sheffield Teaching Hospitals (admin address!!)
RHQWP => 'sheffield',
RJL30 => 'sheffield', # DPW patients for Sheffield
RJL32 => 'leeds',
RP5BA => 'sheffield',
RP5DR => 'sheffield',
RR801 => 'leeds',
RR802 => 'leeds',
RR807 => 'leeds',
RR813 => 'leeds',
RR814 => 'leeds',
RR819 => 'leeds',
RR847 => 'leeds',
RR857 => 'leeds', # DPW patients for Leeds
RWA01 => 'leeds',
RWA16 => 'leeds',
RWA25 => 'leeds',
RWY01 => 'leeds',
RWY02 => 'leeds',
RXF03 => 'leeds',
RXF04 => 'leeds',
RXF05 => 'leeds',
RXF07 => 'leeds',
RXF10 => 'leeds',
);
return $h{$org_code};
}
sub distribution_list {
my ($centre, $arm) = @_;
my %h = (
rare_disease => {
leeds => [ (
'leedsth-tr.genlabadmin@nhs.net',
'ruth.charlton1@nhs.net',
# 'n.jaggs@nhs.net',
'kim.cass@nhs.net',
)],
sheffield => [ (
'Freyja.Docherty@sth.nhs.uk',
'Jackie.Cook@sch.nhs.uk',
'Janice.Nunn@sch.nhs.uk',
'Tamar.Kammin@sth.nhs.uk',
)],
},
cancer => {
leeds => [ (
'leedsth-tr.genlabadmin@nhs.net',
'helen.dickinson5@nhs.net',
'nick.west2@nhs.net',
'eldoverghese@nhs.net',
'phillipthompson@nhs.net',
'ruth.charlton1@nhs.net',
# 'n.jaggs@nhs.net',
'kim.cass@nhs.net',
)],
sheffield => [ (
'sht-tr.100KGP.Histo@nhs.net',
'cathryn.leng@nhs.net',
'Janice.Nunn@sch.nhs.uk',
'Tamar.Kammin@sth.nhs.uk',
)],
},
);
return $h{$arm}{$centre};
}
# alternative to Syntax::Feature::QwComments to allow comments inside qw()
sub qw_with_comments { $_[0] =~ s/#[^\n]*//rg =~ /\S+/g }
