package LIMS::Model::Audit;
use Moose;
extends 'LIMS::Model::Base';
with (
'LIMS::Model::Roles::Query', # get_sql_with_constraint(), get_relationships(), sql_lib()
);
use namespace::clean -except => 'meta';
__PACKAGE__->meta->make_immutable;
use Data::Dumper;
use LIMS::Local::Utils;
use LIMS::Local::ExcelHandler;
#===============================================================================
my @hiv_set = ( 'HIV', 'HIV monitoring' );
my @pnh_pb_set = ( 'PNH', 'PNH (PB)', 'NCG PNH (PB)' );
my @molecular_set = (
'CML follow-up',
'Follow-up CML',
'Chimerism',
'Molec',
'CMPD',
);
my @outreach_set = (
'Outreach BLPD/PCD pre-Rx monitoring',
'Outreach post-Rx CLL',
'Community monitoring',
'Outreach CML',
'Outreach',
);
#===============================================================================
sub turnaround_times_average {
my $self = shift;
my $vars = shift; # warn Dumper $vars; # hashref eg selection = 'specimen'
$self->params($vars);
my $dbix = $self->lims_dbix;
# for calculation of delta workings days:
my $delta_days = sub { LIMS::Local::Utils::delta_business_days(@_) };
my %h = (
pnh => \@pnh_pb_set,
hiv => \@hiv_set,
cmp => \@outreach_set,
mol => \@molecular_set,
); # warn Dumper \%h;
my $sql_lib = 'turnaround_times';
my @attr = ($sql_lib, 'h1.time'); # h1.action = 'reported'
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql; return 1;
my $query = $dbix->query( $sql ); # warn Dumper $query;
my %data = (); # controller needs array for sorting, but easier to create hashref for 'count'
while ( my $vars = $query->hash ) {
my $sample = $vars->{sample_code}; # warn $sample;
my $screen = $vars->{description};
# need to split PB's according to request:
if ($sample eq 'PB') {
if ( grep $screen eq $_, @{ $h{hiv} } ) { $sample = 'PB [HIV]' }
elsif ( grep $screen eq $_, @{ $h{pnh} } ) { $sample = 'PB [PNH]' }
elsif ( grep $screen eq $_, @{ $h{cmp} } ) { $sample = 'PB [CMP]' }
elsif ( grep $screen =~ /^$_/, @{ $h{mol} } )
{ $sample = 'PB [Mol]' }
} # warn $screen if $sample eq 'PB [PNH]';
$data{$sample}{count}++; # increment specimen count
# get registered, reported & authorised dates; using DATE_FORMAT in sql
# MUCH faster than dt conversion afterwards:
my ($registered, $reported, $authorised)
= @{$vars}{ qw(registered reported authorised) };
# calculate registered => reported & registered => auth'ed durations:
# use 'abs' as fix for samples registered on Sun & reported/auth'd on Mon (delta = -1):
my $delta = &$delta_days($registered, $reported);
$data{$sample}{delta_report} += abs($delta);
if ($authorised) { # if using authorisation stage
my $delta = &$delta_days($registered, $authorised);
$data{$sample}{delta_authorise} += abs($delta);
}
} # warn Dumper \%data;
my $title = $self->constraint_title; # set in Role _set_search_constraints()
return (\%data, $title); # return array format
}
#-------------------------------------------------------------------------------
sub turnaround_times_data {
my $self = shift;
my $vars = shift; # warn Dumper $vars;
my $query = $self->_get_turnaround_times_query($vars);
# for calculation of delta workings days:
my $delta_days = sub { LIMS::Local::Utils::delta_business_days(@_) };
my $action = $self->does_authorisation ? 'authorised' : 'reported';
my @cols = qw( request_number year sample_code description registered );
push @cols, $self->does_authorisation ? 'authorised' : 'reported';
my @ary;
while ( my $vars = $query->hash ) {
my ($alpha, $omega) = @{$vars}{ ('registered', $action) };
# calculate registered => reported/authorised duration:
my $delta = &$delta_days($alpha, $omega); # warn Dumper [$vars, $delta] if $delta < 0;
push @ary, [ @{$vars}{@cols}, $delta ]; # format suitable for XL
}
# sort by delta (desc), then yr, then request number
my @sorted = sort {
$b->[-1] <=> $a->[-1] || $a->[1] <=> $b->[1] || $a->[0] <=> $b->[0]
} @ary;
return \@sorted;
}
#-------------------------------------------------------------------------------
sub turnaround_times_chart {
my $self = shift;
my $vars = shift; # warn Dumper $vars;
my $query = $self->_get_turnaround_times_query($vars);
# for calculation of delta workings days:
my $delta_days = sub { LIMS::Local::Utils::delta_business_days(@_) };
my $action = $self->does_authorisation ? 'authorised' : 'reported';
my @ary;
while ( my $vars = $query->hash ) { # warn Dumper $vars;
my ($alpha, $omega) = @{$vars}{ ('registered', $action) };
# calculate registered => authorised duration:
my $delta = &$delta_days($alpha, $omega); # warn Dumper [$vars, $delta] if $delta < 0;
# use 'abs' as fix for samples registered on Sun & reported/auth'd on Mon (delta = -1):
push @ary, abs($delta); # warn Dumper [$vars, $delta] if $delta < 0;
} # warn Dumper \@ary;
my $title = $self->constraint_title; # set in Role::DBIxSimple
return (\@ary, $title);
}
#-------------------------------------------------------------------------------
sub turnaround_times_percentile {
my $self = shift;
my $vars = shift; # warn Dumper $vars; # hashref eg selection = 'specimen'
$self->params($vars);
my $dbix = $self->lims_dbix;
# for calculation of delta workings days:
my $delta_days = sub { LIMS::Local::Utils::delta_business_days(@_) };
my %h = (
pnh => \@pnh_pb_set,
hiv => \@hiv_set,
cmp => \@outreach_set,
mol => \@molecular_set,
);
my $sql_lib = 'turnaround_times';
my @attr = ($sql_lib, 'h1.time'); # h1.action = 'reported'
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql;
my $query = $dbix->query( $sql ); # warn Dumper $query;
my %data = ();
while ( my $vars = $query->hash ) {
my $sample = $vars->{sample_code}; # warn $sample;
my $screen = $vars->{description};
# need to split PB's according to request:
if ($sample eq 'PB') {
if ( grep $screen eq $_, @{ $h{hiv} } ) { $sample = 'PB [HIV]' }
elsif ( grep $screen eq $_, @{ $h{pnh} } ) { $sample = 'PB [PNH]' }
elsif ( grep $screen eq $_, @{ $h{cmp} } ) { $sample = 'PB [CMP]' }
elsif ( grep $screen =~ /^$_/,
@{ $h{mol} } ) { $sample = 'PB [Mol]' }
} # warn $screen if $sample eq 'PB [PNH]';
elsif ( $sample =~ /([DGLRX]F|U)$/ ) { $sample = 'Tissue' }
elsif ( $sample =~ /BL$/ ) { $sample = 'Block' }
elsif ( $sample =~ /^CHI/ ) { $sample = 'CHI*' }
elsif ( $sample =~ /HS|SL$/ ) { $sample = 'Slide' }
elsif ( $sample =~ /[XL]A$/ ) { $sample = 'Tissue aspirate' }
$data{$sample}{count}++; # increment specimen count
# get registered, reported & authorised dates; using DATE_FORMAT in sql
# MUCH faster than dt conversion afterwards:
my ($registered, $reported, $authorised)
= @{$vars}{ qw(registered reported authorised) };
# calculate registered => reported & registered => auth'ed durations:
# use 'abs' as fix for samples registered on Sun & reported/auth'd on Mon (delta = -1):
my $delta = &$delta_days($registered, $reported);
push @{ $data{$sample}{delta_report} }, abs($delta);
if ($authorised) { # if using authorisation stage
my $delta = &$delta_days($registered, $authorised);
push @ { $data{$sample}{delta_authorise} }, abs($delta);
}
} # warn Dumper \%data;
my $title = $self->constraint_title; # set in Role _set_search_constraints()
return (\%data, $title); # return array format
}
#-------------------------------------------------------------------------------
sub turnaround_times_lab_tests {
my $self = shift;
my $vars = shift; # warn Dumper $vars; # hashref of constraints/type
$self->params($vars);
my $data = $self->_lab_test_data(); # warn Dumper $data;
my $title = $self->constraint_title; # from _set_search_constraints(), do last!!
return ($data, $title); # return array format
}
#-------------------------------------------------------------------------------
sub lab_test_turnaround_export { # same as turnaround_times_lab_tests but exports xl:
my $self = shift;
my $vars = shift; # warn Dumper $vars; # hashref of constraints/type
$self->params($vars);
my @data = $self->_lab_test_data(); # in list context for wantarray()
my @headers = qw( request_number year registered lab_section lab_test
requested completed );
my $xl = LIMS::Local::ExcelHandler->new();
my $data_file = $xl->generate_spreadsheet(\@headers, \@data);
return $data_file;
}
#-------------------------------------------------------------------------------
sub lab_tests_sign_off {
my $self = shift;
my $vars = shift; # warn Dumper $vars; # hashref eg lab_section_id = 5
$self->params($vars);
$self->add_constraint( 'ls.id = ?' );
my $dbix = $self->lims_dbix;
my @attr = ('lab_tests_sign_off', 't1.time');
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql;
my $data = $dbix->query( $sql, $vars->{lab_section_id} )->hashes; # warn Dumper $data;
my $title = $self->constraint_title; # set in Role _get_search_constraints()
return ($data, $title); # return array format
}
#-------------------------------------------------------------------------------
sub nhs_number_supplied {
my $self = shift;
my $vars = shift || {}; # will be empty on 1st call
$self->params($vars);
my $dbix = $self->lims_dbix;
my $dbh = $self->lims_db->dbh; # warn Dumper $dbh;
# exempted NHS number:
if ( my $yaml = $self->get_yaml_file('nhs_number_exempt') ) { # warn Dumper $yaml;
my $clinical_trials = $yaml->{clinical_trial};
my $presentation = $yaml->{presentation};
my $screens = join ',', map $dbh->quote($_), @$presentation;
my $trials = join ',', map $dbh->quote($_), @$clinical_trials;
$self->add_constraint( qq!s.description NOT IN ($screens)! );
$self->add_constraint(
qq!(ct.trial_name IS NULL OR ct.trial_name NOT IN ($trials))! );
}
my @attr = ('nhs_number_compliance', 'r.created_at');
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql;
my $data = $dbix->query( $sql )->hashes; # warn Dumper $data;
my $title = $self->constraint_title; # set in Role _get_search_constraints()
return ($data, $title); # return array format
}
#-------------------------------------------------------------------------------
sub teaching_cases {
my $self = shift;
my $days = shift; # default is 365
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('teaching_cases');
my $data = $dbix->query($sql, $days)->hashes; # warn Dumper $data;
return $data;
}
#-------------------------------------------------------------------------------
sub trend_analysis { # uses SQL::Abstract::More to generate queries
my ($self, $profile) = @_; # warn Dumper $profile;
my $today = LIMS::Local::Utils::today;
my $dbix = $self->lims_dbix;
my $interval = 3; # every 3 months
my @tbl_rels = (
'requests|r' , 'r.id = tr.request_id' ,
'request_lab_test_results|tr' , 'tr.lab_test_id = lt.id' ,
'lab_tests|lt' , 'ls.id = lt.lab_section_id' ,
'lab_sections|ls' , 'r.id = rrd.request_id' ,
'request_report_detail|rrd' , 'rrd.diagnosis_id = d.id' ,
'diagnoses|d'
);
my %sqla_args = ( # common args
cols => [ 'tr.result', 'count(*)' ],
joins => \@tbl_rels,
group_by => 'tr.result'
);
# hashref of restrictions for where clause (eg icdo3 => '9830/3):
my $restriction = $profile->{restriction};
# test result for monitoring (eg rearranged, deleted, etc):
my $gene_status = $profile->{gene_status}; # warn Dumper $gene_status;
my %h = ();
for my $i (0 .. 21) { # intervals 0 - 3, 3 - 6, ... 21 - 24
next if $i % $interval; # warn $i; # every 3 months
my $t1 = $today->clone->subtract(months => $i + $interval)->ymd;
my $t2 = $today->clone->subtract(months => $i)->ymd;
# date restriction:
$restriction->{'date(tr.time)'} = { -between => [ $t1, $t2 ] };
# add where clause:
$sqla_args{where} = $restriction;
my ($sql, @bind) = $self->sqla_query(\%sqla_args);
my $results = $dbix->query($sql, @bind)->map; # warn Dumper $results;
my $result = 0;
if (ref $gene_status) { # more than 1 gene status
$result += ( $results->{$_} || 0 ) for @$gene_status;
}
else {
$result = $results->{$gene_status} || 0;
} # warn $result;
my $total = LIMS::Local::Utils::sum_list([ values %$results ]); # warn $total;
# avoid division by zero error if $result = 0 (so will $total)
my $value = $total ? ( $result / $total ) : 0; # warn Dumper [$i, $value];
push @{ $h{interval} }, $i;
push @{ $h{value} }, $value;
push @{ $h{totals} }, $total;
} # warn Dumper \%h;
return \%h;
}
#-------------------------------------------------------------------------------
sub user_workload {
my ($self, $args) = @_; # warn Dumper $args;
my $actions = $args->{action}; # arrayref
$self->params($args->{vars});
my @attr = ('user_workload_stats', 'rh.time', 'one_month');
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql;
my $dbix = $self->lims_dbix;
my $data = $dbix->query( $sql, @$actions )->hashes; # warn Dumper $data;
return {
title => $self->constraint_title, # set in get_date_constraints()
stats => $data,
};
}
#-------------------------------------------------------------------------------
sub revised_diagnoses {
my $self = shift;
my $vars = shift || {}; # will be empty on 1st call (except sort_by)
$self->params($vars);
my $dbix = $self->lims_dbix;
my $revisions;
{ # get revised diagnoses over duration:
my @attrs = ('revised_diagnoses', 'dh.time', 'one_month'); # default to 1 month
my $sql = $self->get_sql_with_constraint(@attrs); # warn $sql;
$revisions = $dbix->query($sql)->hashes; # warn Dumper $revisions;
}
my @request_ids = map $_->{id}, @$revisions; # before $revisions gets revised!!
my %data = (
request_ids => \@request_ids,
);
my $constraint = join ' AND ', $self->all_constraints; # set in Role::get_sql_with_constraint
$constraint =~ s/\w+\.(\w+)/$1/; # remove alias - only have 1 table to search
my $sql = qq!select count(*) from request_history where $constraint
and action = 'reported'!; # warn $sql;
{ # get total reported over duration:
my $total = $dbix->query($sql)->list;
$data{total_reported} = $total;
}
# need to manipulate & extend $revisions data if either apply:
if ( grep $vars->{sort_by} eq $_, qw(reporter reviser) ) {
my $data = $self->_sort_revisions($revisions); # sort data
$data{revisions} = $data;
if ( my @usernames = keys %$data ) { # will be empty if no revisions
my $users = LIMS::DB::User::Manager->get_users(
query => [ username => \@usernames ]
);
{ # add user_details to %data:
my %user_details = map { $_->{username} => $_ } @$users;
$data{user_details} = \%user_details;
}
# add user contstraint to $sql:
$sql .= q! and user_id = ?!;
{ # need report count for each user:
for (@$users) {
my $username = $_->username;
my $user_id = $_->id;
my $report_count = $dbix->query($sql, $user_id)->list;
$data{user_report_counts}{$username} = $report_count;
}
}
}
}
else {
$data{revisions} = $revisions;
}
my $title = $self->constraint_title; # set in Role _get_search_constraints()
return (\%data, $title); # return array format
}
#-------------------------------------------------------------------------------
sub edit_revised_diagnosis {
my ($self, $request_id) = @_;
my @rels = qw(
request_report.diagnosis
request_diagnosis_history.option
request_diagnosis_history.diagnosis
);
my $data = LIMS::DB::Request->new(id => $request_id)->load(with => \@rels);
return $data;
}
#-------------------------------------------------------------------------------
# common method for turnaround_times_lab_tests() & lab_test_turnaround_times()
sub _lab_test_data {
my $self = shift;
my $dbix = $self->lims_dbix;
my $sql_lib = 'turnaround_lab_test_times';
my @attr = ($sql_lib, 'r.created_at'); # registered
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql;
my $data = $dbix->query($sql)->hashes; # warn Dumper $result;
# for calculation of delta workings days:
my $delta_days = sub { LIMS::Local::Utils::delta_business_days(@_) };
# get details of any manual/auto-requested lab-tests from request_lab_test_history:
my $manual_request_map = $self->_get_post_screen_lab_test_requests($data);
# get field labels of any tests auto-requested at registration:
my $auto_requested_map = $self->_get_registration_lab_test_requests();
my @fields = qw( request_id request_number year registered section_name
field_label screened completed ); # fields extracted from db tables
my @rows = my %h = (); # @rows for xl file, %h for counts, deltas, etc
RESULT:
for my $ref ( @$data ) {
my ($request_id, $request_number, $year, $registered, $lab_section,
$test_name, $screened, $completed) = map $ref->{$_}, @fields;
# warn Dumper [map $ref->{$_}, @fields];
# get possible date of manual test request:
my $manual_request_date = $manual_request_map->{$request_id}{$test_name};
# warn Dumper [$request_id, $test_name, $manual_request_date, $screened];
# get possible date of auto-request at registration:
my $auto_request_date = $auto_requested_map->{$test_name}
? $registered : 0; # zero OK as will be tested for truth below
# use manual request date if exists, or auto-requets date, or date of screening:
my $requested = $manual_request_date || $auto_request_date || $screened;
if ( wantarray ) { # collect rows for xl file output:
my @vals = ( $request_number, $year, $registered, $lab_section,
$test_name, $requested, $completed ); # warn Dumper \@vals;
push @rows, \@vals;
next RESULT; # spare delta calcs - not required for xl file
}
$h{$lab_section}{$test_name}{count}++; # increment section/test count
# calculate date requested => completed; use 'abs' as fix for samples
# requested on Sun & completed on Mon (delta = -1):
my $delta = &$delta_days($requested, $completed);
$h{$lab_section}{$test_name}{delta_days} += abs($delta);
} # warn Dumper [\@rows, \%h];
# return depends on whether list of rows or data hashref required:
return wantarray ? @rows : \%h;
}
#-------------------------------------------------------------------------------
# shared by turnaround_times_data & turnaround_times_chart
sub _get_turnaround_times_query {
my $self = shift;
my $vars = shift; # warn Dumper $vars;
my $dbix = $self->lims_dbix;
$self->params($vars);
my $specimen = $vars->{specimen};
# generate contraints/binds for query (get_sql_with_constraint & all_bind_vars):
$self->_get_turnaround_times_constraints($specimen);
my $sql_lib = $self->does_authorisation
? 'turnaround_times_to_authorisation'
: 'turnaround_times_to_reporting';
my @attr = ($sql_lib, 'h1.time');
my $sql = $self->get_sql_with_constraint(@attr); # warn $sql;
my @bind = $self->all_bind_vars; # warn Dumper \@bind;
my $query = @bind # use bind values if supplied
? $dbix->query( $sql, @bind )
: $dbix->query( $sql ); # warn Dumper $query;
return $query;
}
#-------------------------------------------------------------------------------
# convert specimen description from turnaround_times_percentile() back to regexp:
sub _get_turnaround_times_constraints { # no return value expected
my ($self, $specimen) = @_;
if ( $specimen eq 'PB' ) { # complex screening terms:
# sample = PB:
$self->add_constraint( 's1.sample_code = ?' );
$self->add_bind_vars('PB');
# not screened as (list):
$self->add_constraint( 's2.description NOT IN (??)' );
$self->add_bind_vars($_) for ( @pnh_pb_set, @hiv_set, @outreach_set );
# not screened as (regex):
$self->add_constraint( 's2.description NOT RLIKE ?' );
$self->add_bind_vars( join '|', @molecular_set );
}
elsif ( $specimen eq 'PB [Mol]' ) { # complex screening terms:
# sample = PB:
$self->add_constraint( 's1.sample_code = ?' );
$self->add_bind_vars('PB');
# screened as (list):
$self->add_constraint( 's2.description RLIKE ?' );
$self->add_bind_vars( join '|', @molecular_set );
}
elsif ( $specimen =~ /PB \[(\w+)\]/ ) { # PB [PNH], PB [HIV], etc
my $type = $1; # warn $type;
# sample = PB:
$self->add_constraint( 's1.sample_code = ?' );
$self->add_bind_vars('PB');
my %h = (
PNH => \@pnh_pb_set,
HIV => \@hiv_set,
CMP => \@outreach_set,
); # warn Dumper $h{$type};
# screened as (list):
$self->add_constraint( 's2.description IN (??)' );
$self->add_bind_vars($_) for @{ $h{$type} };
}
else {
my %h = (
Tissue => '([DGLRX]F|U)$',
Block => 'BL$',
'CHI*' => '^CHI',
Slide => 'HS|SL$',
'Tissue aspirate' => '[XL]A$',
);
if ( my $var = $h{$specimen} ) {
# specimen matches regex:
$self->add_constraint( 's1.sample_code RLIKE ?' );
$self->add_bind_vars($var);
}
else {
# sample = $specimen (eg so BMA doesn't match BMAT):
$self->add_constraint( 's1.sample_code = ?' );
$self->add_bind_vars($specimen);
}
}
}
# ------------------------------------------------------------------------------
sub _get_post_screen_lab_test_requests {
my $self = shift;
my $data = shift;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('turnaround_lab_test_post_screen_requests');
my $request_ids = do {
my @ids = map $_->{request_id}, @$data; # contains duplicates
LIMS::Local::Utils::get_unique_elements(\@ids); # unique and in numerical order
}; # warn Dumper $request_ids;
my %h = ();
if (@$request_ids) { # or dbix query fails
my $results = $dbix->query($sql, @$request_ids)->hashes;
for my $r (@$results) {
my ($request_id, $action) = ($r->{request_id}, $r->{action}); # warn Dumper $action;
# remove '(auto-)requested' & 'triggered by diagnosis' phrases:
$action =~ s/(auto-)?requested | triggered by diagnosis//g; # warn Dumper $action;
$h{$request_id}{$action} = $r->{datetime};
} # warn Dumper \%h;
}
return \%h;
}
# ------------------------------------------------------------------------------
sub _get_registration_lab_test_requests { # tests auto-requested at registration
my $self = shift;
my @args = (
distinct => 1,
select => 'lab_test.field_label',
require_objects => 'lab_test',
);
my $o = LIMS::DB::SpecimenLabTest::Manager->get_objects(@args);
my %map = map +($_->lab_test->field_label => 1), @$o; # warn Dumper \%map;
return \%map;
}
# ------------------------------------------------------------------------------
sub _sort_revisions {
my $self = shift;
my $data = shift; # warn Dumper $data;
my $functionary = $self->params->{sort_by}; # reporter / reviser
my %sorted;
for my $event (@$data) { # warn Dumper $event;
my $user = $event->{$functionary}; # ie reporter / reviser
push @{ $sorted{$user} }, $event; # warn Dumper $user;
}
return \%sorted;
}
=begin # not selecting by specimen, location, etc
sub _get_sql_lib_entry_for_selection {
my ($self, $selection) = @_;
my %t = (
specimen => 'turnaround_times',
);
my $lib_entry_name = $t{$selection};
# have to modify lib_entry_name if authorisation stage not in use:
if (! $self->does_authorisation) {
$lib_entry_name .= '_no_authorisation';
}
return $lib_entry_name;
}
=cut
1;
