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; # warn Dumper $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 (unless exempt), maybe revert from 'complete': $self->do_request_status_check() unless $data->{retain_req_status}; } { # 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(); }; 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_all_previous_tests_and_results { my ($self, $patient_id) = @_; =begin joining results table too complex for RDBO my @rels = ( 'request.patient_case.patient', 'lab_test.lab_section', 'status', ); my @query = ( nhs_number => $nhs_number, 'status.description' => { ne => 'delete '}, ); my $o = LIMS::DB::RequestLabTestStatus::Manager->get_objects( query => \@query, sort_by => [ 'request.year', 'request.request_number' ], require_objects => \@rels, nested_joins => 0, # with_objects => 'request.lab_tests', # not correct ); =cut my $dbix = $self->lims_dbix; my @data = do { my $sql = $self->sql_lib->retr('all_previous_lab_tests_and_results'); $dbix->query( $sql, $patient_id )->hashes; }; my %h; for my $ref (@data) { # warn Dumper $ref; next; my $test_name = $ref->{field_label}; my $section = $ref->{section_name}; my $test_id = $ref->{lab_test_id}; $self->inflate_mysql_dates_to_datetime($ref, ['test_date']); # replaces date with dt push @{ $h{$test_name}{$section} }, $ref; } return \%h; } #------------------------------------------------------------------------------- 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 - moved out my $relationships = $self->get_relationships(\@tables); # warn Dumper $relationships; my $requests = LIMS::DB::Request::Manager->get_requests( query => [ id => \@request_ids ], require_objects => $relationships, 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_summaries; { my @query = ( request_id => \@request_ids, lab_section_id => $vars->{section_id}, ); my $o = LIMS::DB::RequestResultSummary::Manager->get_objects( query => \@query, with_objects => 'lab_section', ); $results_summaries{$_->request_id} = $_->results_summary for @$o; }; my $lab_section_id = $vars->{section_id}; # get lab test objects for lab section: my $tests = do { my @query = ( lab_section_id => $lab_section_id, test_type => 'test' ); LIMS::DB::LabTest::Manager->get_lab_tests( query => \@query, sort_by => 'field_label', ); }; # warn Dumper $tests; 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_summaries{$_->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; $self->form_data($data); my $db = $self->lims_db; # ie LIMS::DB->new_or_cached; my $update = sub { $self->update_general_notes($data); $self->do_request_history; }; # 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; } # or, maybe set resulted lab-test(s) status to complete: elsif ( $data->{test_status_complete} ) { # just lab test id's with a result: my @test_ids = grep $test_results->{$_}, keys %$test_results; $self->do_complete_selected_tests(\@test_ids) if @test_ids; } # 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;