package History;
use Moose;
with qw(
Role::User
Role::RebuildTables
);
use namespace::clean -except => 'meta';
use Data::Dumper;
use Date::Calc qw(Decode_Date_EU);
use DateTime::Format::MySQL;
has $_ => (is => 'ro', isa => 'HashRef', required => 1)
foreach qw( db sql );
has log_file => ( is => 'ro', required => 1 );
has request => ( is => 'ro', isa => 'HashRef', default => sub { {} } );
has $_ => ( is => 'ro', isa => 'Object', lazy_build => 1 )
foreach qw(
missing_screener_info
missing_reporter_info
missing_registration_info
);
has actions_list => ( is => 'ro', isa => 'Str', lazy_build => 1 );
has err_code_other => ( is => 'ro', isa => 'Int', lazy_build => 1 );
has actions_map => ( is => 'ro', isa => 'HashRef[Str]',lazy_build => 1 );
has change_options_map => ( is => 'ro', isa => 'HashRef[Str]',lazy_build => 1 );
has error_code_map => ( is => 'ro', isa => 'HashRef[HashRef]',lazy_build => 1 );
has $_ => ( is => 'ro', isa => 'ArrayRef[Str]', lazy_build => 1, auto_deref => 1 )
foreach qw( request_actions modified_request_fields lab_test_actions );
__PACKAGE__->meta->make_immutable;
my @tables = qw(
patient_edits
request_history
request_error_code
request_lab_test_history
);
$|++;
sub convert {
my $self = shift;
my $dbix3 = $self->db->{dbix3};
my $dbix4 = $self->db->{dbix4};
my $dbh4 = $self->db->{dbh4};
my $fh = $self->log_file;
#=begin
# $self->rebuild_tables(\@tables);
$self->rebuild_tables_asMyISAM($_) for @tables;
$dbh4->do( q!DROP TABLE IF EXISTS `temp`! );
$dbh4->do( q!CREATE TABLE `temp` LIKE `request_history`! );
my $sql = q!select ID,Date,Time,UserID,Action,HMDS from History!; # where ID > 20000!;
my $history = $dbix3->query($sql);
HISTORY:
while ( my $vals = $history->hash ) { # warn Dumper $vals;
$vals->{id} % 10000 || print $vals->{id}, "\n";
# eg Ki67 -> selection, remove trailing 'on':
$vals->{action} = $self->_do_action_field_substitutions($vals->{action});
my $lab_no = $vals->{hmds}; # warn $lab_no;
my ($hmds, $yr) = $lab_no =~ /H(\d+)\/(\d{2})/;
# create lab_no -> request.id map if not already exists:
$self->request->{$lab_no} ||=
$dbix4->query( q!SELECT id FROM requests WHERE request_number = ? AND
year = ?!, $hmds, 2000 + $yr )->list; # warn $self->request->{$lab_no};
unless ($self->request->{$lab_no}) {
print $fh "no request.id for lab_no $lab_no\n";
next HISTORY;
}
# do this 1st so 'entered foo' list matches before lab_tests:
if ( grep $vals->{action} =~ /^$_/, $self->request_actions ) { # match at beginning
$self->_do_request_actions($vals);
}
# do this next so we remove 'recorded error codes' so can do other 'recorded foo':
elsif ( $vals->{action} =~ /^recorded error code \w/ ) {
$self->_do_error_code_actions($vals);
}
elsif ( grep $vals->{action} =~ /^$_/, $self->lab_test_actions ) { # match at beginning
$self->_do_lab_test_actions($vals);
}
elsif ( $vals->{action} =~ /^(modified)/ ) {
$self->_do_modification_actions($vals);
}
elsif ( $vals->{action} =~ /diagnosis of DLBCL or Burkitt lymphoma/ ) {
$vals->{action} = 'dispatched DLBCL/Burkitt lymphoma email alert';
$self->_do_request_actions($vals);
}
else {
print $vals->{action}, "\n";
}
}
print "updating requests table - will cause requests.updated_at to shift to current_time\n";
#print DateTime->now(time_zone => 'local')->datetime, "\n";
# change status to incomplete if outstanding tests or final_diag required:
$self->_revert_status_on_outstanding_tests;
#print DateTime->now(time_zone => 'local')->datetime, "\n";
$self->_revert_status_if_final_diagnosis_required;
#print DateTime->now(time_zone => 'local')->datetime, "\n";
# patch for MyISAM tables - to replace sub-selects which kills performance:
my $requests = $dbix4->query('select id, request_number, year from requests')->hashes;
# get missing registration, screener, reporter info:
$self->_do_missing_registration_info($requests);
$self->_do_missing_screener_info($requests);
$self->_do_missing_reporter_info($requests);
print DateTime->now(time_zone => 'local')->datetime, "\n";
warn 'dumping temp table into request_history';
=begin # process failed at this point 18/8/2011 so combined into single statement:
# transfer data from temp to request_history in date/time order:
my $data = $dbix4->query( q!select request_id, action, user_id, time
from `temp` order by `time`,`request_id`,`id`! ); # don't want id
while ( my $vals = $data->hash ) { # warn $vals->{request_id};
$dbix4->insert('request_history', $vals);
}
=cut
$dbh4->do( q!
INSERT INTO `request_history` (`request_id`, `action`, `user_id`, `time`)
SELECT `request_id`, `action`, `user_id`, `time`
FROM `temp` order by `time`, `request_id`, `id`!
);
$dbh4->do( q!DROP TABLE `temp`! );
#=cut
print DateTime->now(time_zone => 'local')->datetime, "\n";
# update requests table 'created_at' col with registration date/time:
$self->_do_request_created_at;
# update request_report table 'created_at' col with report date/time:
$self->_do_report_created_at;
$self->convert_to_InnoDB($_) for @tables;
print $fh Dumper $self->no_username;
}
# change status to incomplete if outstanding tests (before timestamp updated):
sub _revert_status_on_outstanding_tests {
my $self = shift;
my $dbh = $self->db->{dbh4};
my $sql = q!
update requests r set r.status_option_id = 4 where r.id in (
select s.request_id from request_lab_test_status s
where s.status_option_id <> 2
) and r.status_option_id = 5!;
$dbh->do($sql);
}
# use hilis3 final_diagnosis.pl cron queries to find requests which need final diagnosis:
sub _revert_status_if_final_diagnosis_required {
my $self = shift;
my $dbix3 = $self->db->{dbix3};
my $dbix4 = $self->db->{dbix4};
my $sql = q!
SELECT `HMDS`, DATE_FORMAT(`Date`, '%Y') as 'year', `InitialDiag`, `Specimen`
FROM `Report`
LEFT JOIN `Main` on `DBID` = `Rpt_ID`
LEFT JOIN `MolGen` on `Mol_ID` = `DBID`
WHERE YEAR(`Date`) >= 2010
AND `AuthorisedBy` IS NOT NULL
AND `FinalDiag` IS NULL
AND (`GenResult` IS NOT NULL OR `FishResult` IS NOT NULL OR `MolResult` IS NOT NULL)
AND `InitialDiag` NOT IN ('Molecular miscellaneous', 'Chimerism sample',
'PNH', 'Rheumatoid arthritis')!;
my @excluded_if_peripheral_blood = (
'CML follow-up (post-BMT)', 'CML imatinib PB follow-up',
'CML interferon follow-up', 'CML STI follow-up' );
my $data = $dbix3->query($sql);
ROW:
while ( my $vals = $data->hash ) { # warn $vals->{request_id};
# skip 'escapees' from HILIS3:
next ROW if grep $vals->{hmds} == $_, (2646, 2656, 5217);
my $specimen = $vals->{specimen};
my $screen = $vals->{initialdiag};
next ROW if ( grep $screen eq $_, @excluded_if_peripheral_blood )
&& $specimen eq 'PB'; # skip CML follow-up PB's
# get lab_tests:
my $sql = q!
select t3.test_name, t4.description
from requests t1
join request_lab_test_status t2 on t2.request_id = t1.id
join lab_tests t3 on t2.lab_test_id = t3.id
join lab_test_status_options t4 on t2.status_option_id = t4.id
where t1.request_number = ? and t1.year = ?!;
my $lt = $dbix4->query( $sql, @{$vals}{ qw(hmds year) } )->hashes;
# warn Dumper $tests; next;
my @status = map $_->{description}, @$lt;
my @tests = map $_->{test_name}, @$lt;
# next if any incomplete tests:
next ROW if grep $_ ne 'complete', @status;
if ( $screen eq 'CMPD pres & follow-up' && $specimen eq 'PB' ) {
# check to see if JAK2 is only lab_test:
next ROW if (join '', @tests) eq 'jak2';
}
# warn Dumper [ @{$vals}{qw(hmds initialdiag specimen)}, @tests ];
# update status if already set to complete:
$dbix4->update( 'requests', { status_option_id => 4 },
{
request_number => $vals->{hmds},
year => $vals->{year},
status_option_id => 5
}
);
}
}
# update requests table 'created_at' col with registration date/time:
sub _do_request_created_at {
my $self = shift;
my $dbix = $self->db->{dbix4};
my $dbh = $self->db->{dbh4};
my $sql = q!select request_id, time from request_history where action = 'registered'!;
my $request_time_map = $dbix->query( $sql )->map;
# to avoid updated_at col updating to now():
$dbh->do( q!ALTER TABLE `requests` CHANGE COLUMN `updated_at`
`updated_at` timestamp;! );
map { # warn $_ unless $_ % 1000;
my $created_at = $request_time_map->{$_};
$dbix->update('requests', { created_at => $created_at }, { id => $_ } );
} sort keys %$request_time_map;
$dbh->do( q!ALTER TABLE `requests` CHANGE COLUMN `updated_at` `updated_at`
timestamp NOT NULL DEFAULT '0000-00-00 00:00:00' ON UPDATE CURRENT_TIMESTAMP! );
}
# update request_report table 'created_at' col with report date/time:
sub _do_report_created_at {
my $self = shift;
my $dbix = $self->db->{dbix4};
my $dbh = $self->db->{dbh4};
my $sql = q!select request_id, time from request_history where action = 'reported'!;
my $report_time_map = $dbix->query( $sql )->map;
# to avoid updated_at col updating to now():
$dbh->do( q!ALTER TABLE `request_report` CHANGE COLUMN `updated_at`
`updated_at` timestamp;! );
map { # warn $_ unless $_ % 1000;
my $created_at = $report_time_map->{$_};
$dbix->update('request_report', { created_at => $created_at }, { request_id => $_ } );
} sort keys %$report_time_map;
$dbh->do( q!ALTER TABLE `request_report` CHANGE COLUMN `updated_at` `updated_at`
timestamp NOT NULL DEFAULT '0000-00-00 00:00:00' ON UPDATE CURRENT_TIMESTAMP! );
}
sub _do_lab_test_actions {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
# get common fields: user_id, request_id & time:
my $data = $self->_get_history_table_data($vals);
$data->{action} = $vals->{action};
$dbh->insert('request_lab_test_history', $data);
}
sub _do_error_code_actions {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
my $data = $self->_get_history_table_data($vals);
my $error_code_map = $self->error_code_map;
my ($error_code) = $vals->{action} =~ /error code (\w)/;
{ # request_history
my %data = %$data;
$data{action} = 'recorded error code ' . $error_code;
$dbh->insert('temp', \%data);
if ($vals->{action} =~ /pre-IR1/) {
$data{action} = 'completed LIC';
$dbh->insert('temp', \%data);
}
}
my $error_code_id = $error_code_map->{$error_code}->{id}
|| die "Cannot find error code id for $error_code";
my $error_code_is_unique = $error_code_map->{$error_code}->{unique}
|| die "Cannot find error code 'is_unique' for $error_code";
{ # request_error_code:
$data->{error_code_id} = $error_code_id;
if ($error_code_is_unique eq 'yes') {
my $sql = q!select 1 from request_error_code
where request_id = ? and error_code_id = ?!;
return if
$dbh->query( $sql, @{$data}{ qw(request_id error_code_id) } )->list;
}
# ok, request_error_code doesn't exist or code not unique:
$dbh->insert('request_error_code', $data);
}
return $error_code_id;
}
# can be modifications to request, patient or lab_test fields:
sub _do_modification_actions {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
return if $vals->{action} eq 'modified' || $vals->{action} eq 'modified PID';
$vals->{action} =~ s/\((.*)\)/\[$1\]/g; # early HILIS3 used () instead of []
$vals->{action} =~ s/(modified \w+)\:/$1/;
$vals->{action} =~ s/»/->/;
$vals->{action} =~ s/modified Number/modified PatNo/;
my $fh = $self->log_file;
# print $fh $vals->{action}, "\n";
my $error_code_id;
# get error_code data:
if ( $vals->{action} =~ /error code \w/ ) {
# record error_code:
$error_code_id = $self->_do_error_code_actions($vals);
# strip error code (it's already logged in request_history file):
$vals->{action} =~ s/\s::\serror code \w//; # warn $vals->{action};
}
# in case Action doesn't have error code (early HILIS3):
my $err_code_other = $self->err_code_other;
$error_code_id ||= $err_code_other;
# get common fields: user_id, request_id & time:
my $data = $self->_get_history_table_data($vals);
$data->{action} = $vals->{action};
my $request_fields = join '|', $self->modified_request_fields; # using auto_deref here
# patient fields:
if ( $vals->{action} =~ /Name|DoB|NHSNo|Sex/ ) { # warn Dumper $vals->{action};
$vals->{action} =~ s/\[(NULL)\]/$1/g; # square brackets causing regex problems
my %mods = $vals->{action} =~ /(\w+) \[(.*?) ->/g; # warn Dumper \%mods;
# only interested in PID fields - but also need to capture BlockRef & PatNo:
if (grep $_ =~ 'Name|DoB|NHSNo', keys %mods) { # warn Dumper \%mods;
# get PID.P_ID from .. & get HILIS4 patient.id
my $request_id = $data->{request_id};
if ( my $name = $mods{Name}) {
my ($lname, $fname) = split ', ', $name;
$mods{LName} = $lname;
$mods{FName} = $fname if $fname; # if Name => 'foo' have to assume LName
}
# get existing patient for this request:
my $patient = do {
my $sql = q!select p.* from requests r join patient_case
pc on r.patient_case_id = pc.id join patients p on pc.patient_id = p.id
where r.id = ?!;
$dbh->query($sql, $request_id)->hash;
}; # warn Dumper $patient;
my $merged_data; # update $patient or $patient_edit with %mods data:
# if patient already modified in patient_edits table - get most recent entry:
my $sql = 'select * from patient_edits where patient_id = ? order by id desc limit 1';
if ( my $entry = $dbh->query($sql, $patient->{id})->hash ) {
$merged_data = $self->_merge($entry,\%mods);
}
else {
$merged_data = $self->_merge($patient,\%mods);
} # warn Dumper $merged_data;
my %edit = map {
$_ => $merged_data->{$_};
} qw(last_name first_name middle_name dob gender nhs_number); # warn Dumper \%edit;
$edit{error_code_id} = $error_code_id;
$edit{patient_id} = $patient->{id};
$edit{user_id} = $data->{user_id};
$edit{time} = $data->{time};
$dbh->insert('patient_edits', \%edit);
}
# look for any request fields which have been captured:
while ( my ($field, $value) = each %mods ) {
next unless grep $field eq $_, qw(PatNo BlockRef Number Clinician);
my ($change) = $vals->{action} =~ /$field.*$value -> (.*?)\]/;
# recreate action:
$field =~ s/Number/PatNo/; # early HILIS3
# warn $vals->{hmds} if grep { ! $_ } ($field, $value, $change); # get uninitialized val
$change ||= '??'; # H10992/06 Action truncated at 255 chars
my $action = sprintf 'modified %s [%s -> %s]', $field, $value, $change;
my %history = (
request_id => $data->{request_id},
user_id => $data->{user_id},
time => $data->{time},
action => $action,
); # warn Dumper \%history;
$dbh->insert('temp', \%history);
}
}
# request fields:
elsif ( $vals->{action} =~ /$request_fields/ ) {
$dbh->insert('temp', $data);
}
# assume lab_test fields:
else {
$dbh->insert('request_lab_test_history', $data);
}
}
sub _merge {
my ($self, $patient, $changes) = @_;
if ( my $last_name = $changes->{LName} ) {
$patient->{last_name} = $last_name;
}
if ( my $first_name = $changes->{FName} ) {
$patient->{first_name} = $first_name;
}
if ( my $nhs_number = $changes->{NHSNo} ) {
$patient->{nhs_number} = $nhs_number;
}
if ( my $dob = $changes->{DoB} ) {
if ($dob =~ /NULL/) {
$patient->{dob} = undef;
$dob = undef;
}
elsif ($dob =~ /(\d{2})[-\.](\d{2})[-\.](\d{4})/) {
$dob = join '-', $3, $2, $1;
}
elsif ($dob =~ /\d{2}[-\.]\w{3}[-\.]\d{4}/) {
$dob = sprintf '%s-%02d-%02d', Decode_Date_EU($dob); # require 4-2-2 for D::F::M
}
elsif ($dob =~ /\d{2}[-\.]\w{3}[-\.]\d{4}/) {
$dob = sprintf '%s-%02d-%02d', Decode_Date_EU($dob); # require 4-2-2 for D::F::M
}
if ($dob) {
eval { # check date is valid:
my $dt = DateTime::Format::MySQL->parse_date($dob); # require 4-2-2
if ($dt) {
$patient->{dob} = $dob;
}
};
}
}
no warnings 'uninitialized';
map $patient->{$_} = lc $patient->{$_}, qw(last_name first_name middle_name);
return $patient;
}
sub _do_request_actions {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
# get common fields: user_id, request_id & time:
my $data = $self->_get_history_table_data($vals);
my $actions_list = $self->actions_list;
my $actions_map = $self->actions_map;
my $options_map = $self->change_options_map;
# screened / reported / authorised:
my (@actions) = $vals->{action} =~ /$actions_list/g;
# if action in actions_list (eg screened, reported & authorised):
if (@actions) {
foreach my $action(@actions) {
# substitute 'action' if in %actions_map:
$data->{action} = $actions_map->{$action} || $action;
$dbh->insert('temp', $data);
}
}
# else just insert action:
else {
$vals->{action} =~ s/pre-IR1/LIC/;
$vals->{action} =~ s/\Ae-mailed\Z//; # empty e-mailed lines
$vals->{action} =~ s/\A(e-mailed)/$1 diagnosis status alert to/;
$data->{action} = $vals->{action} || return; # skip empty lines
$dbh->insert('temp', $data);
}
# update request_lab_test_status if status not complete:
if ($vals->{action} eq 'screened') { # should only be singlicate if outstanding tests
my $sql = q!select 1 from request_lab_test_status where request_id = ?
and status_option_id <> 2!;
if ( $dbh->query($sql, $data->{request_id})->list ) {
my $request_id = $data->{request_id};
my $user_id = $data->{user_id};
$dbh->update(
'request_lab_test_status',
{ user_id => $user_id },
{ request_id => $request_id, status_option_id => { '!=', 2 } },
);
}
}
# update request_diagnosis_history table:
if ($vals->{action} eq 'entered ReviseDiag and FinalDiag') { # only 5 of these
foreach ( qw/error update/ ) {
my $option_id = $options_map->{$_};
$dbh->update('request_diagnosis_history',
{ time => $data->{time} }, # set
{ # where:
request_id => $data->{request_id},
user_id => $data->{user_id},
option_id => $option_id,
}
);
}
}
elsif ($vals->{action} =~ /(Revise|Final)Diag/) {
my $reason = $1 eq 'Revise' ? 'error' : 'update';
my $option_id = $options_map->{$reason};
$dbh->update('request_diagnosis_history',
{ time => $data->{time} }, # set
{ # where:
request_id => $data->{request_id},
user_id => $data->{user_id},
option_id => $option_id,
}
);
}
}
sub _get_history_table_data {
my $self = shift;
my $vals = shift; # warn Dumper $vals;
my $username = lc $vals->{userid}; # warn $username if $lab_no eq 'H1608/02';
# get user.id from History.UserID:
my $user_id = $self->_get_user_id($username); # warn $user_id if $lab_no eq 'H1608/02';
my $lab_no = $vals->{hmds}; # warn $lab_no;
# get request.id from %request map:
my $request_id = $self->request->{$lab_no};
my %data = (
user_id => $user_id,
request_id => $request_id,
time => join ' ', $vals->{date}, $vals->{time},
);
return \%data;
}
# look for missing registration info:
sub _do_missing_registration_info {
my $self = shift;
my $requests = shift;
# sub-select on temp is table killer on MyISAM version:
#my $missing_registration_info = $self->missing_registration_info;
my $dbix3 = $self->db->{dbix3};
my $dbix4 = $self->db->{dbix4};
# while ( my $vals = $missing_registration_info->hash ) {#warn $vals->{id};
my %ids = $dbix4->query( q!select request_id, 1 from temp where action = 'registered'! )->map;
RECORD: for my $vals ( @$requests ) {
next RECORD if $ids{ $vals->{id} }; # replacement for sub-select in $missing_registration_info
my $date = $dbix3->query( q!select Date from Main where HMDS = ?
and year(Date) = ?!, $vals->{request_number}, $vals->{year})->list;
my %data = (
action => 'registered',
request_id => $vals->{id},
user_id => $self->username_userid_map->{unknown},
time => join ' ', $date, '00:00:00',
);
$dbix4->insert('temp', \%data);
}
}
# look for missing screener info:
sub _do_missing_screener_info {
my $self = shift;
my $requests = shift;
# sub-select on temp is table killer on MyISAM version:
# my $missing_screener_info = $self->missing_screener_info;
my $dbix3 = $self->db->{dbix3};
my $dbix4 = $self->db->{dbix4};
# while ( my $vals = $missing_screener_info->hash ) {
my %ids = $dbix4->query( q!select request_id, 1 from temp where action = 'screened'! )->map;
RECORD: for my $vals ( @$requests ) {
next if $ids{ $vals->{id} }; # replacement for sub-select in $missing_screener_info
my ($user,$date) = $dbix3->query( q!select Screener, ScreenDate from
Main,Report where HMDS = ? and year(Date) = ? and DBID = Rpt_ID!,
$vals->{request_number}, $vals->{year})->list;
# $user = signature - need user.id from $self->_get_user_id(), which needs UserID:
$user || next RECORD; # presume not screened;
my $username = $self->_get_username($user)
|| die "No username for $vals->{request_number}/$vals->{year}";
if ( my $user_id = $self->_get_user_id($username) ) {
my %data = (
action => 'screened',
request_id => $vals->{id},
user_id => $user_id,
time => join ' ', $date, '00:00:00',
);
$dbix4->insert('temp', \%data);
}
}
}
# look for missing reporter info:
sub _do_missing_reporter_info {
my $self = shift;
my $requests = shift;
#my $missing_reporter_info = $self->missing_reporter_info;
my $dbix3 = $self->db->{dbix3};
my $dbix4 = $self->db->{dbix4};
# while ( my $vals = $missing_reporter_info->hash ) {
my %ids = $dbix4->query( q!select request_id, 1 from temp where action = 'reported'! )->map;
RECORD: for my $vals ( @$requests ) {
next if $ids{ $vals->{id} }; # replacement for sub-select in $missing_reporter_info
my ($user,$date) = $dbix3->query( q!select ReportBy, ReportDate from
Main,Report where HMDS = ? and year(Date) = ? and DBID = Rpt_ID!,
$vals->{request_number}, $vals->{year})->list;
# $user = signature - need user.id from $self->_get_user_id(), which needs UserID:
$user || next RECORD; # presume not screened;
my $username = $self->_get_username($user)
|| die "No username for $vals->{request_number}/$vals->{year}";
if ( my $user_id = $self->_get_user_id($username) ) {
my %data = (
action => 'reported',
request_id => $vals->{id},
user_id => $user_id,
time => join ' ', $date, '00:00:00',
);
$dbix4->insert('temp', \%data);
}
}
}
sub _build_error_code_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
# needs to be uppercase:
my $sql = q!select `id`, upper(`code`) as 'code', `is_unique` from error_codes!;
my $codes = $dbh->query($sql);
my %map;
while ( my $vals = $codes->hash ) { # warn Dumper $vals;
my $code = $vals->{code};
my %data = (
id => $vals->{id},
unique => $vals->{is_unique},
);
$map{$code} = \%data;
}
return \%map;
# add discontinued codes:
}
sub _build_actions_map {
my $self = shift;
my %map = (
added => 'registered',
'deleted record' => 'deleted',
'unlocked record' => 'unlocked',
);
return \%map;
}
sub _build_change_options_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = q!select `option_name`, `id` from diagnosis_change_options!;
my $map = $dbh->query($sql)->map;
return $map;
}
sub _build_missing_registration_info {
my $self = shift;
my $dbh = $self->db->{dbix4};
return $dbh->query( q!select id, request_number, year from requests where
id not in ( select request_id from temp where action = 'registered' )! );
}
sub _build_missing_screener_info {
my $self = shift;
my $dbh = $self->db->{dbix4};
return $dbh->query( q!select id, request_number, year from requests where
id not in ( select request_id from temp where action = 'screened' )! );
}
sub _build_missing_reporter_info {
my $self = shift;
my $dbh = $self->db->{dbix4};
return $dbh->query( q!select id, request_number, year from requests where
id not in ( select request_id from temp where action = 'reported' )! );
}
sub _build_actions_list {
my $self = shift;
my $actions_list = join '|', qw(registered added screened reported
authorised deleted unlocked);
return $actions_list;
}
sub _build_err_code_other {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $id = $dbh->query('select id from error_codes where description = ?',
'other error(s)' )->list;
return $id;
}
sub _build_modified_request_fields {
my $self = shift;
my @fields = qw(
NewDiagnosis
TrialNo
Urgent
SpecQuality
Private
Store
Study
Research
ReviseDiag
Specimen
Source
BlockRef
ClinDetails
Clinician
Comment
Consent
DoI
FinalDiag
GrossDesc
Hospital
InitDiag
PatNo
);
return \@fields;
}
sub _build_request_actions {
my $self = shift;
my @request_actions = (
'added',
'screened',
'reported',
'authorised',
'registered',
'unlocked', # always 'unlocked record' in table
'reported and authorised',
'screened, reported and authorised',
'deleted', # always 'deleted%' in table
'emailed', # always 'emailed report' or 'emailed report%' in table
'e-mailed', # always 'emailed report' or 'emailed report%' in table
'recorded telephone',
'completed pre-IR1',
'dispatched', # report, CMP pack, sample alert, etc
);
push @request_actions, map { 'entered ' . $_ }
qw( Comment ClinDetails FinalDiag GrossDesc ReviseDiag );
return \@request_actions;
}
sub _build_lab_test_actions {
my $self = shift;
my @lab_test_actions = (
'updated',
'checked',
're-checked',
'requested',
'input',
'recorded', # will match all not matched in 'recorded error code' & @_build_request_actions::request_actions
'signed out',
'H & E', # always 'H & E signed out',
'returned blocks',
'referred blocks',
'block updated',
'removed FISH',
'analysed flow data',
'entered', # will match all which didn't match in @_build_request_actions::request_actions
);
return \@lab_test_actions;
}
sub _do_action_field_substitutions {
my $self = shift;
my $action = shift;
$action =~ s/Ki67/selection/;
# remove trailing 'on' & 'records:':
$action =~ s/\s(on|records\:)\Z//;
return $action;
}
1;
