package LIMS::Model::Local; use Moose; extends 'LIMS::Model::Base'; with 'LIMS::Model::Roles::QueryFormatter'; use namespace::clean -except => 'meta'; __PACKAGE__->meta->make_immutable; use Data::Dumper; #------------------------------------------------------------------------------- sub get_unregistered_requests { my $self = shift; my %args = ( query => [ is_screened => 'no' ], with_objects => 'pre_registration_specimen', # need left join here ); my $data = LIMS::DB::PreRegistration::Manager->get_pre_registration(%args); return $data; } #------------------------------------------------------------------------------- sub get_unregistered_request { my ($self, $prereg_id) = @_; my $data = LIMS::DB::PreRegistration->new(id => $prereg_id)->load; return $data; } #------------------------------------------------------------------------------- sub get_prereg_specimens { my ($self, $prereg_id) = @_; my %args = ( query => [ pre_reg_id => $prereg_id ], ); my $data = LIMS::DB::PreRegistrationSpecimen::Manager ->get_pre_registration_specimens(%args); return $data; } #------------------------------------------------------------------------------- sub get_unregistered_request_lab_tests { my $self = shift; # prereg_specimen_id can be scalar or arrayref: my $prereg_specimen_id = shift; my %map; my %args = ( query => [ reg_specimen_id => $prereg_specimen_id ], require_objects => 'lab_test', ); my $data = LIMS::DB::PreRegistrationLabTest::Manager ->get_pre_registration_lab_tests(%args); for my $prereg_test (@$data) { my $reg_specimen_id = $prereg_test->reg_specimen_id; my $test_name = $prereg_test->lab_test->test_name; $map{$reg_specimen_id}{$test_name} = 1; # just register it } return \%map; } #------------------------------------------------------------------------------- sub get_unregistered_request_specimen { my ($self, $reg_specimen_id) = @_; my $data = LIMS::DB::PreRegistrationSpecimen ->new(id => $reg_specimen_id)->load(with => 'pre_reg'); return $data; } #------------------------------------------------------------------------------- sub update_pre_registration_data { my $self = shift; my $data = shift; # warn Dumper $data; my $lab_section_id = $data->{lab_section_id}; my $lab_tests_map = $self->_get_lab_tests_map($lab_section_id); my $db = $self->lims_db; # ie LIMS::DB->new_or_cached; my $update = sub { # update pre_registration table: my $pre_reg = LIMS::DB::PreRegistration->new( labno => $data->{labno}, )->load; $pre_reg->surname($data->{surname}); $pre_reg->save( changes_only => 1 ); # create new pre_registration_specimen entry: my $rs = LIMS::DB::PreRegistrationSpecimen->new( pre_reg_id => $pre_reg->id, specimen_code => $data->{specimen}, )->save; # lab_tests: while ( my($test_name, $lab_test) = each %$lab_tests_map ) { next unless $data->{$test_name}; # skip if not in $data LIMS::DB::PreRegistrationLabTest->new( reg_specimen_id => $rs->id, lab_test_id => $lab_test->{id}, )->save; } }; my $ok = $db->do_transaction($update); return $ok ? 0 : 'update_pre_registration_data() error - ' . $db->error; } #------------------------------------------------------------------------------- sub update_pre_registration_specimen_data { my $self = shift; my $data = shift; # warn Dumper $data; my $lab_section_id = $data->{lab_section_id}; my $lab_tests_map = $self->_get_lab_tests_map($lab_section_id); my $db = $self->lims_db; # ie LIMS::DB->new_or_cached; my $update = sub { # get registration_specimen object: my $rs = LIMS::DB::PreRegistrationSpecimen->new(id => $data->{id})->load; # get pre_registration object: my $pre_reg = LIMS::DB::PreRegistration->new(id => $rs->pre_reg_id)->load; # update pre_registration table (if necessary): if ($data->{surname} ne $pre_reg->surname) { $pre_reg->surname($data->{surname}); $pre_reg->save; } # update pre_registration_specimen table (if necessary): if ($data->{specimen} ne $rs->specimen_code) { $rs->specimen_code($data->{specimen}); $rs->save; } { # clear pre_registration_lab_test table: my %args = ( where => [ reg_specimen_id => $data->{id} ], ); LIMS::DB::PreRegistrationLabTest::Manager ->delete_pre_registration_lab_tests(%args); while ( my($test_name, $lab_test) = each %$lab_tests_map ) { next unless $data->{$test_name}; # skip if not in $data LIMS::DB::PreRegistrationLabTest->new( reg_specimen_id => $data->{id}, lab_test_id => $lab_test->{id}, )->save; } } }; my $ok = $db->do_transaction($update); return $ok ? 0 : 'update_pre_registration_data() error - ' . $db->error; } #------------------------------------------------------------------------------- sub new_pre_registration_data { my $self = shift; my $data = shift; # warn Dumper $data; my $lab_section_id = $data->{lab_section_id}; my $lab_tests_map = $self->_get_lab_tests_map($lab_section_id); my $db = $self->lims_db; # ie LIMS::DB->new_or_cached; my $new_data = sub { # save pre_registration_specimen data: my $prereg_specimen = LIMS::DB::PreRegistrationSpecimen->new( pre_reg_id => $data->{id}, specimen_code => $data->{specimen}, )->save; # save pre_registration_lab_test data: while ( my($test_name, $lab_test) = each %$lab_tests_map ) { next unless $data->{$test_name}; # skip if not in $data LIMS::DB::PreRegistrationLabTest->new( reg_specimen_id => $prereg_specimen->id, # new prereg_specimen lab_test_id => $lab_test->{id}, )->save; } }; my $ok = $db->do_transaction($new_data); return $ok ? 0 : 'new_pre_registration_data() error - ' . $db->error; } #------------------------------------------------------------------------------- sub has_previous_data { my ($self, $args) = @_; my $request = $args->{request}; my $screen = $args->{screen}; my $patient_id = $request->patient_case->patient_id; my %args = ( require_objects => [ qw(patient_case.patient request_initial_screen.screen) ], query => [ 'requests.id' => { lt => $request->id }, patient_id => $patient_id, description => $screen, ], ); # need at least 1 previous dataset on same patient: my $i = LIMS::DB::Request::Manager->get_requests_count(%args); return $i; } #------------------------------------------------------------------------------- sub get_selected_request_lab_test_results { my ($self, $params) = @_; my %args = ( query => [ %$params ], require_objects => 'lab_test', ); my $lab_test_results = LIMS::DB::RequestLabTestResult::Manager ->get_request_lab_test_results(%args); return $lab_test_results; } #------------------------------------------------------------------------------- sub update_histology_data { my $self = shift; my $data = shift; # warn Dumper $data; my $user_profile = $self->user_profile; my $lab_test = LIMS::DB::LabTest->new(id => $data->{lab_test_id})->load; my $field_label = $lab_test->field_label; my $lab_section_id = $data->{lab_section_id}; my $user_id = $data->{user_id}; my $alias; unless ( $user_id == $user_profile->{id} ) { $alias = LIMS::DB::User->new(id => $user_id)->load; } # get status options for lab_section: my $status_options = $self->_get_lab_section_status_options($lab_section_id); my $lab_tests = $self->_get_lab_tests_map($lab_section_id); my $db = $self->lims_db; # ie LIMS::DB->new_or_cached; my $update = sub { # update request_lab_test_history table for my $option (@$status_options) { next unless $data->{$option}; my $action = "set $field_label status to $option"; if ( $alias ) { # ie data entered on behalf of different user $action .= sprintf ' for %s', uc $alias->username; } my %data = ( request_id => $data->{request_id}, user_id => $user_profile->{id}, action => $action, ); LIMS::DB::RequestLabTestHistory->new(%data)->save; # update request_lab_test_status if 'complete': if ($option eq 'complete') { # get status option for 'complete': my $status_option = LIMS::DB::LabTestStatusOption ->new(description => 'complete')->load; my %data = ( request_id => $data->{request_id}, lab_test_id => $data->{lab_test_id}, ); my $o = LIMS::DB::RequestLabTestStatus->new(%data)->load; # update status option & user_id: $o->status_option_id($status_option->id); $o->user_id($user_profile->{id}); $o->save(changes_only => 1); } } # update test results: TEST: while ( my($test_name, $lab_test) = each %$lab_tests ) { next TEST unless $lab_test->{has_results} eq 'yes'; # skip unless resultable next TEST unless $data->{$test_name}; # skip unless data input - so can't remove my %data = ( request_id => $data->{request_id}, lab_test_id => $lab_test->{id}, ); # warn Dumper \%data; my $o = LIMS::DB::RequestLabTestResult->new(%data); my $action; if ( $o->load(speculative => 1) ) { my $old_result = $o->result; next TEST if $old_result eq $data->{$test_name}; $o->result($data->{$test_name}); $o->save(changes_only => 1); $action = sprintf 'updated %s result [%s -> %s]', $lab_test->{field_label}, $old_result, $data->{$test_name}; } else { $o->result($data->{$test_name}); $o->save; $action = "entered new $lab_test->{field_label} result"; } { # log changes: my %data = ( request_id => $data->{request_id}, user_id => $user_profile->{id}, action => $action, ); LIMS::DB::RequestLabTestHistory->new(%data)->save; } } }; my $ok = $db->do_transaction($update); return $ok ? 0 : 'update_histology_data() error - ' . $db->error; } #------------------------------------------------------------------------------- sub update_histology_blocks { my ($self, $data) = @_; my $db = $self->lims_db; # ie LIMS::DB->new_or_cached; my $request_ids = $data->{request_ids}; my $status = $data->{status}; my $user_profile = $self->user_profile; my $update = sub { # update request_external_ref table for my $id (@$request_ids) { my $o = LIMS::DB::RequestExternalRef->new(request_id => $id)->load; $o->status($status); $o->save(changes_only => 1); { # log changes: my %data = ( request_id => $id, user_id => $user_profile->{id}, action => 'returned blocks', ); LIMS::DB::RequestLabTestHistory->new(%data)->save; } } }; my $ok = $db->do_transaction($update); return $ok ? 0 : 'update_histology_blocks() error - ' . $db->error; } #------------------------------------------------------------------------------- sub _get_lab_section_status_options { my ($self, $lab_section_id) = @_; my %q = ( query => [ lab_section_id => $lab_section_id ], require_objects => 'status_option', ); my $o = LIMS::DB::LabSectionStatusOption::Manager ->get_lab_section_status_option(%q); my @options = map { $_->status_option->description; } @$o; push @options, 'complete'; # need this also return \@options; } #------------------------------------------------------------------------------- sub _get_lab_tests_map { my ($self, $lab_section_id) = @_; # get available lab_tests for pre_screen: my %args = ( query => [ lab_section_id => $lab_section_id, is_active => 'yes', ], ); my $lab_tests = LIMS::DB::LabTest::Manager->get_lab_tests(%args); my %lab_test_map = map { $_->test_name => $_->as_tree, } @$lab_tests; # warn Dumper \%lab_test_map; return \%lab_test_map; } 1;