• Files
• Commits
• Log
• Graph
• Stats

# updates hilis4.request_storage dna concentrations from xl src in 
# "I:\MiSeq\Myeloid\HILIS concentration upload" and adds comment to
# request_lab_test_history

# usage: perl storage_dna_update.pl -f [-t] MiSeq_Myeloid_20xx_xx_upload.xlsx

use Getopt::Std;
getopts('f:t'); # filename, testing
our($opt_f, $opt_t); # warn $opt_t; exit;

use lib '/home/raj/perl-lib';

use FindBin qw($Bin); # warn $Bin;
use Data::Printer alias => 'p', use_prototypes => 1;
use Math::Round qw(round);
use Spreadsheet::Read;
use Local::DB;
use Modern::Perl;
use IO::All;

#===============================================================================
my $db = 'hilis4';
my $src = $opt_f or die 'require source filename'; # p $src; 
my $JUST_TESTING = $opt_t || 0; # prints update but doesn't do it
#===============================================================================

my $dbix = Local::DB->dbix({ dbname => 'hilis4' });
$dbix->lc_columns = 0; # vialId

my $xls = ReadData($Bin . '/' . $src); # p $xls;
my $log = $src =~ s/xlsx$/log/r; # p $log; # r = non-destructive;

my $sheet = $xls->[1]; # p $sheet; # 1st sheet
# rows() not exported so call as fully qualified method:
my @rows = Spreadsheet::Read::rows($sheet); # p @rows; # AoA

my $headers = shift @rows;
$_ =~ s/\s/_/ for @$headers;
$_ =~ s/(\w+)/lc $1/eg for @$headers; # p $headers; exit;

my $request_query = q!select r.id, p.last_name from hilis4.requests r join
    patient_case pc on r.patient_case_id = pc.id join patients p on
    pc.patient_id = p.id where request_number = ? and year = ?!;
my $storage_query = qq!select vialId, concentration from $db.request_storage 
    where request_id = ? and specimen_id = ?!;
my $specimen_map = $dbix->select('specimens', ['sample_code','id'])->map; # p $specimen_map;
 
my $user_id; # set inside block
my $i = 0; # update success counter

ROW:
for my $row (@rows) { # arrayref
    my $data = _to_hash($row); # p $data; next;
  # get user - may only occur once in spreadsheet, needs to be 1st row:
    if ( my $user = trim($data->{user}) ) {
        $user_id ||= $dbix->select('users', 'id', { username => $user})->value
        or die "cannot find user_id for user $user"; # p $user_id;
    }
  # check we have a valid user_id:
    defined $user_id || die 'cannot find a valid user_id';
  # get request_number & year from sample col:
    my ($req_num, $yr) = $data->{sample} =~ m!H?(\d+)/(\d{2})!; # p $req_num; p $yr;
  # get request_id & last_name from hilis4 db:
    my ($req_id, $last_name) 
        = $dbix->query($request_query, $req_num, $yr + 2000)->row; # p $req_id;  p $last_name;
    unless ( lc $last_name eq lc trim($data->{last_name}) ) {
        my $msg = sprintf "request %s/%s last name mismatch (%s, %s)",
            $req_num, $yr, $last_name, $data->{last_name};
        $JUST_TESTING
            ? say $msg
            : io($Bin . '/'. $log)->append($msg . "\n");
        next ROW;
    }
  # get specimen from specimen col & get specimen_id from hilis4:
    my $specimen    = trim($data->{specimen}); # p $specimen;
    my $specimen_id = $specimen_map->{$specimen} or 
        say qq!don't recognise "$specimen"! and next ROW;
  # get concentration result from xl col:
    my $new_value = round($data->{concentration}); # p $concentration;
  # get db request_storage vialId & current value for request_id/specimen:
    my ($vialId, $old_value) 
        = $dbix->query($storage_query, $req_id, $specimen_id)->row;
    unless ( $vialId && $old_value ) {
        my $msg = sprintf "request %s/%s does not have %s stored",
            $req_num, $yr, $specimen;
        $JUST_TESTING
            ? say $msg
            : io($Bin . '/'. $log)->append($msg . "\n");
        next ROW;
    }
    # end of block if just testing:
    say "will update $req_num/$yr $vialId/$specimen $old_value -> $new_value" 
        and next ROW if $JUST_TESTING;

    { # update request_storage table:
        my $result = $dbix->update("$db.request_storage", 
            { concentration => $new_value },
            { vialId => $vialId, part_number => 1 });
        unless ( $result->rows ) {
            my $msg = sprintf "request %s/%s failed to update with %s/%s", 
                $req_num, $yr, $specimen, $new_value;
            $JUST_TESTING
                ? say $msg
                : io($Bin . '/'. $log)->append($msg . "\n");
            next ROW;
        }
        my $msg = sprintf "updated request %s/%s %s DNA concentration from %s to %s",
            $req_num, $yr, $specimen, $old_value, $new_value;
        io($Bin . '/'. $log)->append($msg . "\n");
        $i += $result->rows;
    }
    { # do request_lab_test_history:
        my %h = (
            request_id => $req_id,
            user_id	   => $user_id,
            action     => "batch-updated $specimen storage vial DNA concentration value",
        );
        my $result = $dbix->insert("$db.request_lab_test_history", \%h);
        unless ( $result->rows ) {
            my $msg = sprintf 
                "failed to update request_lab_test_history for request %s/%s",
                    $req_num, $yr;
        }
    }
}
say sprintf "updated %s of %s rows", $i, scalar @rows;

sub trim {
    local $_ = shift || return;
    $_ =~ s/^\s+|\s+$//g;
    return $_;
}

sub _to_hash {
    my $ref = shift; # p $ref; # arrayref
    my %h; 
    my $i = 0;
    for (@$headers) { # p $_;
        $h{$_} = $ref->[$i++];
    } # p %h;
    return \%h;
}