#!/usr/bin/env perl =begin ------------------------------------------------------------------------- transfers xls file of requests for any auth'd within past 24hrs to ftp.tdlpathology.com, using Net::SFTP::Foreign sets uclh database manually, no need for command-line arg =cut --------------------------------------------------------------------------- use Getopt::Std; getopts('d:tq'); # days, testing, query output our($opt_d,$opt_t,$opt_q); # warn $opt_t; exit; use strict; use warnings; use feature 'say'; my $JUST_TESTING = $opt_t || 0; # dumps xls file in /tmp only #============================================================================== my $duration = $opt_d || 1; # days; for DATE(time_col) >= ( now minus 2 days ) #============================================================================== use lib '/home/raj/perl5/lib/perl5'; use IO::All; use Try::Tiny; use Text::CSV; use File::Temp; use Data::Printer; use Net::SFTP::Foreign; use SQL::Abstract::More; use FindBin qw($Bin); # warn $Bin; use lib $Bin . '/../../../lib'; use LIMS::Local::ScriptHelpers; use Spreadsheet::WriteExcel::Simple; # get tools from LIMS::Local::ScriptHelpers: my $tools = LIMS::Local::ScriptHelpers->new(); $tools->test_only($JUST_TESTING); my $today = $tools->time_now; my $cfg_file = "$Bin/../lib/settings.cfg"; my $settings = Config::Auto::parse($cfg_file); # p $settings; my $cfg = $settings->{uclh_tdl_server}; # p $cfg; #------------------------------------------------------------------------------- my $ref_date = $today->clone->subtract( days => $duration ); # warn $ref_date; my $sftphost = $cfg->{remote_address} or die 'remote_address cfg value missing'; my $username = $cfg->{username} or die 'username cfg value missing'; my $password = $cfg->{password} or die 'password cfg value missing'; my $remote_path = $cfg->{remote_path} or die 'remote_path cfg value missing'; my $remote_file = 'hsl_hmds_data.xls'; #------------------------------------------------------------------------------- my $config = $tools->config(); my $dbix = $tools->dbix(); $dbix->lc_columns = 0; # preserve MixedCase $dbix->dbh->do('USE uclh'); my ($sql, @bind) = _get_query(); # p $sql; p @bind; my $query = $dbix->query( $sql, @bind ); my @cols = $query->columns; # p @cols; my @data = $query->arrays; # p @data; exit unless @data; # open my $fh, '>:encoding(utf8)', my \$data or die "IO: $!"; my $fh = File::Temp->new(); # create new fh to tmpfile in /tmp dir my $xl = Spreadsheet::WriteExcel::Simple->new; my $local_file = $fh->filename; $local_file .= '.xls' if $JUST_TESTING; # warn $local_file; # won't auto-delete $xl->write_bold_row(\@cols); $xl->write_row($_) for @data; $xl->save($local_file); if ($JUST_TESTING) { say 'data saved to ' . $local_file; exit; } { # sftp file: my %args = ( user => $username, password => $password ); my $sftp = Net::SFTP::Foreign->new($sftphost, %args); $sftp->die_on_error('unable to establish SFTP connection'); # need to manually set remote path: $sftp->setcwd($remote_path) or msg_and_exit('unable to set cwd: ' . $sftp->error); # need to set copy_perm false or get error "put failed: Couldn't setstat # remote file: SSH_FILEXFER_ATTR_PERMISSIONS": $sftp->put($local_file, $remote_file, copy_perm => 0) or msg_and_exit('put failed: ' . $sftp->error); # probably caught any error aleady, but just in case: if ( my $err = $sftp->error ) { msg_and_exit($err); } else { my $script = $tools->script_filename; my $date = $ref_date->dmy; # for cron log say "$script reports UCLH data for $date successfully transferred"; } } sub msg_and_exit { my $msg = shift; my $script = $tools->script_filename; say "$script - $msg"; # dump to logs $tools->mail_admin({ script => $script, msg => $msg }); exit; } sub _get_query { my @cols = ( 'pc.unit_number|PatientNumber', q{CONCAT_WS(' ', p.first_name, p.last_name)|PatientName}, 'p.gender|Sex', 'p.dob|DoB', q{DATE_FORMAT(r.created_at,'%Y') - DATE_FORMAT(p.dob,'%Y') - (DATE_FORMAT(r.created_at,'00-%m-%d') < DATE_FORMAT(p.dob,'00-%m-%d')) AS Age}, q{MAX(CASE WHEN ao.option_name = 'private' THEN 'Private' ELSE 'NHS' END) AS Category}, 'p.nhs_number|NHSNo', 'pn.detail|PatientNotes', 'NULL|RefOrdNo', # referred from another location 'NULL|ReferringLabNo', # referred from another location 'NULL|ReferringClinician', # referred from another location 'rs.organisation_code|SourceCode', 'rs.display_name|SourceName', 'NULL|SourceClass', 'ref.national_code|ClinicianCode', 'ref.name|ClinicianName', 'DATE(rsd.specimen_date)|SampleDate', 'TIME(rsd.specimen_date)|SampleTime', # assuming received date/time same as registration date/time q{MAX(CASE WHEN rh.action = 'registered' THEN DATE(rh.time) END) AS ReceivedDate}, q{MAX(CASE WHEN rh.action = 'registered' THEN TIME(rh.time) END) AS ReceivedTime}, q{MAX(CASE WHEN rh.action = 'registered' THEN DATE(rh.time) END) AS BookedDate}, q{MAX(CASE WHEN rh.action = 'registered' THEN TIME(rh.time) END) AS BookedTime}, q{MAX(CASE WHEN rh.action = 'registered' THEN CONCAT_WS(' ', u.first_name, u.last_name) END) AS BookedUser}, q{MAX(CASE WHEN ao.option_name = 'urgent' THEN 'yes' ELSE 'no' END) AS Urgent}, 's.sample_code|SampleType', 's.description|SampleDesc', q{CONCAT('U', r.request_number, '/', r.year - 2000)|LabNo}, q{IF(lt.test_type = 'panel', lt.field_label, NULL) AS TLC}, q{IF(lt.test_type = 'test', lt.field_label, NULL) AS TFC}, 'NULL|Result', # no results available 'NULL|ResultDate', # no results available 'NULL|ResultTime', # no results available q{MAX(CASE WHEN rh.action = 'authorised' THEN DATE(rh.time) END) AS AuthDate}, q{MAX(CASE WHEN rh.action = 'authorised' THEN TIME(rh.time) END) AS AuthTime}, 'NULL|Units', 'NULL|RangeLo', 'NULL|RangeHi', ); my @rels = ( 'requests|r' , q{r.patient_case_id=pc.id} => 'patient_case|pc' , q{pc.patient_id=p.id} => 'patients|p' , q{pc.referral_source_id=rs.id} => 'referral_sources|rs' , q{rsv.request_id=r.id} => 'request_status_view|rsv' , q{r.referrer_department_id=rd.id} => 'referrer_department|rd' , q{rd.referrer_id=ref.id} => 'referrers|ref' , q{rsd.request_id=r.id} => 'request_specimen_detail|rsd' , q{rsp.request_id=r.id} => 'request_specimen|rsp' , q{rsp.specimen_id=s.id} => 'specimens|s' , q{rh.request_id=r.id} => 'request_history|rh' , q{rh.user_id=u.id} => 'users|u' , # left joins: q{=>ts.request_id=r.id} => 'request_lab_test_status|ts' , q{=>ts.lab_test_id=lt.id} => 'lab_tests|lt' , q{=>ro.request_id=r.id} => 'request_option|ro' , q{=>ro.option_id=ao.id} => 'additional_options|ao' , q{=>pn.patient_id=p.id} => 'patient_notes|pn' , ); my %where = ( 'DATE(rsv.time)' => $ref_date->ymd, 'rsv.action' => 'authorised', ); my @args = ( -columns => \@cols, -from => [ -join => @rels ], -where => \%where, -group_by => ['lt.id','r.id'], -order_by => 'r.id', ); # p @args; my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p \@bind; $dbix->dump_query($sql, @bind) if $opt_q; # exit; return ($sql, @bind); }