• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Model::Local;

use Moose;
extends 'LIMS::Model::Base';
with (
    'LIMS::Model::Roles::Query',
    'LIMS::Model::Roles::LabTestUpdate', # do_linked_lab_tests()
);
has form_data => ( is => 'rw', isa => 'HashRef', default => sub { {} } );

use namespace::clean -except => 'meta';
__PACKAGE__->meta->make_immutable;

use Data::Dumper;

#-------------------------------------------------------------------------------
sub load_view {
	my ($self, $view, $sort) = @_; # warn $sort; # optional sort
    
    my $table = 'views.'.$view;
    my $dbix  = $self->lims_dbix;

    my $data = $dbix->select($table, '*', {}, $sort)->arrays; # $sort ignored if undef
    my @cols = map # can't use dbix_get_meta() - need cols in order:
        $_->{field}, $dbix->query("show columns from $table")->hashes; # warn Dumper \@cols;

    return {
        data => $data,
        cols => \@cols,
    };
}

#-------------------------------------------------------------------------------
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, $id) = @_;

	my $data = LIMS::DB::PreRegistration->new(id => $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 delete_pre_registration_data {
	my ($self, $id) = @_;

=begin # replaced by CASCADE DELETE on pre_reg_specimens & pre_reg_lab_tests FK's:
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $delete = sub {
        my $o = LIMS::DB::PreRegistration->new( id => $id )->load;
		{ # get any pre_registration_specimens:
			my $specimens = do {
				my %args = ( query => [ pre_reg_id => $id ] );
				LIMS::DB::PreRegistrationSpecimen::Manager
					->get_pre_registration_specimens(%args);
			}; # warn Dumper $specimens;
            # delete any pre_registration_lab_tests, then delete pre_registration_specimens:
			for my $specimen (@$specimens) {
                my $id = $specimen->id;
				my %args = ( where => [ reg_specimen_id => $id ] );
				LIMS::DB::PreRegistrationLabTest::Manager
                    ->delete_pre_registration_lab_tests(%args);
				LIMS::DB::PreRegistrationSpecimen->new(id => $id)->delete;
			}
		}
        # now delete pre_registration entry:
		$o->delete; # die 'roll back now';
    };
	my $ok = $db->do_transaction($delete);
	return $ok ? 0 : 'delete_pre_registration_data() error - ' . $db->error;
=cut
    eval { LIMS::DB::PreRegistration->new( id => $id )->delete };
    return @$ if @$;
}

#-------------------------------------------------------------------------------
sub has_previous_data {
	my ($self, $args) = @_;

	my $test_name = $args->{test_name};
	my $request   = $args->{request};

	my $patient_id = $request->patient_case->patient_id;

	my @args = (
		require_objects => [
			qw( patient_case.patient request_lab_tests_status.lab_test )
		],
		query => [
			'requests.id' => { lt => $request->id },
			patient_id    => $patient_id,
			test_name     => $test_name,
		],
	);

	# need at least 1 previous dataset on same patient:
	my $i = LIMS::DB::Request::Manager->get_requests_count(@args);
	return $i;
}

#-------------------------------------------------------------------------------
sub get_chimerism_data {
	my ($self, $request_id) = @_; # warn Dumper $request_id; # arrayref

	my %h;

	{ # request & patient data:
		my @args = (
			require_objects => [ 'patient_case.patient' ],
            with_objects    => [ 'patient_case.patient.patient_note' ],
			query           => [ id => $request_id ],
		);
		my $o = LIMS::DB::Request::Manager->get_requests(@args);
		for my $req(@$o) { # warn Dumper $req->as_tree;
			my $id = $req->id;
			$h{$id} = $req->as_tree(deflate => 0); # hash ref so we can add more data
		}
	}
	{ # sample data:
		my @args = (
			require_objects => [ 'specimen' ],
			query => [ request_id => $request_id ],
		);
		my $o = LIMS::DB::RequestSpecimen::Manager->get_objects(@args);
		for my $ref(@$o) {
			my $id = $ref->request_id; # should only be 1 sample (CHIx) but jic
			push @{ $h{$id}{specimen} }, $ref->specimen->sample_code;
		}
	}
	{ # lab-tests:
		my @args = (
			require_objects => [ 'lab_test' ],
			query => [
				request_id => $request_id,
				'lab_test.test_name' => { rlike => 'chimerism' },
				'lab_test.is_active' => 'yes',
			],
		);
		my $o = LIMS::DB::RequestLabTestStatus::Manager->get_objects(@args);
		for my $ref(@$o) {
			my $id = $ref->request_id;
			push @{ $h{$id}{lab_test} }, $ref->lab_test->field_label;
		}
	}

	my @rels = ( 'patient_case.patient', 'results_summary.lab_section',
		'request_specimen.specimen' );
	# common args for baseline & previous results (will be cloned in loop):
	my $ARGS = {
		baseline => {
			require_objects => \@rels,
			query => [
				'results_summary.lab_section.section_name' => 'Molecular',
				'request_specimen.specimen.sample_code'    => 'CHIB',
			],
			multi_many_ok => 1, # have >1 "one to many" relationships (get arrayrefs)
		},
		previous => {
			require_objects => \@rels,
			query => [
				'results_summary.lab_section.section_name' => 'Molecular',
				'request_specimen.specimen.sample_code'    => [ qw(CHIA CHIM) ],
			],
			multi_many_ok => 1, # have >1 "one to many" relationships (get arrayrefs)
			sort_by		  => [ 'created_at DESC' ],
			limit 		  => 1,
		},
	};
	my $clone = sub { LIMS::Local::Utils::clone(@_) };

	{ # baseline & most recent data (if CHI[AM] sample):
		REQ: while ( my($req_id, $d) = each %h ) { # warn Dumper $d;
			my $specimen = $d->{specimen};  # arrayref (should be of 1)
			next REQ unless grep $_ =~ /CHI[AM]/, @$specimen;

			my $nhs_number = $d->{patient_case}->{patient}->{nhs_number}
			|| next REQ; # or will query db using nhs_number => NULL

			{ # baseline (CHIB) data:
				my $args = &$clone($ARGS->{baseline}); # take copy for modification
				push @{ $args->{query} },
					'patient_case.patient.nhs_number' => $nhs_number; # warn Dumper $args;
				my $o = LIMS::DB::Request::Manager->get_objects(%$args);
				if ( @$o ) { # warn Dumper $o; # should be array(ref) of 1 arrayref:
					my $result = $o->[0]->results_summary->[0]->results_summary;
					my ($baseline) = $result =~ /Baseline chimerism data:\s?(.*)/;
					$h{$req_id}{baseline} = $baseline;
				}
			}
			{ # previous (CHIA/M) molecular result:
				my $args = &$clone($ARGS->{previous}); # take copy for modification
				push @{ $args->{query} },
					'patient_case.patient.nhs_number' => $nhs_number; # warn Dumper $args;
				my $o = LIMS::DB::Request::Manager->get_objects(%$args);
				if ( @$o ) { # warn Dumper $o; # should be array(ref) of 1 arrayref:
					my $result = $o->[0]->results_summary->[0]->results_summary;
					$h{$req_id}{previous_result} = $result;
				}
			}
		}
	}
	return \%h;
}

#-------------------------------------------------------------------------------
sub get_xna_extraction_status {
	my ($self, $args) = @_; # warn Dumper $args; # hashref

	my $request_id  = $args->{request_id};
	my $lab_test_id = $args->{lab_test_id};

	my @linked_lab_test_ids = do {
		my @args = (
			distinct => 1,
			select   => 'linked_test_id',
			query    => [ parent_test_id => $lab_test_id ],
		);
		my $o = LIMS::DB::LinkedLabTest::Manager->get_objects(@args);
		map $_->linked_test_id, @$o;
	}; # warn Dumper \@linked_lab_test_ids;
	
	my $data = LIMS::DB::Request::Manager->get_objects(
		require_objects => [
			'request_lab_tests_status.status',
			'request_lab_tests_status.lab_test'
		],
		query => [
			id => $request_id,
			'request_lab_tests_status.lab_test.id' => \@linked_lab_test_ids,
		],
	); # warn Dumper $_->as_tree for @$data;
	return $data;
}

#-------------------------------------------------------------------------------
sub pcr_status_overview {
	my ($self, $lab_test_id) = @_; # arrayref

	my $data = LIMS::DB::RequestLabTestStatus::Manager->get_objects(
		query => [
			'request.status_option.description' => { ne => 'complete '},
			'lab_test_id' 						=> $lab_test_id,

		],
		require_objects => [ 'status', 'lab_test', 'request.status_option' ],
		sort_by => [
			qw( request.request_number request.year lab_test.test_name )
		],
	); # warn Dumper $_->as_tree for @$data;
	return $data;
}

#-------------------------------------------------------------------------------
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 get_outstanding_gross_description {
	my $self = shift;

	my @inner_joins = qw( patients sample_code status_options );
	my $require_objects_relationships = $self->get_relationships(\@inner_joins);

	my @outer_joins = qw(request_specimen_detail);
	my $with_objects_relationships = $self->get_relationships(\@outer_joins);

	my %args = (
		query => [
			'status_option.description' => [ qw(new screened) ] , # ie not reported
			'specimens.description' => { rlike => '(fixed|trephine)$' },
			gross_description => undef,
		],
		# retrieve distinct records (but can only retrieve 1 sample per request):
		distinct => [ qw(request_specimen patient_case patient specimen) ],
        require_objects => $require_objects_relationships,
		with_objects    => $with_objects_relationships,
        multi_many_ok   => 1, # have >1 one-to-many rels
	);

	my $o = LIMS::DB::Request::Manager->get_requests(%args);
	return $o;
}

#-------------------------------------------------------------------------------
sub update_gross_description {
	my ($self, $args) = @_; # warn Dumper $args;

	my $db = $self->lims_db;

	my $request_id = $args->{request_id};
	my $gross_desc = $args->{gross_description};

	my $update = sub {
		my $o = LIMS::DB::RequestSpecimenDetail->new(request_id => $request_id);
        my $action = $o->load_speculative ? 'updated' : 'reported'; # warn Dumper $o->as_tree;
		$o->gross_description($gross_desc);
        $o->insert_or_update(changes_only => 1); # don't update specimen_date if exists

		LIMS::DB::RequestHistory->new(
			request_id => $args->{request_id},
			user_id    => $self->user_profile->{id},
			action     => join ' ', $action, 'specimen gross description',
		)->save;
	};

	my $ok = $db->do_transaction($update);

	return $ok ? 0 : 'update_gross_description() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
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 $linked_tests   = $data->{linked_tests} || {}; # optional href (yaml data)
	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); # warn Dumper $lab_tests;

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
		# update request_lab_test_history table
        for my $option_name (@$status_options) { # warn Dumper $option_name;
            next unless $data->{$option_name};

			my $action = "set $field_label status to $option_name";

			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_name eq 'complete') {
				# get status option for 'complete':
				my $status_option = LIMS::DB::LabTestStatusOption
					->new(description => 'complete')->load;

				my %h = (
					request_id  => $data->{request_id},
					lab_test_id => $data->{lab_test_id},
				);
				my $o = LIMS::DB::RequestLabTestStatus->new(%h)->load;

				# update status option & user_id:
				$o->status_option_id($status_option->id);
				$o->user_id($user_profile->{id});
				$o->save(changes_only => 1);
			}
            # linked additional tests if configured:
            if ( my $tests = $linked_tests->{$option_name} ) { # warn Dumper $tests;
                $self->do_linked_lab_tests($tests, $data->{request_id});
            }
		}

		# 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 $ref = $data->{reference}; # changed to a recorded delivery ref

	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($ref);
			$o->save(changes_only => 1);

			{ # log changes:
				my $action = sprintf 'returned blocks [ref: %s]', $ref;
				my %data = (
					request_id => $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_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',
        sort_by => 'position',
	);
	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;