• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/perl

=begin -------------------------------------------------------------------------
emails list of errors (action contains 'modified' or 'recorded error code' for
# previous week
********** MISSING PATIENT HISTORY EDITS ***************************
=cut ---------------------------------------------------------------------------

use strict;
use warnings;

my $JUST_TESTING = 0; # email to ra.jones only

############ recipients from contacts.lib ######################################
my @recipients = qw( lynda.blythe.secure raj.secure );
my $duration = 7; # over past number of days
################################################################################

BEGIN {
    use FindBin qw($Bin); # warn $Bin;
    use lib (
        "$Bin/../../../lib",
        '/home/raj/perl5/lib/perl5',
    );
}

use DateTime;
use Data::Dumper;
use DateTime::Format::MySQL;
use LIMS::Local::ScriptHelpers;

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

#-------------------------------------------------------------------------------
my $date    = $tools->time_now->dmy;
my $subject = "HILIS errors week ending $date";
#-------------------------------------------------------------------------------

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

my $query = $sql_lib->retr('error_log');
    
my @terms = qw(LName FName PatNo NHSNo DoB Specimen Source Clinician BlockRef
    Private Urgent Store Treatment Research Monitor );
my $regexp = join '|', @terms;

$query =~ s/%REGEXP%/$regexp/; # warn $query; exit;

my $result = $dbix->query($query, $duration);

my (@rows, @seen);

while (my $ref = $result->hash) { # warn Dumper $vars; next;
    { # get some vals:
        _get_registration_user($ref);
        _get_error_action($ref);
        _get_labno($ref);
    }
    my @fields = qw(time modifier action error_action labno register_user);
    push @rows, [ @{$ref}{@fields} ];

    push @seen, $ref->{err_history_id}; # don't want this entry again
} # warn Dumper \@err_code_ids;

{ # now get error codes without modification entries in history log:
    my $sql = $sql_lib->retr('error_log_non_modification');
    my $result = $dbix->query($sql, $duration);
    while ( my $ref = $result->hash ) {
        # skip error code entries already collected:
        next if grep $ref->{request_history_id} == $_, @seen;
        
        {  # get some vals:
            _get_registration_user($ref);
            _get_labno($ref);
        }        
        my @fields = qw(time modifier action labno register_user);
        push @rows, [ @{$ref}{@fields} ];
    }
}

{ # patient edits:
    my $sql = $sql_lib->retr('error_log_patient_edits');
    # see M::History::_parse_patient_history_for_changes for details    
}

my $msg = join "\n", map { join ' | ', @$_ } sort by_time @rows;
# print $msg; exit;

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

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

sub _get_registration_user {
    my $ref = shift;
    
    my $sql = q!select UCASE(username) from request_history rh join users u on
        rh.user_id = u.id where rh.request_id = ? and rh.action = 'registered'!;
    $dbix->query($sql, $ref->{request_id})->into($ref->{register_user});    
}

sub _get_error_action {
    my $ref = shift;
    
    my ($error_action) = $ref->{err_code_action} =~ /recorded (error code .*)/;
    $ref->{error_action} = $error_action;
}

sub _get_labno {
    my $ref = shift;
    
    $ref->{labno} = sprintf 'H%s/%s',
        $ref->{request_number}, $ref->{year} - 2000;
}

sub by_time {
    my $dtA = DateTime::Format::MySQL->parse_datetime($a->[0]);
    my $dtB = DateTime::Format::MySQL->parse_datetime($b->[0]);
    
    return DateTime->compare( $dtA, $dtB );
}