• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/perl

=begin -------------------------------------------------------------------------
sends a list of requests (non-trial) where referrer or source unknown; runs daily
and exits unless date is 1st of month, or last working day of month, or Sunday
other than 2nd or last day of month (as list due anyway previous/next day)
* check date calcs in ~/scripts/code_unknown_run_dates.pl
* can force $JUST_TESTING using ARGV[0] = 1
=cut

#-------------------------------------------------------------------------------
my $JUST_TESTING = 0; # email to ra.jones only
my @recipients = qw(hmds.secure raj); # for non-secure info
#-------------------------------------------------------------------------------

use lib '/home/raj/perl5/lib/perl5';
use Data::Printer alias => 'p';
use DateTime::Format::MySQL;
use SQL::Abstract::More;
use Modern::Perl;
use Config::Auto;

use FindBin qw($Bin); # warn $Bin;
use lib "$Bin/../../../lib";
use LIMS::Local::ScriptHelpers;
use LIMS::Local::Utils;

use constant TODAY => LIMS::Local::Utils::today; # warn TODAY->day_name;
# use constant TODAY => DateTime->new( year => 2015, month => 12, day => 13 );

$JUST_TESTING = $ARGV[0] if $ARGV[0]; # only set if arg passed - cannot be undef value

{ # do we run today? - only Sundays & last working day on or before 1st of month
	# get datetime for 1st day of month ahead:
    my $first_of_next_month = get_first_of_next_month(); # p $first_of_next_month->dmy;

	# get date of last *working* day before 1st of next month:
	my $last_working_date # considers weekends & public hols
		= LIMS::Local::Utils::last_working_date($first_of_next_month);
		# say $last_working_date->dmy; say TODAY->dmy;
	my $delta = sub { LIMS::Local::Utils::delta_days(@_) };

	# run on 1st of month, last working day of month, and Sundays (except when
	# 2nd day or last day of month):
	exit 0 unless $JUST_TESTING
		or TODAY->day == 1 # run on 1st regardless of day
		or (! &$delta(TODAY->ymd, $last_working_date->ymd) ) # ie IS last working day
		or ( TODAY->day_name eq 'Sunday'
			&& TODAY->day > 2 # skip Sunday if 2nd or last day of month:
			&& TODAY->clone->add( days => 1 )->day > 1
		)
}
#===============================================================================
# to get here it's 1st day of month, last working day of month, or a Sunday (except
# day 2 or last day of month)
#===============================================================================

my $tools = LIMS::Local::ScriptHelpers->new();
$tools->test_only($JUST_TESTING);

my $cfg_file = "$Bin/../lib/settings.cfg";
my $settings = Config::Auto::parse($cfg_file); # warn Dumper $settings;

my $config = $tools->config();
my $dbix   = $tools->dbix();

# organisation codes NOT required in activity data:
my $skip_orgs = $settings->{skip_organisation_codes}; # warn Dumper $skip_orgs;

# my $query = $sql_lib->retr( 'national_code_unknown' ); # warn $query;
my ($sql, @bind) = get_query_params(); # p $sql; p @bind;
my $result = $dbix->query($sql, @bind);

my @rows;
while (my $vars = $result->hash) { # p $vars; next;
    my $lab_no = join '/', $vars->{request_number}, $vars->{year} - 2000;

    my $row = sprintf '%-9s %-12s %s',
        $lab_no,
        DateTime::Format::MySQL->parse_datetime($vars->{created_at})->dmy,
        $vars->{display_name};

    $row .= ' [WILL NOT BE BILLED]' if
        grep { $vars->{organisation_code} eq $_ } @$skip_orgs;
    push @rows, $row;
}

{ # send message:
	my $message_body = @rows
		? ( join "\n", @rows )
		: 'No unknown national codes so far this month';

	my $subject = do {
		my $month_year = ( TODAY->day == 1 )
			? TODAY->clone->subtract( months => 1 )->strftime('%B %Y')
			: TODAY->strftime('%B %Y');
		# prepend URGENT to message title if 1st of month, or not Sunday:
		TODAY->day_name ne 'Sunday' || TODAY->day == 1
			? 'PRIORITY: unknown national codes for ' . $month_year
			: 'Unknown national codes for ' . $month_year;
	}; # p $subject;

	my %mail = (
		config  => $config,
		subject => $subject,
		message => $message_body,
	); # warn Dumper \%mail; # next;

	$tools->send_mail(\%mail, \@recipients);
}

#===============================================================================
sub get_query_params {
    my @col_names = qw(
		r.request_number
		r.year
		r.created_at
		rs.display_name
		rs.organisation_code
    );

    my @tbl_rels = (
        # table|alias                  	# FK-PK relationship
        'requests|r' 				,	'r.referrer_department_id = rd.id' ,
		'referrer_department|rd'	,	'rd.referrer_id = ref.id'		   ,
		'referrers|ref'				,	'r.patient_case_id = pc.id'        ,
		'patient_case|pc'			,	'pc.referral_source_id = rs.id'    ,
		'referral_sources|rs'		,	'=>rt.request_id = r.id'           , # left join
		'request_trial|rt'
    );

	# date restriction for where clause (1st of month):
	my $start_date = ( TODAY->day == 1 ) # if today = 1st of month
		? TODAY->clone->subtract( months => 1 ) # 1st of previous month
		: TODAY->clone->subtract( days => TODAY->day - 1 ); # 1st of this month

	my %where = (
		-or => {
			'rs.organisation_code' => { -in => [ qw/X99999 V81999/ ] },
			'ref.national_code'    => { like => '%' . 999998 },
		},
		'r.created_at'	=> { '>=' => $start_date->ymd },
		'rt.request_id' => undef, # not in clinical trial
    );

	my @sort = qw(r.year r.request_number);

	my ($sql, @bind) = SQL::Abstract::More->new->select(
		-columns  => \@col_names,
		-from     => [ -join => @tbl_rels ],
		-where    => \%where,
		-order_by => \@sort,
	); # p $sql; p @bind;
    return ($sql, @bind);
}

sub get_first_of_next_month {
    my $dt = TODAY->clone; # add days until ->day equals 1:
    do { $dt->add(days => 1) } while $dt->day > 1;
    return $dt;
}