#!/usr/bin/perl

=begin -------------------------------------------------------------------------
uploads activity data to ftp server - can be set to test mode using $JUST_TESTING
=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   = 1; # months ago
# organisation codes NOT required in activity data (also need to set in national_code_unknown.pl):
my @skip_orgs  = qw(X99999 V81999 RWD00); # unknown practice, hospital, PathLinks
#-------------------------------------------------------------------------------
 
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 IO::Compress::Gzip qw(gzip $GzipError);

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();

my $date = $tools->date_subtract(months => $duration);
my $month = $date->month_name;

my $filename = $tools->script_filename;

my $query = $sql_lib->retr('activity_data');

my $delimiter = '|';

my (@rows, %request_numbers);

my %log = (
	unsourced => [], # initialise to avoid possible undef value error later
	failed    => [],
);

my $result = $dbix->query($query, $duration, $duration); # needs duration twice
my $is_private = q!select 1 from request_option ro join additional_options ao on
    ro.option_id = ao.id where ro.request_id = ? and ao.option_name = 'private'!;

ROW:
while (my $vars = $result->hash) { # warn Dumper $vars; next;
    my $id = $vars->{id}; 
    my $lab_no = join '/', $vars->{request_number}, ($vars->{year} - 2000);    
    
    # log & skip unknown referral_source:
    if ( grep $vars->{organisation_code} eq $_, @skip_orgs ) { 
        push @{ $log{unsourced} },
            { labno => $lab_no, trial => $vars->{trial_name} };
        next ROW; 
    }  
    
    # log failures (unknown clinicians for non-study requests):
    if ( $vars->{referrer_code} =~ /9999998\Z/ && $vars->{category} ne 'ST' ) {
        next if $log{seen}{$id}++; # duplicates if request has >1 specimen
        push @{ $log{failed} }, $lab_no;
        my $location = $vars->{display_name};
        $log{unknown}{$location}++;
    }

    # non-NHS sources unless in trial/study:
	if ( $vars->{organisation_code} =~ /^NT\d{3}|8EQ15/ ) { 
		$vars->{category} = '04' unless $vars->{category} eq 'ST';
	}
    # private patient in NHS hospital:
	elsif ( $dbix->query($is_private, $vars->{id})->list ) { 
		$vars->{category} = '02'; # warn $vars->{id};
	}
    
    # apply any local billing rules before upload:
    apply_local_rules($vars);
    
    # generate data row:
    my $data = parse_data($vars);
    push @rows, $data;
}

my $cfg = $settings->{activity_data_server};

my $local_filename = sprintf '%s/hmds.dat', $JUST_TESTING
	? '/tmp' # override path for testing
	: $cfg->{path_to_datafile};

my $content = join "\n", @rows;
$content > io($local_filename);

unless ($JUST_TESTING) {
	my %args = (
		local_filename  => $local_filename,
		remote_filename => $cfg->{remote_filename},
		server_addr     => $cfg->{remote_address},
		username        => $cfg->{username},
		password        => $cfg->{password},
	);

    # ftp file (returns str on failure, undef on success):
    my $rtn = $tools->ftp_file(\%args);

    if ($rtn) {
        $tools->mail_admin({ script => $0, msg => $rtn });
        die "$0 - $rtn\n"; # dump to logs
    }
    print "$filename reports data for $month succesfully uploaded\n"; # for cron log
    # archive activity data file:
    archive_data_file();
}

my @no_referrer_src = map "$_: $log{unknown}{$_}",
    reverse sort { $log{unknown}{$a} <=> $log{unknown}{$b} }
    keys %{ $log{unknown} };
    
# calculate some vars for email message:
my $total_requests   = scalar @rows;
my $number_unsourced = scalar @{ $log{unsourced} };
my $number_failed    = scalar @{ $log{failed} };
my $percent_failed   = eval { 100 * $number_failed / $total_requests };
my $no_referrer_reqs = join "\n\t", @{ $log{failed} };
my $no_referrer_src  = join "\n\t", @no_referrer_src;

my $unsourced_labnos = get_unsourced_requests($log{unsourced});

# send emails to recipients:
my $message
    = sprintf qq!Activity data file created successfully (%s entries).\n\n!
    . qq!Unknown source: %s\n\t%s\n\n!
    . qq!Unknown referrer: %s (%.2f%%)\n\t%s\n\n!
    . qq!Sources for unknown referrer:\n\t%s!,
        $total_requests, 
        $number_unsourced,
        $unsourced_labnos,
        $number_failed,
        $percent_failed || 0,
        $no_referrer_reqs,
        $no_referrer_src; # print $message . "\n"; # exit;

