package LIMS::Model::Request;
use Moose;
extends 'LIMS::Model::Base';
with (
'LIMS::Model::Roles::Query',
'LIMS::Model::Roles::DBIxSimple',
'LIMS::Model::Roles::RequestUpdate',
'LIMS::Model::Roles::ScreenUpdate', # auto_screen
'LIMS::Model::Roles::HistoryAction',
);
use namespace::clean -except => 'meta';
has frozen_data => ( is => 'rw', isa => 'HashRef');
has form_data => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
has archive => (
is => 'ro',
isa => 'ArrayRef[HashRef]',
default => sub { [] },
lazy => 1,
traits => ['Array'],
handles => {
add_to_archive => 'push',
archived_data => 'elements',
},
);
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
for qw(
specimen_map
referral_type_map
specimen_lab_test_map
request_status_options_map
);
__PACKAGE__->meta->make_immutable;
use Data::Dumper;
use LIMS::Local::Utils;
#-------------------------------------------------------------------------------
sub new_request {
my $self = shift;
my $data = shift; # warn Dumper $data; # return;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
# extract request, options & consent data from $data:
my $request_data = $self->_get_request_data($data);
my $trial_data = $self->_get_clinical_trial_data($data);
# get specimens table iterator:
my $specimen = LIMS::DB::Specimen::Manager
->get_specimens_iterator(sort_by => 'sample_code');
# get specimen -> lab_test map (for any auto-generated lab tests):
my $specimen_lab_test_map = $self->specimen_lab_test_map;
# get consent_options iterator:
my $consent_options = LIMS::DB::ConsentOption::Manager
->get_consent_options_iterator();
# get additional_options table iterator:
my $request_options = LIMS::DB::AdditionalOption::Manager
->get_additional_options_iterator();
# extract specimens from $data->{specimen}:
my $specimens = LIMS::Local::Utils::get_specimens($data->{specimen}); # warn Dumper $specimens;
# have rare instances of no entry in request_specimen table (solved 3/1/13 - BMAT.PB & RDBO <0.802):
if (@$specimens) { # if any entry in @$specimens doesn't exist in specimens_map:
my $map = $self->specimen_map;
$map->{$_} || die "cannot find id for $_" for @$specimens; # cannot find id for BMAT.PB - 3/1/13
} # warn Dumper \@$specimens;
else { # will also capture undef $data->{specimen} - which should be impossible
die sprintf q!cannot parse specimen entry '%s'!, $data->{specimen};
}
my $user_id = $self->user_profile->{id};
# create new request in transaction:
my $new_request = sub {
# save request_data to request table 1st so we can get request.id:
my $request = LIMS::DB::Request->new(%$request_data);
$request->save;
# request_history:
$self->add_to_actions('registered');
# cycle specimens iterator, adding specimen_id to request_specimen table:
while ( my $o = $specimen->next ) {
next unless grep { $o->sample_code eq $_ } @$specimens; # DEBUG $o->sample_code;
LIMS::DB::RequestSpecimen->new(
request_id => $request->id,
specimen_id => $o->id,
)->save;
# add new lab-tests if specimen requires:
my %data = (
request_id => $request->id,
specimen => $o,
);
$self->do_specimen_associated_lab_tests(\%data); # M::R::LabTestUpdate
}
# clinical trial:
if ( my $trial_id = $trial_data->{trial_id} ) {
LIMS::DB::RequestTrial->new(
trial_id => $trial_id,
request_id => $request->id,
)->save;
# trial_number - should not be submitted without trial_id:
if ( my $trial_number = $trial_data->{trial_number} ) {
# update existing or create new patient trial data:
LIMS::DB::PatientTrial->new(
patient_id => $trial_data->{patient_id},
trial_number => $trial_number,
trial_id => $trial_id,
)->insert_or_update;
}
}
# consent data:
while ( my $o = $consent_options->next ) {
my $option_name = $o->consent_name;
next unless $data->{$option_name};
LIMS::DB::RequestConsent->new(
status => $data->{$option_name},
request_id => $request->id,
consent_id => $o->id,
)->save;
}
# error codes:
if ( my $error_code_id = $data->{error_code_id} ) {
my %data = (
request_id => $request->id,
user_id => $user_id,
);
# get error_code_ids as an arrayref (if not already):
my $codes = ref $error_code_id eq 'ARRAY'
? $error_code_id : [ $error_code_id ];
my %err_codes_map = do {
my $o = LIMS::DB::ErrorCode::Manager->get_error_codes;
map +($_->id => $_->code), @$o;
}; # warn Dumper \%err_codes_map;
for my $code(@$codes) {
$data{error_code_id} = $code;
LIMS::DB::RequestErrorCode->new(%data)->save;
my $msg = 'recorded error code '. uc $err_codes_map{$code};
$self->add_to_actions($msg);
}
}
# cycle request_options iterator, adding additional_option_id to request_options table:
while ( my $o = $request_options->next ) {
my $option_name = $o->option_name;
next unless $data->{$option_name};
LIMS::DB::RequestOption->new(
request_id => $request->id,
option_id => $o->id,
)->save;
}
# external_reference:
if ( my $ref = $data->{external_reference} ) {
LIMS::DB::RequestExternalRef->new(
request_id => $request->id,
external_reference => $ref,
)->save;
}
$data->{_request_id} = $request->id;
$self->form_data($data); # save form_data for ScreenUpdate & HistoryAction Role methods
# auto-screen (if configured):
if ($data->{auto_screen_config}) { # warn Dumper $data->{auto_screen_config};
$self->do_auto_screen() # Roles::ScreenUpdate
}
$self->do_request_history(); # commit actions to request_history table
};
# do_transaction() returns true if succeeds; sets $db->error on failure:
my $ok = $db->do_transaction($new_request);
return $ok ? 0 : 'new_request() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub get_requests_count {
my $self = shift;
my ($request_number, $year) = @_;
my %args = (
query => [
request_number => $request_number,
year => $year || DateTime->now->year,
],
);
my $total = LIMS::DB::Request::Manager->get_requests_count(%args);
return $total;
}
#-------------------------------------------------------------------------------
sub count_biohazard_records {
my ($self, $args) = @_; # warn Dumper $args; # hashref
my %args = (
query => [ # any other doi's:
'option_name' => 'doi',
'patient_case.patient_id' => $args->{patient_id},
],
require_objects => [ 'patient_case', 'request_option.option' ],
);
my $i = LIMS::DB::Request::Manager->get_requests_count(%args);
return $i;
}
#-------------------------------------------------------------------------------
sub get_previous_diagnoses {
my ($self, $request_id) = @_;
my %args = (
query => [ request_id => $request_id ],
require_objects => [ 'user', 'diagnosis', 'option' ],
sort_by => 'time',
);
my $o = LIMS::DB::RequestDiagnosisHistory::Manager
->get_request_diagnosis_histories(%args);
return $o;
}
#-------------------------------------------------------------------------------
# gets request.id if $n == 1:
sub get_request_id {
my ($self, $search_constraints) = @_;
my $formatted_args = $self->get_args_for_request_id($search_constraints);
my $request = LIMS::DB::Request::Manager->get_requests(%$formatted_args);
my $request_id;
eval { # should never fail, but JIC
$request_id = $request->[0]->id;
}; warn 'request_id is undefined' unless $request_id; # happened once when request_specimen empty - how???
return $request_id; # will return undef if $request is empty arrayref
}
#-------------------------------------------------------------------------------
# called by Search::do_search() to find number of requests matching search criteria:
sub search_requests_count {
my ($self, $search_constraints) = @_; # warn Dumper $search_constraints;
my $formatted_args
= $self->get_args_for_requests_count($search_constraints); # warn Dumper $formatted_args;
#$self->set_rose_debug(1);
my $total = LIMS::DB::Request::Manager->get_requests_count(%$formatted_args);
#$self->set_rose_debug(0);
return $total;
}
#-------------------------------------------------------------------------------
# called by Search::do_search() to retrieve records matching search criteria for n > 1:
sub find_requests {
my $self = shift;
my $args = shift; # hashref with keys = 'search_constraints' & 'args_for_search'
# get query, with_objects, require_objects, etc from $args:
my $formatted_args = $self->get_args_for_find_requests($args); # warn Dumper $formatted_args;
#$self->set_rose_debug(1);
my $requests = LIMS::DB::Request::Manager->get_requests(%$formatted_args);
#$self->set_rose_debug(0);
return $requests;
}
#-------------------------------------------------------------------------------
# accepts request.id & returns all required request data:
sub get_single_request {
my ($self, $request_id) = @_; # warn $request_id;
# check it exists 1st (in case user input of request_id into url):
$self->_verify_request_exists($request_id) || return 0;
# require data from these tables:
my @tables = qw(
patients
referrers
diagnoses
patient_notes
status_options
clinical_trials
referral_sources
secondary_diagnosis
request_external_ref
hospital_departments
request_general_notes
request_initial_screen
);
my $relationships = $self->get_relationships(\@tables);
#$self->set_rose_debug(1);
my $request
= LIMS::DB::Request->new(id => $request_id)->load(with => $relationships);
#$self->set_rose_debug(0);
return $request;
}
#-------------------------------------------------------------------------------
# get request_id's from yy_nnnnn formatted lab numbers:
sub get_request_id_from_lab_number {
my ($self, $ref) = @_; # arrayref of lab_numbers
# reject any lab_numbers not nn_nnnnn format (don't expect any):
my @lab_numbers = grep $_ =~ /\d{2}_\d{5}/, @$ref; # warn Dumper @lab_numbers;
# need to do sql query not supported by RDBO:
my $dbix = $self->lims_dbix;
# to search for, and retrieve, using nn_nnnnn format:
my $cws = q!CONCAT_WS( '_', RIGHT(year, 2), LPAD(request_number, 5, 0) )!;
# SELECT CONCAT_WS( '_', RIGHT(year, 2), LPAD(request_number, 5, 0) ), id
# FROM requests WHERE CONCAT_WS( '_', RIGHT(year, 2), LPAD(request_number, 5, 0) )
# IN (??)
my %where = ( $cws => { in => \@lab_numbers } );
my $data = $dbix->select('requests', [$cws, 'id'], \%where)->map; # warn Dumper $data;
return $data;
}
#-------------------------------------------------------------------------------
# finds previous requests on current request nhs_number or patient id:
sub get_previous_requests {
my $self = shift;
my $args = shift; # hashref of args for query (eg nhs_number => 123, etc)
# require data from these tables:
my @tables = qw( patients diagnoses );
my $relationships = $self->get_relationships(\@tables);
my %params = (
query => [ %$args ],
require_objects => $relationships,
sort_by => 'year DESC, request_number DESC',
nested_joins => 0,
);
my $records = LIMS::DB::Request::Manager->get_requests_iterator(%params);
return $records;
}
#-------------------------------------------------------------------------------
sub get_request_options {
my ($self, $request_id) = @_; # warn $request_id;
my %args = (
query => [ request_id => $request_id ],
require_objects => 'option',
);
my $request_options
= LIMS::DB::RequestOption::Manager->get_request_options(%args);
return $request_options;
}
#-------------------------------------------------------------------------------
sub get_request_report_diagnosis {
my ($self, $request_id) = @_; # warn $request_id;
my %args = (
query => [ request_id => $request_id ],
require_objects => 'request_report.diagnosis',
);
my $request_diagnosis =
ref $request_id eq 'ARRAY' # can handle either single or list
? LIMS::DB::Request::Manager->get_requests(%args)
: LIMS::DB::Request->new(request_id => $request_id)
->load(with => 'request_report.diagnosis');
return $request_diagnosis;
}
#-------------------------------------------------------------------------------
sub get_request_consent {
my ($self, $request_id) = @_; # warn $request_id;
my %args = (
query => [ request_id => $request_id ],
require_objects => 'consent',
);
my $request_consent
= LIMS::DB::RequestConsent::Manager->get_request_consents(%args);
return $request_consent;
}
=begin #------------------------------------------------------------------------
sub get_referrer_department { # was used by mail_reports.pl - ? remove if not used
my ($self, $request_id) = @_; # warn $request_id;
my @rels = qw(
referrer_department.referrer
referrer_department.hospital_department
);
my $request
= LIMS::DB::Request->new(id => $request_id)->load(with => \@rels);
return $request->as_tree;
}
=cut
#-------------------------------------------------------------------------------
sub get_request_errors {
my ($self, $request_id) = @_; # warn $request_id;
my %args = (
query => [ request_id => $request_id ],
require_objects => [ 'error_code', 'user' ],
);
my $request_errors
= LIMS::DB::RequestErrorCode::Manager->get_request_error_codes(%args);
return $request_errors;
}
#-------------------------------------------------------------------------------
sub get_request_error_code {
my ($self, $id) = @_; # warn $id;
my $err = LIMS::DB::RequestErrorCode->new(id => $id)
->load(with => [ 'error_code', 'user' ]);
return $err;
}
#-------------------------------------------------------------------------------
sub delete_request_error_code {
my ($self, $id) = @_; # warn $id;
my $delete = sub {
my $o = LIMS::DB::RequestErrorCode->new(id => $id)
->load( with => 'error_code' );
my $request_id = $o->request_id;
$o->delete;
$self->add_to_actions('deleted error code ' . uc $o->error_code->code);
$self->do_history_log({ _request_id => $request_id });
};
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $result = $db->do_transaction( $delete );
# don't need return value unless error:
return $result ? 0 : 'error in delete_request_error_code() - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub request_error_code {
my $self = shift;
my $data = shift; # warn Dumper $data;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my %args = ( _request_id => $data->{request_id} ); # do_request_error_code() format
my $error = sub {
if ($data->{LIC}) {
$self->add_to_actions('completed LIC');
}
if ( my $error_code_id = $data->{error_code_id} ) {
$args{error_code_id} = $error_code_id;
$self->do_request_error_code(\%args);
}
# log history:
$self->do_history_log(\%args);
};
my $result = $db->do_transaction( $error );
# don't need return value unless error:
return $result ? 0 : 'error in new_request_error() - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub edit_request_error_code {
my $self = shift;
my $data = shift; # warn Dumper $data;
my $error_code_id = $data->{error_code_id};
# get error_code object:
my $error_code = LIMS::DB::ErrorCode->new(id => $error_code_id)->load;
# edit request_error_code entry:
my $edit = sub {
my $o = LIMS::DB::RequestErrorCode->new(id => $data->{id})
->load( with => 'error_code' );
# add to actions for history log:
my $msg = sprintf 'updated error code %s to %s',
uc $o->error_code->code, uc $error_code->code; # old -> new
$self->add_to_actions($msg);
$o->error_code_id($error_code_id); # change it
$o->save(changes_only => 1); # save it
$self->do_history_log({ _request_id => $o->request_id }); # log it
};
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $result = $db->do_transaction( $edit );
# don't need return value unless error:
return $result ? 0 : 'error in edit_request_error_code() - ' . $db->error;
}
#-------------------------------------------------------------------------------
# basic version of get_single_request() - just gets request & patient data:
sub get_patient_and_request_data {
my ($self, $param) = @_; # warn $param;
my @args =
ref $param eq 'ARRAY'
? @$param # eg request_number => nn, year => yyyy
: (id => $param); # assume request.id passed if $param is scalar
my $data
= LIMS::DB::Request->new(@args)->load(with => 'patient_case.patient');
return $data;
}
#-------------------------------------------------------------------------------
# gets basic request summary data (req, patient, referral) for multiple request_ids:
sub requests_summary_data {
my ($self, $request_ids) = @_; # arrayref
my @tables = # for packs & letters dispatches
qw( referral_sources patient_practices outreach_pack_dispatches );
my $relationships = $self->get_relationships(\@tables);
my @args = (
query => [ id => $request_ids ],
require_objects => $relationships,
);
my $data = LIMS::DB::Request::Manager->get_requests(@args);
return $data;
}
#-------------------------------------------------------------------------------
sub get_section_notes {
my ($self, $request_id) = @_;
my %args = (
query => [ request_id => $request_id ],
);
my $section_notes = LIMS::DB::RequestLabSectionNote::Manager
->get_request_lab_section_notes(%args);
return $section_notes;
}
#-------------------------------------------------------------------------------
sub get_laboratory_number {
my ($self, $request_id) = @_;
my $request = LIMS::DB::Request->new(id => $request_id)->load;
my $lab_number = join '/',
$request->request_number,
sprintf '%02d', $request->year - 2000;
return $lab_number;
}
#-------------------------------------------------------------------------------
sub get_request {
my ($self, $request_id) = @_;
my $request = LIMS::DB::Request->new(id => $request_id)->load;
return $request;
}
#-------------------------------------------------------------------------------
sub get_requests {
my ($self, $request_id) = @_; # arrayref
my $requests = LIMS::DB::Request::Manager->get_requests(
query => [ id => $request_id ] );
return $requests;
}
#-------------------------------------------------------------------------------
sub get_request_dispatch_logs {
my ($self, $request_id) = @_;
my $logs = LIMS::DB::RequestDispatchLog::Manager->get_request_dispatch_logs(
query => [ request_id => $request_id ]
);
return $logs;
}
#-------------------------------------------------------------------------------
# how many requests 'have' this patient_case.id ?
sub get_patient_case_requests_count {
my $self = shift;
my $case_id = shift;
my $requests_count = LIMS::DB::Request::Manager->get_requests_count(
query => [ patient_case_id => $case_id ],
);
return $requests_count;
}
#-------------------------------------------------------------------------------
sub get_new_and_relapsed_cases {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $duration = $args->{duration};
my $org_code = $args->{org_code}; # optional - not supplied for 'all locations'
my $delta =
$self->time_now->subtract( days => $duration )->truncate( to => 'day' );
# set status level required for displaying reports:
my $report_status = $self->does_authorisation() ? 'authorised' : 'reported';
my @query = (
'request_report.status' => { ne => 'default' },
'request_history.time' => { ge => $delta },
'request_history.action' => $report_status, # reported or authorised
);
push @query, ( parent_code => $org_code ) if $org_code; # ie not 'all locations'
# have split this into 2 queries as original was far too slow - up to 30 secs !!
my @tables = qw( request_report parent_organisations request_history );
my $relationships = $self->get_relationships(\@tables);
my @params = (
select => 'id', # only need request.id - used in 2nd query
query => \@query,
require_objects => $relationships,
);
my $cases = LIMS::DB::Request::Manager->get_requests(@params);
return undef unless @$cases; # warn Dumper $_->as_tree for @$cases;
{
my @request_ids = map +($_->id), @$cases; # warn Dumper \@request_ids;
my @tables = qw( patients referral_sources diagnoses request_status );
my $relationships = $self->get_relationships(\@tables);
my @query = (
id => \@request_ids,
'request_status.status_option.description' => $report_status,
);
my @params = (
query => \@query,
require_objects => $relationships,
# sort_by => 'created_at', # _has_ to be a t1 col if using require_objects
);
my $data = LIMS::DB::Request::Manager->get_requests(@params);
return $data;
}
}
#-------------------------------------------------------------------------------
sub update_request_dispatch_log {
my $self = shift;
my $data = shift;
my $request_id = $data->{request_id};
my $recipient = $data->{recipient};
my $action = 'dispatched report to ' . $recipient;
my $server_name = $self->lims_cfg->{settings}->{server_username};
# get username of server:
my $user_id = LIMS::DB::User->new(username => $server_name)->load->id;
my $update = sub {
LIMS::DB::RequestDispatchLog->new(
request_id => $request_id,
recipient => $recipient,
)->save;
LIMS::DB::RequestHistory->new(
request_id => $request_id,
user_id => $user_id,
action => $action,
)->save;
};
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $ok = $db->do_transaction($update);
# don't need return value unless error:
return $ok ? 0 : 'update_request_dispatch_log() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub update_request {
my ($self, $form_data) = @_; # use Data::Dumper; # warn Dumper $form_data;
# get original data from session (and store it in $self->frozen_data):
my $original_data = $self->_get_original_data;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $update_request = sub {
# referrer_code (only submitted if field edited):
if ( $form_data->{referrer_code} ) {
my $original_referrer_code = $self->frozen_data->{referrer_code};
if ( $form_data->{referrer_code} ne $original_referrer_code ) {
$self->do_referrer_update($form_data);
} # warn "$form_data->{referrer_code} ne $original_referrer_code";
}
# specimen_code (always submitted):
{
my $original_specimen_code = $self->frozen_data->{specimen_code};
if ( $form_data->{specimen_code} ne $original_specimen_code ) {
$self->do_specimen_code_update($form_data);
} # warn "$form_data->{specimen_code} ne $original_specimen_code";
}
# clinical trial:
{
no warnings 'uninitialized'; # either original or form params can be undef
my $original_trial_id = $self->frozen_data->{trial_id};
if ( $form_data->{trial_id} != $original_trial_id ) {
$self->do_clinical_trial_update($form_data);
}
}
# external reference:
{
no warnings 'uninitialized'; # either original or form param can be undef
my $original_external_ref = $self->frozen_data->{external_reference};
if ( $form_data->{external_reference} ne $original_external_ref ) {
$self->do_external_ref_update($form_data);
}
}
# trial number:
{
no warnings 'uninitialized'; # either original or form params can be undef
my $original_trial_number = $self->frozen_data->{trial_number};
if ( $form_data->{trial_number} ne $original_trial_number ) {
$self->do_trial_number_update($form_data);
}
}
# request_options:
{
no warnings 'uninitialized'; # any of form params or original data can be undef
# get list of all additional options:
my $request_options
= LIMS::DB::AdditionalOption::Manager->get_additional_options;
my $frozen = $self->frozen_data; # warn Dumper $frozen;
# hash for new request options:
my %new_request_options = ();
foreach (@$request_options) {
my $option = $_->option_name; # warn Dumper $option;
my $original = $frozen->{$option} || '';
$new_request_options{$_->id}{new} = $form_data->{$option}; # 1 or undef
$new_request_options{$_->id}{old} = $original; # old value
$new_request_options{$_->id}{name} = $option;
} # warn Dumper \%new_request_options;
if (%new_request_options) {
$self->do_request_options_update($form_data, \%new_request_options);
}
}
# request_consent:
{
no warnings 'uninitialized'; # any of form params or original data can be undef
# get list of all additional options:
my $request_consent
= LIMS::DB::ConsentOption::Manager->get_consent_options;
my $frozen = $self->frozen_data; # warn Dumper $frozen;
# hash for new request consent:
my %new_request_consent = ();
foreach (@$request_consent) {
my $consent_name = $_->consent_name;
$new_request_consent{$_->id}{new} = $form_data->{$consent_name}; # yes, no or undef
$new_request_consent{$_->id}{old} = $frozen->{$consent_name}; # old value
$new_request_consent{$_->id}{name} = $consent_name;
} # warn Dumper \%new_request_consent;
if (%new_request_consent) {
$self->do_request_consent_update($form_data, \%new_request_consent);
}
}
# update error code & history log:
$self->do_request_error_code($form_data);
$self->do_history_log($form_data);
};
#$self->set_rose_debug(1);
my $ok = $db->do_transaction( $update_request );
#$self->set_rose_debug(0);
# return value needs to match format in update_patient_case():
return $ok
? { success => $ok }
: { error => 'update_request() error - ' . $db->error };
}
#-------------------------------------------------------------------------------
sub unlock_request {
my ($self, $request_id) = @_;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $unlock = sub {
my $o = LIMS::DB::Request->new(id => $request_id)->load;
=begin # would need to manually reset status to locked, reverted to timestamp:
# update request_status:
my $status_otions_map = $self->request_status_options_map;
my $status_option_id
= $status_otions_map->{authorised}->{is_active} eq 'yes'
? $status_otions_map->{authorised}->{id}
: $status_otions_map->{reported}->{id};
$o->status_option_id($status_option_id);
=cut
$o->updated_at($self->time_now);
$o->save(changes_only => 1);
LIMS::DB::RequestHistory->new(
request_id => $request_id,
user_id => $self->user_profile->{id},
action => 'unlocked record',
)->save;
};
#$self->set_rose_debug(1);
my $ok = $db->do_transaction($unlock);
#$self->set_rose_debug(0);
# don't need return value unless error:
return $ok ? 0 : 'unlock_request() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub delete_request {
my $self = shift;
my $data = shift; # $self->debug($data); # return;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $request_id = $data->{request_id};
my $request = LIMS::DB::Request->new(id => $request_id)
->load(with => ['patient_case.patient', 'request_report.diagnosis']);
my %current_action = (
user_id => $self->user_profile->{id},
time => $self->time_now(),
action => sprintf 'deleted record (%s)', $data->{reason},
);
my $delete = sub {
# retrieve all history data for archiving before cascade delete:
$self->_archive_request_history($request); # warn Dumper $self->archive;
# add current action (delete):
$self->add_to_archive(\%current_action);
# sort archive into datetime order:
my @chronological = sort {
DateTime->compare($a->{time}, $b->{time})
} $self->archived_data; # warn Dumper \@chronological;
# save to deleted_requests table:
for my $entry (@chronological) { # warn Dumper $data;
LIMS::DB::DeletedRequest->new(
request_id => $request_id,
request_number => $request->request_number,
year => $request->year,
action => $entry->{action},
user_id => $entry->{user_id},
time => $entry->{time},
)->save;
}
LIMS::DB::Request->new(id => $request_id)->delete;
# (cascade => 'delete'); using ON DELETE CASCADE in sql
};
#$self->set_rose_debug(1);
my $ok = $db->do_transaction($delete);
#$self->set_rose_debug(0);
# don't need return value unless error:
return $ok ? 0 : 'delete_request() error - ' . $db->error;
}
#-------------------------------------------------------------------------------
sub _archive_request_history {
my ($self, $request) = @_;
# common to all queries:
my %args = ( query => [ request_id => $request->id ] );
{ # request error_code:
local $args{require_objects} = 'error_code'; # warn Dumper \%args;
my $o = LIMS::DB::RequestErrorCode::Manager->get_request_error_codes(%args);
for (@$o) { # warn Dumper $_->as_tree;
my $data = $self->_format_data_for_archive($_);
# format action:
$data->{action} = 'recorded error code ' . $_->error_code->code;
$self->add_to_archive($data);
}
}
{ # request_history:
my $o = LIMS::DB::RequestHistory::Manager->get_request_histories(%args);
for (@$o) {
my $data = $self->_format_data_for_archive($_);
# format action:
my $action = $_->action; # warn Dumper $data;
if ($action eq 'reported') { # get diagnosis:
$action .= sprintf ' (diagnosis = %s)',
$request->request_report->diagnosis->name;
}
elsif ($action eq 'registered') {
my $patient = $request->patient_case->patient;
$action .= sprintf ' (%s, %s, %s)',
$patient->last_name,
$patient->first_name,
$patient->dob ? $patient->dob->ymd : 'NULL';
}
$data->{action} = $action;
$self->add_to_archive($data);
}
}
{ # request_diagnosis_history:
local $args{require_objects} = [ qw(diagnosis option) ];
my $o = LIMS::DB::RequestDiagnosisHistory::Manager
->get_request_diagnosis_histories(%args);
for (@$o) {
my $data = $self->_format_data_for_archive($_);
# format action:
$data->{action} = sprintf 'amended diagnosis = %s; reason = %s',
$_->diagnosis->name, $_->option->option_name;
$self->add_to_archive($data);
}
}
{ # request_phonelog:
my $o = LIMS::DB::RequestPhoneLog::Manager->get_request_phone_log(%args);
for (@$o) {
my $data = $self->_format_data_for_archive($_);
# format action:
$data->{action} = join '; ', $_->status, $_->contact, $_->details;
$self->add_to_archive($data);
}
}
}
#-------------------------------------------------------------------------------
# returns common data items user_id & time:
sub _format_data_for_archive {
my $self = shift;
my $data = shift;
my %data = (
user_id => $data->user_id,
time => $data->time,
);
return \%data;
}
#-------------------------------------------------------------------------------
sub update_patient_case {
=begin # how it works:
scope determines whether to apply change to single record (default) or to all records.
1) Get a new patient_case.id - 'use_patient_case_id' param if submitted, otherwise
find existing combination of submitted patient_id, referral_source_id & unit_number
in patient_case table, or create a new patient_case.
2) If scope = all (or if only 1 record attached to patient_case), change all
instances of requests.patient_case_id to new value & delete old patient_case entry
3) If scope = single record, just change patient_case_id for single request.id
4) If referral_source is changed, requests.referrer_department_id may be incorrect,
so unless parent_organisation is same as old, requests.referrer_department_id
is updated to a new one if found, or to the entry corresponding to unknown referrer
(clinician or gp, if not already), pending referrer change.
=cut
my ($self, $form_data) = @_; # warn 'form_data:'; warn Dumper $form_data; # return;
# get original data from session (and store it in $self->frozen_data):
my $original_data = $self->_get_original_data; # warn 'orginal_data:'; warn Dumper $original_data;
my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
my $i = 0; # successful updates counter
my $update_patient_case = sub {
# get new patient_case_id:
my $new_patient_case_id = $self->_get_new_patient_case_id($form_data)
|| die 'no patient_case_id returned by _get_new_patient_case_id()';
# protect against old patient_case_id == new patient_case_id, where 'old'
# patient_case gets deleted if scope set to 'all':
return 0 unless $new_patient_case_id != $original_data->{patient_case_id};
if ($form_data->{scope} eq 'all') { # warn 'all';
{ # update requests table:
my %args = (
set => { patient_case_id => $new_patient_case_id },
where => [ patient_case_id => $original_data->{patient_case_id} ],
);
$i += LIMS::DB::Request::Manager->update_requests(%args);
}
{ # delete old patient_case:
my $patient_case_id = $original_data->{patient_case_id};
LIMS::DB::PatientCase->new(id => $patient_case_id)->delete();
}
}
else { # just update single record:
my $o = LIMS::DB::Request->new(id => $form_data->{_request_id})->load;
$o->patient_case_id($new_patient_case_id); # warn 'one';
$i += 1 if $o->save(changes_only => 1); # $i gets memory address on success ??
}
# might need to update referrer department if new referral source submitted:
if ( my $new_referral_source_id = $form_data->{referral_source_id} ) {
if ( $new_referral_source_id != $original_data->{referral_source_id} ) {
$self->do_referrer_department_update($form_data);
}
}
$self->do_patient_case_history($form_data);
};
#$self->set_rose_debug(1);
my $ok = $db->do_transaction($update_patient_case); # warn $i; # warn Dumper $db->error;
# or can do: $db->do_transaction( sub { $result = $update_patient_case->() } );
#$self->set_rose_debug(0);
# return hashref of db error (if any), or numerical value of success (updates count):
return $ok
? { success => $i }
: { error => 'update_patient_case() error - ' . $db->error };
}
#-------------------------------------------------------------------------------
sub get_first_request_date {
my $self = shift;
my $first_request = LIMS::DB::Request->new(id => 1)->load(speculative => 1);
$first_request->created_at if $first_request;
}
#-------------------------------------------------------------------------------
sub _get_new_patient_case_id {
my ($self, $form_data) = @_;
# patient_case_id might be submitted by 'use this' radio button:
my $patient_case_id = $form_data->{use_patient_case_id} || '';
# if $form_data patient_case_id used, original values are submitted in form
# fields so need to get new values into $form_data to replace original ones:
if ($patient_case_id) {
my $patient_case = LIMS::DB::PatientCase->new(id => $patient_case_id)
->load(with => 'referral_source');
map {
$form_data->{$_} = $patient_case->$_;
} qw(unit_number referral_source_id);
$form_data->{_location_name} = $patient_case->referral_source->display_name;
}
# if we don't already have a patient_case_id, go and get one:
else {
# find matching patient_case, or create new:
my $patient_case = $self->get_patient_case($form_data);
$patient_case_id = $patient_case->id;
}
return $patient_case_id;
}
#-------------------------------------------------------------------------------
sub _get_original_data {
my $self = shift;
# put original data into frozen_data():
my $original_data = $self->session_data('_request_edit_data');
$self->frozen_data($original_data); # warn Dumper $original_data->{_data};
=begin # don't do this - causes fatal error if back button used & then data resubmitted
# clear session data (not required as it's overwritten anyway, but tidier):
# $self->clear_data('_request_edit_data');
=cut
return $original_data;
}
#-------------------------------------------------------------------------------
sub _verify_request_exists {
my ($self, $request_id) = @_; # warn $request_id;
my @q = (id => $request_id);
return LIMS::DB::Request::Manager->get_requests_count( query => \@q );
}
#-------------------------------------------------------------------------------
sub _get_request_data {
my $self = shift;
my $data = shift;
# get referrer_department.id for supplied referral source & referrer code:
my $referrer_department = $self->_get_referrer_department($data);
$data->{referrer_department_id} = $referrer_department->id;
my %request_data = map {
$_ => $data->{$_};
} qw( request_number patient_case_id referrer_department_id );
# current year:
# $request_data{year} = DateTime->now->year; # done by DB::Request meta data - nope:
$request_data{year} = LIMS::Local::Utils::this_year(); # DB classes only loaded once
=begin # not using this method anymore
{ # check for previously deleted request_number/year combination, if so use request.id:
my %args = (
request_number => $data->{request_number},
year => DateTime->now->year,
);
#$self->set_rose_debug(1);
my $deleted_request
= LIMS::DB::DeletedRequest->new(%args)->load(speculative => 1);
#$self->set_rose_debug(0);
if ($deleted_request) {
$request_data{id} = $deleted_request->request_id;
}
}
=cut
return \%request_data;
}
#-------------------------------------------------------------------------------
sub _get_referrer_department {
my $self = shift;
my $data = shift; # warn Dumper $data;
my $referrer
= LIMS::DB::Referrer->new(national_code => $data->{referrer_code})->load;
my $referral_source
= LIMS::DB::ReferralSource->new(id => $data->{referral_source_id})
->load(with => 'referral_type'); # get referral_type for possible use later;
# get referrer_department for supplied referral source & referrer code:
my %args = (
referrer_id => $referrer->id,
parent_organisation_id => $referral_source->parent_organisation_id,
);
my $referrer_department
= LIMS::DB::ReferrerDepartment->new(%args)->load(speculative => 1);
# if no $referrer_department, get referrer_department.id for unknown referrer of correct type:
if (! $referrer_department ) { # warn 'here';
# get map between referral_type.id & referrer_department.id for unknown locations:
my $referral_type_map = $self->referral_type_map; # warn Dumper $referral_type_map;
# get id of default referrer_department for this location type (hospital or practice):
my $referrer_department_id
= $referral_type_map->{$referral_source->referral_type_id};
$referrer_department = LIMS::DB::ReferrerDepartment
->new(id => $referrer_department_id)->load; # warn Dumper $referrer_department->as_tree;
}
return $referrer_department;
}
#-------------------------------------------------------------------------------
sub _build_request_status_options_map {
my $self = shift;
my $status_options = LIMS::DB::StatusOption::Manager->get_status_options;
my %map = map {
$_->description => $_->as_tree;
} @$status_options; # warn Dumper \%map;
return \%map;
}
#-------------------------------------------------------------------------------
# creates map between referral_type.id and referrer_department.id for unknown locations:
sub _build_referral_type_map {
my $self = shift;
my %args = ( # using 2 custom relationships in ReferralType & ParentOrg classes:
require_objects => 'unknown_parent_org.unknown_referrer_department',
);
# get referral_types:
my $referral_types
= LIMS::DB::ReferralType::Manager->get_referral_types(%args);
=begin # effective sql for ReferralType::Manager->get_referral_types():
SELECT
t1.id as 'referral_type_id',
t3.id as 'referrer_department_id'
FROM
referral_types t1
JOIN parent_organisations t2 ON (t1.default_unknown = t2.parent_code)
JOIN referrer_department t3 ON (t2.id = t3.parent_organisation_id)
=cut
# create map:
my %referral_type_map = map {
$_->id => $_->unknown_parent_org->unknown_referrer_department->id;
} @$referral_types; # warn Dumper \%referral_type_map;
return \%referral_type_map;
}
#-------------------------------------------------------------------------------
# warning: method of same name exists in C::Roles::DataMap
# returns hash of arrayrefs
sub _build_specimen_lab_test_map {
my $self = shift;
my $o = $self->get_objects('SpecimenLabTest');
my %map;
for (@$o) {
my $specimen_id = $_->specimen_id; # warn $specimen_id;
my $lab_test_id = $_->lab_test_id; # warn $lab_test_id;
push @{ $map{$specimen_id} }, $lab_test_id;
} # warn Dumper \%map;
return \%map;
}
#-------------------------------------------------------------------------------
# only need this in new_request() to see why rare null request_specimen entry
sub _build_specimen_map {
my $self = shift;
my $o = $self->get_objects('Specimen');
my %h = map { $_->sample_code => $_->id } @$o; # need LC for input matching
return \%h;
}
#-------------------------------------------------------------------------------
# *** method of similar name in Role::RequestUpdate ***
sub _get_clinical_trial_data {
my $self = shift;
my $data = shift;
# no need for db access if no trial_id:
return unless $data->{trial_id};
my $patient_case = LIMS::DB::PatientCase->new(
id => $data->{patient_case_id}
)->load;
my %trial_data = (
trial_id => $data->{trial_id},
trial_number => $data->{trial_number},
patient_id => $patient_case->patient_id,
);
return \%trial_data;
}
1;
