#!/usr/bin/perl
=begin -------------------------------------------------------------------------
sends summary of requests received and reports disptched to MDT contact for centre
using YEARWEEK(<date>, 1) to make Monday = 1st dow, so week = Monday - Sunday
# see example script after __END__
--------------------------------------------------------------------------------
=cut
use Getopt::Std;
getopts('td:'); # days
our($opt_d,$opt_t); # warn $opt_d; exit;
use strict;
use warnings;
my $JUST_TESTING = $opt_t || 0; # dumps contents to file and sets recipient to raj
#===============================================================================
my @skip_locations = qw( ); # don't want to receive lists - display_name MUST match
my $duration = $opt_d || 7; # over past number of days (but using YEARWEEK in query)
#===============================================================================
use lib '/home/raj/perl5/lib/perl5';
use Data::Printer;
use SQL::Abstract::More;
use DateTime::Format::MySQL;
use FindBin qw($Bin); # warn $Bin;
use lib $Bin . '/../../../lib';
use LIMS::Local::ScriptHelpers;
use vars qw($fh);
my $sqla = SQL::Abstract::More->new;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);
# get tools from LIMS::Local::ScriptHelpers:
my $sql_lib = $tools->sql_lib();
my $config = $tools->config();
my $dbix = $tools->dbix();
#-------------------------------------------------------------------------------
# get all locations with mdt contacts:
my $locations = get_mdt_centres(); # p $locations; exit;
# get email_contacts for above list (excluding any @skip_locations):
my $email_contacts = get_active_email_contacts(); # warn Dumper $email_contacts; # AoH
# get date from:
my $ref_date = $tools->date_subtract( days => $duration );
#-------------------------------------------------------------------------------
if ($JUST_TESTING) { # only open $fh if needed:
open $fh, '>', "$Bin/requests_and_reports.html" or die $!;
}
# go:
{
ENTRY: # loop through each contact and get request_id's as required:
for my $recipient (@$email_contacts) { # warn Dumper $recipient; next;
my $location = $recipient->{display_name}; # next unless $location =~ /Goole/;
my $src_id = $recipient->{referral_source_id};
my $scope = $recipient->{scope}; # dept, hospital or organisation
# using GROUP_CONCAT on contact_address to avoid repeat data retrieval:
my @contacts = split ',', $recipient->{contacts}; # maybe > 1
my @source_ids = ($src_id); # need at least local ref_src_id
# info can be for hospital or organisation:
if ( $scope eq 'organisation' ) {
# find all ref_src's under parent_organisation of ref_src_id:
my $parent_organisation_id = $dbix->select('referral_sources',
'parent_organisation_id', { id => $src_id } )->list;
my $ref_src_ids = $dbix->select('referral_sources', 'id',
{ parent_organisation_id => $parent_organisation_id } )->flat;
# add other ref_src_ids for this parent:
push @source_ids, grep $_ != $src_id, @$ref_src_ids;
} # p @source_ids;
my %data = (
location => $location,
contact => \@contacts, #arrayref
);
{ # requests received:
my $request_ids = do {
my ($sql, @bind) = _requests_received(@source_ids);
$dbix->query($sql, @bind)->flat;
};
if (@$request_ids) {
my $results = do {
my ($sql, @bind) = _requests_and_reports($request_ids);
$dbix->query($sql, @bind)->hashes;
};
to_datetime($results); # convert mysql dates
$data{requests}{registered} = $results;
}
}
{ # reports authorised:
my $request_ids = do {
my ($sql, @bind) = _requests_authorised(@source_ids);
$dbix->query($sql, @bind)->flat;
};
if (@$request_ids) {
my $results = do {
my ($sql, @bind) = _requests_and_reports($request_ids);
$dbix->query($sql, @bind)->hashes;
};
to_datetime($results); # convert mysql dates
$data{requests}{authorised} = $results;
}
}
do_requests(\%data);
}
}
sub do_requests {
my $args = shift; # p $args; # hashref
my $requests = $args->{requests}; # hashref
my $location = $args->{location};
my $contact = $JUST_TESTING
? ['ra.jones@nhs.net'] # expects arrayref
: $args->{contact}; # p $contact;
my $tt_file = 'cron/requests_and_reports.tt';
my $message_body = $tools->process_template($tt_file, $requests);
my $subject = sprintf '%s HMDS requests since %s',
$location, $ref_date->dmy;
my %mail = (
config => $config,
content => 'html',
message => $message_body,
subject => $subject,
); # warn Dumper \%mail; exit;
if ($fh) {
print $fh $message_body; # return;
}
$tools->send_mail(\%mail, $contact);
}
sub get_mdt_centres {
my $res = $dbix->select('email_contacts', 'distinct(display_name)',
{ type => 'mdt', is_active => 'yes' })->flat;
return $res;
}
sub get_active_email_contacts { # get array of hashrefs of location/scope => email:
my $results = do {
my ($sql, @bind) = _email_contacts('mdt');
$dbix->query($sql, @bind)->hashes;
}; # p $results;
my @required = (); # only return data for required locations:
for my $contact (@$results) {
next unless grep $contact->{display_name} eq $_, @$locations;
next if grep $contact->{display_name} eq $_, @skip_locations;
push @required, $contact;
} # p @required;
return \@required;
}
sub to_datetime {
my $data = shift; # AoH
my $dfm = DateTime::Format::MySQL->new();
for (@$data) {
my $registered = $dfm->parse_date($_->{registered}); # always exists
$_->{registered} = $registered;
if ( my $authorised = $_->{authorised} ) {
$_->{authorised} = $dfm->parse_date($authorised);
}
if ( my $dob = $_->{dob} ) {
$_->{dob} = $dfm->parse_date($dob);
}
}
}
# SQLA =========================================================================
sub _requests_received {
my $src_ids = shift;
my @cols = ( 'r.id' );
my @rels = qw(
requests|r r.patient_case_id=pc.id
patient_case|pc pc.patient_id=p.id
patients|p pc.referral_source_id=rs.id
referral_sources|rs
);
my $ymd = $ref_date->ymd;
my %where = (
'YEARWEEK(r.created_at)' => { -ident => qq!YEARWEEK('$ymd', 1)! }, # mode 1 = Monday
'rs.id' => { -in => $src_ids },
);
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;
return ($sql, @bind);
}
sub _requests_authorised {
my $src_ids = shift;
my @cols = ( 'r.id' );
my @rels = qw(
requests|r r.patient_case_id=pc.id
patient_case|pc pc.patient_id=p.id
patients|p pc.referral_source_id=rs.id
referral_sources|rs rh.request_id=r.id
request_history|rh
);
my $ymd = $ref_date->ymd;
my %where = (
'YEARWEEK(rh.time)' => { -ident => qq!YEARWEEK('$ymd', 1)! }, # # mode 1 = Monday
'rh.action' => 'authorised',
'rs.id' => { -in => $src_ids },
);
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;
return ($sql, @bind);
}
sub _requests_and_reports {
my $req_ids = shift;
my @cols = (
'p.last_name',
'p.first_name',
'p.dob',
'p.nhs_number',
'pc.unit_number',
'rs.display_name|location',
'ref.name|referrer',
'hd.display_name|department',
'DATE(r.created_at)|registered',
'DATE(rh.time)|authorised',
);
my @rels = (
'requests|r' => q{r.patient_case_id=pc.id},
'patient_case|pc' => q{pc.patient_id=p.id},
'patients|p' => q{r.referrer_department_id=rd.id},
'referrer_department|rd' => q{rd.referrer_id=ref.id},
'referrers|ref' => q{rd.hospital_department_code=hd.id},
'hospital_departments|hd' => q{pc.referral_source_id=rs.id},
'referral_sources|rs' =>
q{=>rh.request_id=r.id,rh.action='authorised'},
'request_history|rh'
);
my %where = ( 'r.id' => { -in => $req_ids } );
my @args = (
-columns => \@cols,
-from => [ -join => @rels ],
-where => \%where,
-order_by => [ 'p.last_name', 'p.first_name' ],
);
my ($sql, @bind) = $sqla->select(@args); # p $sql; # p \@bind;
# $dbix->dump_query($sql, @bind); exit;
return ($sql, @bind);
}
sub _email_contacts {
my $type = shift;
my @cols = qw( id display_name scope referral_source_id
GROUP_CONCAT(contact_address)|contacts );
my @rels = qw( email_contacts );
my %where = ( type => $type, is_active => 'yes' );
my @args = (
-columns => \@cols,
-from => [ -join => @rels ],
-where => \%where,
-group_by => [ qw/display_name scope referral_source_id/ ],
);
my ($sql, @bind) = $sqla->select(@args); # p $sql; # p \@bind;
# $dbix->dump_query($sql, @bind); exit;
return ($sql, @bind);
}
__END__
use DateTime;
use LIMS::Local::ScriptHelpers;
my $tools = LIMS::Local::ScriptHelpers->new();
my $dbix = $tools->dbix();
my $date = DateTime->new( year => 2011, month => 1, day => 1 );
for (0 .. 365) {
my $inc = $date->clone->add(days => $_);
$dbix->query( "select yearweek(?, 1)", $inc->ymd )->into( my $yr_week );
my $day = join ' ', $inc->day_abbr, $inc->ymd;
warn "$day: $yr_week";
}