my %mail = (		
	config  => $config,
	message => $message,
	subject => 'Activity data for month ' . $month, 	
); # warn Dumper \%mail; exit;
    
$tools->send_mail(\%mail, \@recipients);

sub parse_data {
    my $vars = shift; # hashref
    
    my $line = join $delimiter, (
		'HMDS',
        'H' . $vars->{request_number} . '/' . ( $vars->{year} - 2000 ),
		uc $vars->{last_name},
		( join ' ', map ucfirst $vars->{$_}, grep $vars->{$_}, qw/first_name middle_name/ ),
		$vars->{unit_number}, # have to handle default unknown
		$vars->{dob} ? DateTime::Format::MySQL->parse_date($vars->{dob})->dmy('/') : '',   # have to handle default unknown
		$vars->{age} || '',
		$vars->{gender} || 'U',
		$vars->{organisation_code}, 
		$vars->{referrer_code}, 
		$vars->{organisation_code} =~ /\A(RR8|RAE)/ ? $vars->{hospital_department_code} : '', 
		'HM' . $vars->{sample_code}, 
		'HM' . $vars->{sample_code}, 
		$vars->{category},
		$vars->{on_call},
		DateTime::Format::MySQL->parse_datetime($vars->{created_at})->dmy('/'),
        DateTime::Format::MySQL->parse_datetime($vars->{created_at})->strftime('%d/%m/%Y:%H:%M'),
        '', # external ref - not used
		$vars->{nhs_number}	|| '',	
	);
    
    return $line;
}

sub apply_local_rules {
    my $vars = shift; # hashref
    
	$vars->{first_name} = uc $vars->{first_name}
        if (
            $vars->{first_name} =~ /\A(lgi|pin)\Z/i ||
            $vars->{last_name}  =~ /\Ahtg\d+/i
        );

	# $vars->{unit_number} = '' if $vars->{unit_number} eq 'UNKNOWN';
 
    # avoid uninitialized value error:
	map $vars->{$_} ||= '', qw(trial_name presentation);
    
    # haematology needs to be clinical not laboratory:
    $vars->{hospital_department_code} =~ s/823/303/; 
    
   # Castleford & Normanton DH now RGX18, unless Dermatology which has its own code:
    if ( $vars->{organisation_code} eq 'RXF07' ) {
        if ( # examine both speciality & specimen:
            $vars->{hospital_department_code} == 330 ||
            $vars->{sample_description} =~ /^skin/i
        ) {
            $vars->{organisation_code} = '5N301D';
        }
        else {
            $vars->{organisation_code} = 'RGX18';
        }
    }
    
    # special case for outreach samples (PB -> CMPB):
    if ( # no longer regarded as clinical trial, use presentation:
            ( grep { $vars->{presentation} eq $_ }
                ('Community monitoring', 'Outreach')
            )
            && $vars->{sample_code} eq 'PB'
        )
    {
        $vars->{category} = '01'; # set sample type to chargeable (if not already)
        $vars->{sample_code} = 'CMPB'; # set special sample_type
    }
    
    # override ST category for research PB samples from non-LTH source:
    if ( $vars->{sample_code} eq 'RXPB' && $vars->{organisation_code} !~ /^RR8/) {
        $vars->{category} = '01';
    }

    # NCRI Arctic trials billed as normal:
    if ( $vars->{trial_name} eq 'NCRI CLL ARCTIC' ) {
        $vars->{category} = '01'; # override ST code
    }
}

sub get_unsourced_requests {
    my $data = shift; # arrayref of hashrefs (labno & trial)
    
    my @d = map {
        sprintf '%s [%s]', $_->{labno}, $_->{trial} || 'WILL NOT BE BILLED'
    } @$data;
    
    return join "\n\t", @d;
}

sub archive_data_file {
    my $data_file = $cfg->{path_to_datafile} . '/hmds.dat';
    # make sure it exists:
    if (-e $data_file) {
        my $o = io($data_file);
        
        my $input  = $o->name; # warn $input;
        # compress and archive:        
        my $output = sprintf '%s/%s_%02d_hmds.dat.gz',
            $cfg->{path_to_datafile}, $date->year, $date->month;

        my $status = gzip $input => $output, Minimal => 1 # avoids full path info
            or warn "$0 - gzip failed: $GzipError\n";

        $o->unlink; # archived if has data, deleted anyway
    }
}