package LIMS::Model::Result;
use Moose;
extends 'LIMS::Model::Base';
with (
'LIMS::Model::Roles::Query', # get_relationships()
'LIMS::Model::Roles::SessionData', # provides $self->user_profile
'LIMS::Model::Roles::ResultsUpdate', # do_[lab_tests/results_summary]_update()
'LIMS::Model::Roles::RequestUpdate',
'LIMS::Model::Roles::ReportUpdate', # also loads M::R::LabTestUpdate
# 'LIMS::Model::Roles::LabTestUpdate', # no need - loaded by M::R::ReportUpdate
);
use namespace::clean -except => 'meta';
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
for ( qw/lab_test_status_options_map/ );
has form_data => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
has result_updates => (
is => 'ro',
isa => 'ArrayRef[HashRef]',
default => sub { [] },
traits => ['Array'],
handles => {
add_to_updates => 'push',
count_updates => 'count',
},
);
has update_failures => (
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub { [] },
traits => ['Array'],
handles => {
add_to_failures => 'push',
count_failures => 'count',
},
);
__PACKAGE__->meta->make_immutable;
use Data::Dumper;
#-------------------------------------------------------------------------------
sub update_lab_test_requests { # called only by C::Result::Update()
my $self = shift;
my $data = shift; # $self->debug($data);
# put $dfv->valid into $self:
$self->form_data($data);
my $test_id = $data->{test_id} || []; # need $test_id to be arrayref:
if ($test_id) { # ensure it exists or will get autovivified (empty) arrayref
$test_id = [$test_id] if ref $test_id ne 'ARRAY';
}; # warn Dumper $test_id;
# if configured to expand panels to lab-tests:
if ( @$test_id && $data->{expand_panels} ) {
# to find array index position using List::MoreUtils::firstidx():
my $get_index = sub { LIMS::Local::Utils::get_first_index(@_) };
# get existing lab-tests (so we don't re-request if exempted):
my %requested_tests = do {
my @query = ( request_id => $data->{_request_id} );
my $o = LIMS::DB::RequestLabTestStatus::Manager
->get_objects( query => \@query );
map +($_->lab_test_id => 1), @$o;
}; # warn Dumper \%requested_tests;
ID: for my $id (@$test_id) { # warn $id;
# if $id in panel_lab_test, must be a panel, so replace in $test_id:
my $o = LIMS::DB::PanelLabTest::Manager
->get_objects( query => [ panel_test_id => $id ] );
next ID unless @$o;
# replace panel.id with lab-test.id(s) in $test_id arrayref:
my @required = map { $_->lab_test_id } # skip if already requested:
grep { ! $requested_tests{$_->lab_test_id} } @$o;
my $index = &$get_index($id, $test_id); # warn $index;
splice( @$test_id, $index, 1, @required ); # warn Dumper \@required;
}
} # warn Dumper $test_id;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update_lab_tests = sub {
if ( @$test_id ) { # add new investigation/test(s):
$self->do_new_lab_investigation($_) for @$test_id;
# check request_status, maybe revert from 'complete':
$self->do_request_status_check();
}
{ # insert/update section notes:
$self->do_section_notes_update();
}
{ # insert/update remote system id:
$self->do_foreign_id_update();
}
};
#$self->set_rose_debug(1);
# do_transaction() returns true if succeeds; sets $db->error on failure:
my $ok = $db->do_transaction( $update_lab_tests );
#$self->set_rose_debug(0);
return $ok ? 0 : 'update_lab_test_requests() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
# so far only used by do_bcr_abl() & do_chimerism() C::DataImport methods
# does auto_report if configured (do_bcr_abl):
sub update_results_summary {
my $self = shift;
my $args = shift; # hashref of LabSection object, request_id & result
my $request_id = $args->{request_id};
my $section = $args->{section}; # LabSection object
my $result = $args->{result};
# Roles::do_results_summary_update() requires _section_id, _section_name,
# _request_id & results_summary:
my %data = (
results_summary => $result,
_section_name => $section->section_name,
_request_id => $request_id,
_section_id => $section->id,
); # warn Dumper \%data;
# add auto_reportable_config if exists:
if ( my $auto_rpt_cfg = $args->{auto_reportable_config} ) {
$data{auto_reportable_config} = $auto_rpt_cfg; # for do_auto-report()
$data{lab_test_data} = $args->{lab_test_data}; # for set_lab_test_complete()
}
# put %data into $self for do_results_summary_update() & do_auto_report():
$self->form_data(\%data); # warn Dumper \%data;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
# reset arrays in case we're called in a loop (eg upload bcr-abl file):
$self->reset_actions;
$self->reset_request_lab_tests;
my $update = sub {
$self->do_results_summary_update();
$self->set_lab_test_complete();
# will silently skip if no config supplied or already reported
$self->do_auto_report();
die 'rollback now';
};
my $ok = $db->do_transaction($update);
return $ok ? 0 : 'update_results_summary() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_request_lab_test_results {
my ($self, $request_id) = @_;
my %args = (
query => [ request_id => $request_id ],
require_objects => 'lab_test',
);
my $lab_test_results = LIMS::DB::RequestLabTestResult::Manager
->get_request_lab_test_results(%args);
return $lab_test_results;
}
#-------------------------------------------------------------------------------
sub get_request_results_summary {
my $self = shift;
my $args = shift;
my %args = (
request_id => $args->{request_id},
lab_section_id => $args->{section_id},
);
my $results_summary = LIMS::DB::RequestResultSummary->new(%args);
# return row object if exists:
if (my $o = $results_summary->load_speculative) {
return $o;
}
return $results_summary;
}
#-------------------------------------------------------------------------------
sub get_section_lab_test_results {
my ($self, $vars) = @_; # warn Dumper $vars;
# get all test results for user-selected section:
my $results = $self->_section_lab_test_results($vars);
# get requests data for all entries in test results dataset:
my @request_ids = ( keys %$results );
return 0 unless @request_ids;
my @tables = qw( sample_code diagnoses results_summary );
my $relationships = $self->get_relationships(\@tables); # warn Dumper $relationships;
my $requests = LIMS::DB::Request::Manager->get_requests(
query => [ id => \@request_ids ],
require_objects => $relationships,
multi_many_ok => 1,
sort_by => [ qw(year request_number) ],
);
return 0 unless @$requests; # warn Dumper $requests->[0]->as_tree;
# create map of request.id => specimen(s):
my %request_specimen = map {
my $rs = $_->request_specimen; # always arrayref
$_->id => ( join ', ', map { $_->specimen->sample_code } @$rs );
} @$requests; # warn Dumper \%request_specimen;
# create map of request.id => { lab_section_id => result }
my %results_summary = ();
for my $request (@$requests) {
for (@{ $request->results_summary }) { # always arrayref
my $section_id = $_->lab_section_id;
my $result = $_->results_summary;
$results_summary{$request->id}{$section_id} = $result;
}
} # warn Dumper \%results_summary;
my $lab_section_id = $vars->{section_id};
# get lab test objects for lab section:
my @query = ( lab_section_id => $lab_section_id, test_type => 'test' );
my $tests = LIMS::DB::LabTest::Manager->get_lab_tests(
query => \@query,
sort_by => 'field_label',
);
my @fields = map $_->field_label, @$tests; # warn Dumper \@fields;
my @headers = ( qw/request year diagnosis specimen summary/, @fields );
my @data = map {
[ # arrayrefs for Spreadsheet::WriteExcel::Simple->write_row()
$_->request_number,
$_->year,
$_->request_report->diagnosis->name,
$request_specimen{$_->id}, # specimen(s)
$results_summary{$_->id}{$lab_section_id},
@{ $results->{$_->id} }{@fields}, # sort results in @fields order
]
} @$requests;
return { headers => \@headers, results => \@data };
}
sub _section_lab_test_results { # get all test results for user-selected section:
my ($self, $vars) = @_; # warn Dumper $vars;
my @query = ( 'lab_section_id' => $vars->{section_id} );
my @objects = 'lab_test'; # minimum require_objects item
if ( $vars->{date_from} || $vars->{date_to} ) { # optional constraints
my $dt = sub { LIMS::Local::Utils::to_datetime_using_parsedate(@_) };
# NB: silently fails if date is invalid:
if ( my $start = &$dt($vars->{date_from}) ) {
push @query, ( 'request.created_at' => { ge => $start } );
}
if ( my $end = &$dt($vars->{date_to}) ) {
my $date = $end->add(days => 1); # ie created_at <= midnight on date + 1
push @query, ( 'request.created_at' => { le => $date } );
}
push @objects, 'request';
}
if ( my $category_id = $vars->{category_id} ) { # optional constraint
my $str = 'request.request_report.diagnosis.icdo3_category';
push @query, ( "$str.diagnostic_category_id" => $category_id );
push @objects => $str,
} # warn Dumper \@query;
my @args = ( require_objects => \@objects, query => \@query );
my $results = LIMS::DB::RequestLabTestResult::Manager
->get_request_lab_test_results(@args);
my %h; # create hash of test results; key = request ID:
$h{$_->request_id}{$_->lab_test->field_label} = $_->result for @$results; # warn Dumper \%h;
return \%h;
}
#-------------------------------------------------------------------------------
sub general_notes { # uses Role::RequestUpdate::update_general_notes() method:
my $self = shift;
my $data = shift;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
$self->update_general_notes($data);
};
# do it as transaction to use Role::RequestUpdate method & capture any errs:
my $ok = $db->do_transaction( $update );
return $ok ? 0 : 'update_general_notes() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_status_option_count {
my ($self, $option_id) = @_;
my %args = (
query => [ status_option_id => $option_id ],
);
my $count = LIMS::DB::RequestLabTestStatus::Manager
->get_request_lab_test_status_count(%args);
return $count;
}
#-------------------------------------------------------------------------------
sub get_haematology_data {
my ($self, $request) = @_; # warn Dumper $request;
my $labno = sprintf '%02d_%05d',
$request->{year} - 2000, $request->{request_number};
my $data = LIMS::DB::RequestHaematology->new(lab_number => $labno)
->load_speculative;
return $data;
}
#-------------------------------------------------------------------------------
sub get_multiple_haem { # accepts list of lab_numbers in dd_ddddd format
my ($self, $requests) = @_;
my $data = LIMS::DB::RequestHaematology::Manager->get_objects(
query => [ lab_number => $requests, status => 'verified' ]
);
return $data;
}
#-------------------------------------------------------------------------------
sub accept_haematology_data {
my ($self, $args) = @_; # warn Dumper $args;
my $lab_number = $args->{lab_number}; # required
my $request_id = $args->{request_id}; # optional, only if registered
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached
my $update = sub {
my $o = LIMS::DB::RequestHaematology->new(lab_number => $lab_number)->load;
$o->status('verified');
$o->updated($self->time_now);
$o->save(changes_only => 1);
if ($request_id) { # only if request already registered
my %args = (
request_id => $request_id,
user_id => $self->user_profile->{id},
action => 'validated haematology data',
);
LIMS::DB::RequestLabTestHistory->new(%args)->save;
}
};
my $ok = $db->do_transaction( $update );
return $ok ? 0 : 'accept_haematology_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub delete_haematology_data {
my ($self, $args) = @_; # warn Dumper $args;
my $lab_number = $args->{lab_number}; # required
my $request_id = $args->{request_id}; # optional, only if registered
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached
my $delete = sub {
my $o = LIMS::DB::RequestHaematology->new(lab_number => $lab_number)->load;
$o->delete;
if ($request_id) { # only if request already registered
my %args = (
request_id => $request_id,
user_id => $self->user_profile->{id},
action => 'deleted haematology data',
);
LIMS::DB::RequestLabTestHistory->new(%args)->save;
}
};
my $ok = $db->do_transaction( $delete );
return $ok ? 0 : 'delete_haematology_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_request_lab_test_results {
my $self = shift;
my $data = shift; # warn Dumper $data;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $test_results = $data->{lab_test_results} || {}; # in case submitted empty to clear
my @lab_test_ids = keys %$test_results; # warn Dumper \@lab_test_ids;
$self->form_data($data); # for do_results_summary_update()
my $update = sub {
# first clear any existing test result data for this request_id:
if (@lab_test_ids) {
my %args = (
where => [
request_id => $data->{_request_id},
lab_test_id => \@lab_test_ids,
],
);
LIMS::DB::RequestLabTestResult::Manager
->delete_request_lab_test_results(%args);
{ # insert new data:
while ( my ($test_id, $result) = each %$test_results ) {
next unless $result; # warn Dumper($test_id, $result);
my %data = (
request_id => $data->{_request_id},
lab_test_id => $test_id,
result => $result,
);
LIMS::DB::RequestLabTestResult->new(%data)->save;
}
}
}
{ # insert/update results_summary:
$self->do_results_summary_update(); # all params as $self->param
}
# maybe set all section test/investigation(s) to 'complete':
if ( $data->{complete_all_tests} ) {
$self->do_complete_all_tests;
}
# last action - if auto_reportable config:
if ( $data->{auto_reportable_config} ) {
$self->do_auto_report();
}
};
my $ok = $db->do_transaction( $update );
return $ok ? 0 : 'update_results_data() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub check_request_lab_test { # just need to check lab-test been requested:
my $self = shift;
my $args = shift; # warn Dumper $args;
my $lab_test_data = $args->{lab_test_data}; # warn Dumper $lab_test_data;
my $request_id = $args->{request_id};
my $lab_test_id = $self->_get_lab_test_id($lab_test_data); # warn $lab_test_id;
my %params = (
lab_test_id => $lab_test_id,
request_id => $request_id,
);
my $o = LIMS::DB::RequestLabTestStatus->new(%params)->load(speculative => 1);
return $o ? 1 : 0; # just return success flag
}
#-------------------------------------------------------------------------------
sub import_results {
my $self = shift;
my $data = shift; # $self->debug($data);
# $data = hashref of report, result_summary & lab_test data + request_id:
my $result_data = $data->{result_summary_data};
my $lab_test_data = $data->{lab_test_data};
my $report_data = $data->{report_data};
my $request_id = $data->{request_id}; # warn $request_id;
my $user_profile_id = $self->user_profile->{id};
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $import = sub {
if ($lab_test_data) {
{ # update request_lab_test_status to complete:
my $date_acquired = $lab_test_data->{date_acquired}; # DT object
my $acquisition_userid = $lab_test_data->{acquisition_userid};
my $status_option = LIMS::DB::LabTestStatusOption
->new(description => 'complete')->load;
my $lab_test_id = $self->_get_lab_test_id($lab_test_data);
# load request_lab_test_status object on unique_key:
my %params = (
lab_test_id => $lab_test_id,
request_id => $request_id,
);
my $o = LIMS::DB::RequestLabTestStatus->new(%params)->load;
# update request_lab_test_status object:
$o->status_option_id($status_option->id);
$o->user_id($acquisition_userid);
$o->time($date_acquired);
$o->save(changes_only => 1);
}
{ # request_lab_test history:
my $acquisition_userid = $lab_test_data->{acquisition_userid};
my $lab_test_name = $lab_test_data->{lab_test_name};
my $action = "set $lab_test_name status to complete";
# if logged_in user id NOT same as datafile user id:
if ( $acquisition_userid != $user_profile_id ) {
my $user = uc $lab_test_data->{acquired_by};
$action .= " for $user";
}
my %args = (
request_id => $request_id,
user_id => $user_profile_id, # id of LOGGED IN USER HERE
action => $action,
);
LIMS::DB::RequestLabTestHistory->new(%args)->save;
}
}
{ # request_result_summaries:
my $results_summary = $result_data->{results_summary};
my $section_name = $result_data->{lab_section};
my $lab_section
= LIMS::DB::LabSection->new(section_name => $section_name)->load;
my %data = (
results_summary => $results_summary,
lab_section_id => $lab_section->id,
request_id => $request_id,
);
LIMS::DB::RequestResultSummary->new(%data)->save;
}
{ # results_summary histories:
my $lab_section = $result_data->{lab_section};
my $action = "new $lab_section result summary";
my %args = (
request_id => $request_id,
user_id => $user_profile_id, # id of LOGGED IN USER HERE
action => $action,
);
LIMS::DB::RequestLabTestHistory->new(%args)->save;
}
{ # report:
# add request_id & diagnosis_id directly to $report_data:
$report_data->{request_id} = $request_id;
# get diagnosis.id:
my $diagnosis_id = $self->_get_diagnosis_id($report_data);
$report_data->{diagnosis_id} = $diagnosis_id; # warn Dumper $report_data;
# load request_report_detail object:
my $r = LIMS::DB::RequestReportDetail->new(request_id => $request_id);
# add request_specimen_detail:
$r->request_specimen_detail( LIMS::DB::RequestSpecimenDetail->new );
# update request_report_detail & request_specimen_detail objects:
for my $o ($r, $r->request_specimen_detail) {
my @params = grep {
$o->meta->column($_)->type !~ /serial|timestamp|datetime/;
} $o->meta->column_names; # warn Dumper \@params;
COL: foreach my $param (@params) { # warn $param;
next COL if $param eq 'request_id'; # not supplied by form
my $val = $report_data->{$param} || next COL; # warn Dumper [$param, $val];
$o->$param($val);
}
}
$r->save(cascade => 1);
}
};
#$self->set_rose_debug(1);
my $ok = $db->do_transaction( $import );
#$self->set_rose_debug(0);
return $ok ? 0 : 'import_results() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
# shared by __PACKAGE__check_request_lab_test() & __PACKAGE__import_results()
sub _get_lab_test_id {
my $self = shift;
my $data = shift;
# lab_test has U.K. on field_label, lab_section_id & test_type
my $lab_section
= LIMS::DB::LabSection->new(section_name => $data->{lab_section})->load;
my %data = (
lab_section_id => $lab_section->id,
test_name => $data->{lab_test_name},
test_type => $data->{test_type}
);
my $lab_test = LIMS::DB::LabTest->new(%data)->load;
return $lab_test->id;
}
#-------------------------------------------------------------------------------
sub update_lab_tests_from_worklist {
my $self = shift;
my $data = shift; # $self->debug($data); # hashref
my $request_lab_test_ids = $data->{request_lab_test_ids};
my $status_option_id = $data->{status_option_id};
my $user_id = $data->{user_id};
# get map of lab_test_status_options:
my $status_option = $self->lab_test_status_options_map; # warn Dumper $status_option;
# get status from form submission:
my $status = $status_option->{$status_option_id}->{description}; # warn $status;
# get user profile:
my $user_profile = $self->user_profile;
# check user_id matches user_profile id, or get new user_profile:
if ($user_id != $user_profile->{id}) {
my $o = LIMS::DB::User->new(id => $user_id)->load;
$user_profile = $o->as_tree;
}
# get users' initials:
my @name = map $user_profile->{$_}, qw(first_name last_name);
my $initials = join '', map { $_ =~ /^(\w)/ } @name; # warn $inits;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update = sub {
LABTEST:
foreach my $id (@$request_lab_test_ids) {
my $o = LIMS::DB::RequestLabTestStatus->new(id => $id);
my @args = ( # need request for template display:
with => ['request','lab_test'],
speculative => 1,
);
if (! $o->load(@args) ) { # in case back-button & resubmit deletions:
$self->add_to_failures($id);
next LABTEST;
}
my $lab_test = $o->lab_test->field_label;
my $request_id = $o->request_id;
# update test status (even for delete - for template):
$o->status_option_id($status_option_id);
$o->user_id($user_id);
my $entry = $o->as_tree;
# if request to delete && success, add entry to result_updates:
if ( $status eq 'delete' ) {
# check no foreign key constraint ??
$self->add_to_updates($entry) if $o->delete;
}
# if update success, add entry to result_updates:
else {
$self->add_to_updates($entry) if $o->save(changes_only => 1);
}
{ # history log:
my $history = $status eq 'delete'
? "deleted $lab_test entry"
: "set $lab_test status to $status";
# if logged_in user id NOT same as submitted user id:
if ($self->user_profile->{id} != $user_profile->{id}) {
my $user = uc $user_profile->{username};
$history .= " for $user";
}
my %args = (
request_id => $request_id,
user_id => $self->user_profile->{id}, # id of LOGGED IN USER HERE
action => $history,
);
LIMS::DB::RequestLabTestHistory->new(%args)->save;
}
}
};
my $ok = $db->do_transaction($update);
=begin # causes error after search involving a date field - "error" stays in system
if (my $err = $db->error) {
return { error => 'update_lab_tests_from_worklist() error - ' . $err };
}
else {
return {
updates => $self->result_updates,
success => $self->count_updates,
failures => $self->count_failures,
};
}
=cut
if ($ok) {
return {
updates => $self->result_updates,
success => $self->count_updates,
failures => $self->count_failures,
};
}
else {
my $err = $db->error;
return { error => 'update_lab_tests_from_worklist() error - ' . $err };
}
}
#-------------------------------------------------------------------------------
sub get_results_summary_options {
my $self = shift;
my %args = (
sort_by => 'description',
require_objects => 'lab_section',
);
my $results_summary_options = LIMS::DB::ResultSummaryOption::Manager
->get_result_summary_options(%args);
return $results_summary_options;
}
#-------------------------------------------------------------------------------
sub get_result_data_type {
my ($self, $data_type_id) = @_;
my $data_type
= LIMS::DB::LabTestResultDataType->new(id => $data_type_id)->load;
return $data_type;
}
# ------------------------------------------------------------------------------
sub update_result_data_type {
my $self = shift;
my $data = shift; # $self->debug( $data );
my %args = ( class => 'LabTestResultDataType', data => $data );
return $self->update_object(\%args);
}
#-------------------------------------------------------------------------------
sub get_results_summary_option {
my ($self, $option_id) = @_;
my $option = LIMS::DB::ResultSummaryOption->new(id => $option_id)->load;
return $option;
}
#-------------------------------------------------------------------------------
sub get_results_summary_options_for_section {
my ($self, $section_id) = @_;
my %args = (
query => [ lab_section_id => $section_id ],
sort_by => 'description',
# require_objects => 'lab_section',
);
my $results_summary_options = LIMS::DB::ResultSummaryOption::Manager
->get_result_summary_options(%args);
return $results_summary_options;
}
# ------------------------------------------------------------------------------
sub update_result_summary_options {
my $self = shift;
my $data = shift; # $self->debug( $data );
my %args = ( class => 'ResultSummaryOption', data => $data );
return $self->update_object(\%args);
}
#-------------------------------------------------------------------------------
sub _get_diagnosis_id {
my $self = shift;
my $data = shift;
my $diagnosis = LIMS::DB::Diagnosis->new(name => $data->{diagnosis})->load;
# delete unrequired 'diagnosis' key:
delete $data->{diagnosis};
return $diagnosis->id;
}
#-------------------------------------------------------------------------------
sub _build_lab_test_status_options_map {
my $self = shift;
my $o = LIMS::DB::LabTestStatusOption::Manager->get_lab_test_status_options;
my %map = map {
$_->id => $_->as_tree;
} @$o;
return \%map;
}
1;
