• Files
• Commits
• Log
• Graph
• Stats

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;