• Files
• Commits
• Log
• Graph
• Stats

#!/usr/bin/perl

=begin -------------------------------------------------------------------------
compiles list of number of cases registered vs frequency of error code A, by user
=cut ---------------------------------------------------------------------------

use strict;
use warnings;

my $JUST_TESTING = 0; # skips ftp, sets /tmp dir for data file, emails just raj

#######################################
my @recipients = qw(douglas raj);     #
my $duration   = 2; # months          #
#######################################
 
BEGIN {
    use FindBin qw($Bin); # warn $Bin;
    use lib (
        "$Bin/../../../lib",
        '/home/raj/perl5/lib/perl5',
    );
}

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

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

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 date 1 month ago:
my $ref_date = $tools->date_subtract(months => $duration);
my $subject = sprintf 'HILIS register log & error codes [%s.%s]',
    $ref_date->month_name, $ref_date->year; # warn $subject;
    
# get register log for previous month:
my $register_log = do {
    my $sql = $sql_lib->retr('register_log');
    $dbix->query($sql, $ref_date->year, $ref_date->month)->hashes;
}; # warn Dumper $register_log;

# get request_id's with error code A or deletion for previous month:
my $request_id = do {
    my $sql = $sql_lib->retr('error_code_A_requests');
    $dbix->query($sql, $ref_date->year, $ref_date->month)->flat;
}; # warn Dumper $request_id;

# get map of registration users for requests { user_id => frequency }
my $registration_user = do {
    my $sql = $sql_lib->retr('registration_user_map');
    $dbix->query($sql, @$request_id)->map;
}; # warn Dumper $registration_user;

=begin # ditched - not accurate anymore as error code attached to request not history
my $errCodeA_data = do {
    my $sql = $sql_lib->retr('error_code_A_data');
    $sql =~ s/%PARAMS%/join ',',@$request_id/e; # placeholders already in use
    $dbix->query($sql, $ref_date->year, $ref_date->month)->hashes;
}; # warn Dumper $errCodeA_data;
# get userid => username map for HMDS users:
my $user_map = do {
    my $sql = q!select u.id, u.username from users u join user_locations l
        on (u.user_location_id = l.id) where l.location_name = 'HMDS'!;
    $dbix->query($sql)->map;
};
=cut

# get breakdown of error code frequencies for month:
my $error_codes = do {
    my $sql = $sql_lib->retr('error_codes');
    $dbix->query($sql, $ref_date->year, $ref_date->month)->arrays;    
};

my $message = "Cases registered on HILIS and error rate by UserID for month:\n";

{ # write out register log data to rows:
    for my $user (@$register_log) {
        my $user_id = $user->{id};
        # get frequency of error code A's for this user:
        my $err_freq = $registration_user->{$user_id};        
        
        my @data = (
            uc $user->{username},
            $user->{f},     # total number records registered by user
            $err_freq || 0, # no. of error code A / deleted records
        );
        
        if ($err_freq) {
            my $err_percent = sprintf "%.2f%%", 100 * $err_freq / $user->{f};
            push @data, $err_percent;
        }
        no warnings 'uninitialized'; # $err_percent missing unless $err_freq
        $message .= sprintf "  %-15s %-4s %-3s %s\n", @data;
    } # warn $message;
}

$message .= "\nError code frequencies for month:\n";

{ # add error code frequencies:
    $message .= sprintf "  %s %-45s %s\n", @$_ for @$error_codes;
} # warn $message;

=begin # ditched - see above
{ # error details for each user:
    my %user_errors;
    
    for my $err (@$errCodeA_data) {
        my $user_id = $err->{user_id};
        my $request_id = $err->{request_id};
        my $action_user = $user_map->{$user_id}; # who made the change
        
        my $request = do {
            my $sql = q!select request_number, year, username from requests r
                join request_history rh on (rh.request_id = r.id) join users u
                on (rh.user_id = u.id) where action = 'registered' and
                rh.request_id = ?!;
            
            $dbix->query($sql, $request_id)->hash;
        };
        
        my $registration_user = uc $request->{username};
        my $data = sprintf 'H%s/%s %s %s',
            $request->{request_number},
            $request->{year} - 2000,
            uc $action_user,
            $err->{action};
        
        push @{ $user_errors{$registration_user} }, $data;
    } # warn Dumper \%user_errors;
    
    for my $user (sort keys %user_errors) {
        $message .= $user . "\n";
		foreach ( @{ $user_errors{$user} } ) {
			$message .= "  $_\n";
		}
		$message .= "\n\n";        
    } # warn $message;
}
=cut

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

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