• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Model::Local;

use Moose;
extends 'LIMS::Model::Base';
with 'LIMS::Model::Roles::Query';
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, $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_xna_extraction_status {
	my ($self, $args) = @_; # arrayref
	
	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 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 $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) { # warn Dumper $option;
			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 $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;