• Files
• Commits
• Log
• Graph
• Stats

package History;

use Moose;
    with qw(
        Role::User
        Role::RebuildTables
    );
use namespace::clean -except => 'meta';

use Data::Dumper;

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 actions_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(
	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);

    $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 > 172000

    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";
		}
	}

	# change status to incomplete if outstanding tests or final_diag required:
	$self->_revert_status_on_outstanding_tests;
	$self->_revert_status_if_final_diagnosis_required;
	
	# get missing registration, screener, reporter info:
	$self->_do_missing_registration_info;
	$self->_do_missing_screener_info;
	$self->_do_missing_reporter_info;

	warn 'dumping temp table into request_history';
	
	# 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);
    }

    $dbh4->do( q!DROP TABLE `temp`! );
#=cut
	
	# 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;
	
    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);
	}
}

# 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};

	# get error_code data:
	if ( $vals->{action} =~ /error code \w/ ) {
		# record error_code:
		$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};
	}

	# 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|PatNo|Sex|PID/ ) {
		# TODO: skip for now
		my $fh = $self->log_file;
		print $fh $vals->{action}, "\n";
	}
	# request fields:
	elsif ( $vals->{action} =~ /$request_fields/ ) {
		$dbh->insert('temp', $data);
	}
	# assume lab_test fields:
	else {
		$dbh->insert('request_lab_test_history', $data);
	}
}

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;

    # 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/ ) {
			$dbh->update('request_diagnosis_history',
				{ time => $data->{time} }, # set
				{ # where:
					request_id => $data->{request_id},
					user_id    => $data->{user_id},
					reason     => $_,
				}
			);
		}
	}	
	elsif ($vals->{action} =~ /(Revise|Final)Diag/) {
		my $reason = $1 eq 'Revise' ? 'error' : 'update';
		$dbh->update('request_diagnosis_history',
			{ time => $data->{time} }, # set
			{ # where:
				request_id => $data->{request_id},
				user_id    => $data->{user_id},
				reason     => $reason,
			} 
		);
	}
}

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 $missing_registration_info = $self->missing_registration_info;

    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};

    while ( my $vals = $missing_registration_info->hash ) {
        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 $missing_screener_info = $self->missing_screener_info;

    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};

	RECORD:
    while ( my $vals = $missing_screener_info->hash ) {
        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 $missing_reporter_info = $self->missing_reporter_info;

    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};

	RECORD:
    while ( my $vals = $missing_reporter_info->hash ) {
        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_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_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
	);

	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;