• Files
• Commits
• Log
• Graph
• Stats

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;

#-------------------------------------------------------------------------------
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', 'PNH (PB)' ],
        hiv => [ 'HIV', 'HIV monitoring' ],
        cmp => [ 'Community monitoring', 'Outreach' ],
        mol => [
            qw/CMPD Chimerism Molec/, 'CML follow-up', 'Follow-up CML'
        ],
    );

    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 @ary;
    while ( my $vars = $query->hash ) {
        my ($alpha, $omega) = @{$vars}{ qw(registered authorised) };
    
        # calculate registered => authorised duration:
		my $delta = &$delta_days($alpha, $omega); # warn Dumper [$vars, $delta] if $delta < 0;
		my @cols = qw( request_number year sample_code description registered
			authorised );
		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 @ary;
    while ( my $vars = $query->hash ) {
        my ($alpha, $omega) = @{$vars}{ qw(registered authorised) };
    
        # 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', 'PNH (PB)' ],
        hiv => [ 'HIV', 'HIV monitoring' ],
        cmp => [ 'Community monitoring', 'Outreach' ],
        mol => [
            qw/CMPD Chimerism Molec/, 'CML follow-up', 'Follow-up CML'
        ],
    );

    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 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 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 = 'turnaround_times_to_authorisation';
 	my @attr    = ($sql_lib, 'h1.time'); # h1.action = 'authorised'
 	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 ( qw/PNH Outreach HIV/,
            'PNH (PB)', 'HIV monitoring', 'Community monitoring');
		# not screened as (regex):
        $self->add_constraint( 's2.description NOT RLIKE ?' );
        $self->add_bind_vars( join '|', qw/CMPD Chimerism Molec/,
            'CML follow-up', 'Follow-up CML' );
    }
    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 '|', qw/CMPD Chimerism Molec/,
            'CML follow-up', 'Follow-up CML' );
    }
    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', 'PNH (PB)' ],
            HIV => [ 'HIV', 'HIV monitoring' ],
            CMP => [ 'Community monitoring', 'Outreach' ],
        ); # 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;