package LIMS::Model::Roles::ScreenUpdate; use Moose::Role; with ( 'LIMS::Model::Roles::LabTestUpdate', ); use Data::Dumper; #------------------------------------------------------------------------------- sub do_auto_screen { my $self = shift; # get hashref or required data (keys = lab_tests, presentation & trial_name): my $auto_screen_data = $self->_get_auto_screen_data(); # warn Dumper $auto_screen_data; return 0 unless %$auto_screen_data; # warn Dumper $auto_screen_data; my $data = $self->form_data; # warn Dumper $data; my $request_id = $data->{_request_id}; my $user_id = $self->user_profile->{id}; my $screen_id = 0; # set below, used in do_lab_test_details() block # linked_lab_tests_map: my $linked_tests_map = $self->linked_lab_tests; # M::R::LabTestUpdate # first save presentation info: if ( my $presentation = $auto_screen_data->{presentation} ) { my $description = $presentation->{description}; my $category = $presentation->{category}; my @args = ( query => [ description => $description, name => $category, ], require_objects => 'category', ); my $screen = LIMS::DB::Screen::Manager->get_screens(@args)->[0]; $screen_id = $screen->id; # used in do_lab_test_details() block my %data = ( request_id => $request_id, screen_id => $screen->id, ); # warn Dumper \%data; LIMS::DB::RequestInitialScreen->new(%data)->save; # update request status: $self->update_request_status('screened', $request_id); } # if trial name required: if ( my $trial_name = $auto_screen_data->{trial_name} ) { my $trial_id = LIMS::DB::ClinicalTrial->new( trial_name => $trial_name)->load->id; my %data = ( request_id => $request_id, trial_id => $trial_id, ); LIMS::DB::RequestTrial->new(%data)->load_or_insert; # in case already set in form } # if lab tests generated: if ( my $lab_tests = $auto_screen_data->{lab_tests} ) { # warn Dumper $lab_tests; while ( my($lab_test_id, $test_name) = each %$lab_tests ) { my %data = ( _request_id => $request_id, lab_test_id => $lab_test_id, ); $self->do_new_lab_test(\%data); # add linked tests if configured: if ( my $ref = $linked_tests_map->{$lab_test_id} ) { # arrayref of linked test.id's $self->do_linked_lab_tests($ref, $request_id); } # lab test details: $data{screen_id} = $screen_id; # required by do_lab_test_details() $self->do_lab_test_details(\%data); } } $self->add_to_actions('screened'); } #------------------------------------------------------------------------------- sub additional_options { my ($self, $action) = @_; # warn Dumper $action; my $data = $self->form_data; # warn Dumper $data; my $cfg = $data->{additional_options_config}->{$action} || return 0; # get 'screened_as' description: my $presentation = LIMS::DB::Screen->new(id => $data->{screen_id})->load; my $screened_as = $presentation->description; # warn $screened_as; # cycle through options to see if screened_as term triggers option flag: while ( my($option, $d) = each %$cfg ) { # warn Dumper [$option, $d]; # check option (eg DoI) exists and is active: my $o = LIMS::DB::AdditionalOption->new(option_name => $option) ->load(speculative => 1); # warn Dumper $o->as_tree; return 0 unless $o && $o->is_active eq 'yes'; # set option flag if screened_as term matches one of list: if ( grep lc($screened_as) eq lc($_), @$d ) { my %data = ( request_id => $data->{_request_id}, option_id => $o->id, ); # warn Dumper \%data; LIMS::DB::RequestOption->new(%data)->load_or_insert; } } } #------------------------------------------------------------------------------- sub _get_auto_screen_data { my $self = shift; my $form_data = $self->form_data; # warn Dumper $form_data; my $cfg = $form_data->{auto_screen_config}; # warn Dumper $cfg; my $request_id = $form_data->{_request_id}; # get full request data (request, patient_case & patient tables) as a flat # data stucture, in case we need to find any mandatory field (eg nhs_number): my $request_data = do { my $r = LIMS::DB::Request->new(id => $request_id) ->load(with => 'patient_case.patient')->as_tree; LIMS::Local::Utils::traverse_hash($r); # uses Data::Traverse to flatten $r }; # warn Dumper $request_data; my %data = (); # method for determining if any previous diagnosis matches supplied icdo3: my $has_previous_diagnosis_icdo3 = sub { my $icdo3 = shift; my @args = ( require_objects => [ 'request_report.diagnosis', 'patient_case.patient', ], query => [ 'request_report.diagnosis.icdo3' => $icdo3, 'patient_case.patient_id' => $form_data->{patient_id}, ], ); LIMS::DB::Request::Manager->get_requests_count(@args); }; # method for determining if required specimen(s) exists in supplied specimens: my $has_specimen = sub { LIMS::Local::Utils::is_array_subset(@_) }; RULE: while ( my ($rule, $d) = each %$cfg ) { # $rule just for info - not used # check any mandatory request/patient fields (eg nhs_number): if ( my $required_fields = $d->{required_fields} ) { for my $field(@$required_fields) { # warn $field; # try to find required value in submitted form data, or else in # request/patient_case/patient data fields: next RULE unless $form_data->{$field} || $request_data->{$field}; } } my $match_criteria = $d->{match_criteria}; # HoH # $match_criteria has 1 or more hashref entries: while ( my ($field, $value) = each %$match_criteria ) { # warn Dumper [$field,$value]; # a match on specimen takes priority - may also generate trial name: if ( $field eq 'specimen_type' ) { my $required_specimens = $value; # always arrayref my @supplied = split /\,\s?|\s+/, $form_data->{specimen}; # warn Dumper [$required_specimens, \@supplied]; # check required specimen(s) exists in supplied specimens, or skip to next: next RULE if ! &$has_specimen($required_specimens, \@supplied); } elsif ( $field eq 'trial_name' ) { # get trial id from form, or skip rule: my $trial_id = $form_data->{trial_id} || next RULE; my $trial # get trials.trial_name for trial id: = LIMS::DB::ClinicalTrial->new(id => $trial_id)->load; # skip rule unless submitted trial is in config: next RULE unless $value eq $trial->trial_name; } elsif ( $field eq 'previous_diagnosis_icdo3' ) { # warn $value; # if previous_diagnosis ICDO3 supplied (eg used for CML's): next RULE unless &$has_previous_diagnosis_icdo3($value); # icdo3 } else { next RULE; # no matches } } # add config presentation & trial_name fields to %data (unless already set # from previous cycle through RULES loop, so ensure rules not inconsistent): map { $data{$_} ||= $d->{$_} } grep $d->{$_}, qw( presentation trial_name ); # add lab tests: if ( my $lab_tests = $d->{lab_tests} ) { # warn Dumper $lab_tests; $data{lab_tests}{$_} = $lab_tests->{$_} for keys %$lab_tests; } # add lab-test details: if ( my $lab_test_details = $d->{lab_test_details} ) { $data{lab_test_details} = $lab_test_details; } } # warn Dumper \%data; return \%data; } 1;