package Role::Report;
use Moose::Role;
=begin
requires qw(screen_map signature_userid_map username_userid_map
substitute_screening_terms substitute_user);
=cut
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
foreach qw(
status_map
diagnosis_map
renamed_diagnoses
change_options_map
specimen_quality_map
);
use Data::Dumper;
sub do_report {
my $self = shift;
my $vals = shift;
# if not yet screened, will not exist in Report table:
$vals->{rpt_id} || return 0;
my $dbh = $self->db->{dbix4};
{ # InitialDiag:
my $initialdiag = $vals->{initialdiag};
my $screen_id = $self->screen_map->{$initialdiag}
|| $self->substitute_screening_terms->{$initialdiag}
|| die "no screen id for $initialdiag ($vals->{dbid})";
my %data = (
request_id => $vals->{_request_id},
screen_id => $screen_id,
);
$dbh->insert('request_initial_screen', \%data);
}
# if reported, convert data for request_report table:
if ( $vals->{reportby} ) {
my $new_diagnosis = $vals->{newdiagnosis} || '';
my $quality = $vals->{specquality} || '';
my $status = $self->status_map->{$new_diagnosis} || 'default';
my $specimen_quality = $self->specimen_quality_map->{$quality}
|| 'adequate';
my $diagnosis_map = $self->diagnosis_map;
my $diagnosis = $self->_process_diagnosis_data($vals);
my $diagnosis_id = $diagnosis_map->{$diagnosis}
|| die "Cannot find diagnosis_id for $diagnosis";
my %data = (
request_id => $vals->{_request_id},
comment => $vals->{comment},
clinical_details => $vals->{clindetails},
specimen_quality => $specimen_quality,
status => $status,
diagnosis_id => $diagnosis_id,
created_at => '0000-00-00 00:00:00', # will be updated in History
updated_at => $vals->{reporttime},
);
$dbh->insert('request_report', \%data);
}
# gross description:
if ( my $gross_description = $vals->{grossdesc} ) {
my %data = (
request_id => $vals->{_request_id},
detail => $gross_description,
);
unless ( grep $gross_description eq $_, ('-', 'N/A') ) {
$dbh->insert('request_gross_description', \%data);
}
}
}
# updates request_diagnosis_history table with any ReviseDiag or Diagnosis
# returns FinalDiag, ReviseDiag or Diagnosis:
sub _process_diagnosis_data {
my $self = shift;
my $vals = shift;
my $diagnosis;
# first try FinalDiag, update request_diagnosis_history table:
if ( $diagnosis = $vals->{finaldiag} ) {
if ($vals->{revisediag}) {
if ( $vals->{revisediag} ne $vals->{diagnosis} ) {
# diagnosis-that-got-changed, who-changed-it, date, reason:
my %data = (
diagnosis => $vals->{diagnosis},
username => $vals->{revisedby},
datetime => $vals->{revisedate},
request_id => $vals->{_request_id},
reason => 'error',
);
$self->_do_diagnosis_history(\%data);
}
if ( $vals->{finaldiag} ne $vals->{revisediag} ) {
# diagnosis-that-got-changed, who-changed-it, date, reason:
my %data = (
diagnosis => $vals->{revisediag},
username => $vals->{finalby},
datetime => $vals->{finaldate},
request_id => $vals->{_request_id},
reason => 'update',
);
$self->_do_diagnosis_history(\%data);
}
}
elsif ( $vals->{finaldiag} ne $vals->{diagnosis} ) {
# diagnosis-that-got-changed, who-changed-it, date, reason:
my %data = (
diagnosis => $vals->{diagnosis},
username => $vals->{finalby},
datetime => $vals->{finaldate},
request_id => $vals->{_request_id},
reason => 'update',
);
$self->_do_diagnosis_history(\%data);
}
}
# next try ReviseDiag, update request_diagnosis_history table:
elsif ( $diagnosis = $vals->{revisediag} ) {
if ( $vals->{revisediag} ne $vals->{diagnosis} ) {
# diagnosis-that-got-changed, who-changed-it, date, reason:
my %data = (
diagnosis => $vals->{diagnosis},
username => $vals->{revisedby},
datetime => $vals->{revisedate},
request_id => $vals->{_request_id},
reason => 'error',
);
$self->_do_diagnosis_history(\%data);
}
}
# group of molecular samples from 2002/2003 with no diagnosis:
elsif ( ! $vals->{diagnosis} ) {
if ( $vals->{initialdiag} =~ /molecular|chimerism/i ) {
$diagnosis = 'Not required';
}
}
else {
$diagnosis = $vals->{diagnosis};
}
return $diagnosis;
}
sub _do_diagnosis_history {
my $self = shift;
my $data = shift;
my $dbh = $self->db->{dbix4};
my $diagnosis = $data->{diagnosis}; # original diagnosis
my $signature = $data->{username}; # who changed it
my $reason = $data->{reason}; # why
my $date = $data->{datetime} || '0000-00-00'; # early data didn't record date
my $diagnosis_map = $self->diagnosis_map;
my $options_map = $self->change_options_map;
my $user_id = $self->_get_user_id_from_sig($signature)
|| die "Cannot find users.id for $signature";
my $diagnosis_id = $diagnosis_map->{$diagnosis}
|| die "Cannot find diagnosis_id for $diagnosis";
my %data = (
request_id => $data->{request_id},
diagnosis_id => $diagnosis_id,
option_id => $options_map->{$reason},
user_id => $user_id,
time => join ' ', $date, '00:00:00',
);
$dbh->insert('request_diagnosis_history', \%data);
}
sub _build_status_map {
my $self = shift;
my %status_map = (
Y => 'new', # new_diagnosis = yes
R => 'relapse',
N => 'default', # new_diagnosis = no
);
return \%status_map;
}
sub _build_specimen_quality_map {
my $self = shift;
my %specimen_quality_map = (
Adequate => 'adequate',
Average => 'adequate',
Good => 'good',
Poor => 'poor',
);
return \%specimen_quality_map;
}
sub _build_renamed_diagnoses {
my $self = shift;
# add renamed terms:
my @renamed_pairs = (
'B-cell chronic lymphocytic leukaemia',
'B-cell chronic lymphocytic leukaemia (B-cell CLL)',
'B-CLL - minimal residual disease present',
'B-cell CLL - minimal residual disease present',
'Blastic variant of mantle cell lymphoma',
'Mantle cell lymphoma - blastic variant',
'Chronic myeloproliferative disorder with myelofibrosis',
'Chronic myeloproliferative neoplasm with myelofibrosis',
'CLL-associated EBV lymphoproliferative disorder',
'B-cell CLL-associated EBV lymphoproliferative disorder',
'CML - cytogenetic remission',
'Chronic myeloid leukaemia - cytogenetic remission',
'CML - major molecular response',
'Chronic myeloid leukaemia - major molecular response',
'CML - minor molecular response',
'Chronic myeloid leukaemia - minor molecular response',
'CML - satisfactory molecular response',
'Chronic myeloid leukaemia - satisfactory molecular response',
'CML - unsatisfactory molecular reponse', # originally mis-spelled
'Chronic myeloid leukaemia - unsatisfactory molecular response',
'Diffuse large B-cell lymphoma',
'Diffuse large B-cell lymphoma (DLBCL)',
'Extranodal MZL with rearrangement of MALT-1',
'Extranodal marginal zone lymphoma with rearrangement of MALT-1',
'Hodgkin lymphoma - HIV associated',
'Classical Hodgkin lymphoma - HIV associated',
'MDS treated <5% blasts',
'Myelodysplastic syndrome treated <5% blasts',
'Mixed phenotype acute leukaemia with MLL rearrangement',
'Acute leukaemia - mixed phenotype with MLL rearrangement',
'Monoclonal gammopathy of uncertain significance',
'Monoclonal gammopathy of undetermined significance (MGUS)',
'Myeloma - minimal residual disease present',
'Plasma cell myeloma - minimal residual disease present',
'Atypical CML',
'Atypical chronic myeloid leukaemia',
);
my %h = @renamed_pairs;
return \%h;
}
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_diagnosis_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $map = $dbh->query( 'select name, id from diagnoses' )->map;
# add any diagnoses which have changed names:
my $renamed_diagnoses = $self->renamed_diagnoses;
while ( my ($old, $new) = each %$renamed_diagnoses ) {
$map->{$old} = $map->{$new}; # maps old term to new term for conversion
}
return $map;
}
sub _get_event_time {
my ($self, $function, $date_field, $lab_no) = @_;
my $sql;
if ($function eq 'screened') {
$sql = q!select Date, Time from History where HMDS = ? and
Action = 'screened'!;
}
else {
$sql = sprintf q!select Date, Time from History where HMDS = ? and
Action in ('%s', 'reported and authorised')!, $function;
}
if ( my @date_time = $self->db->{dbix3}->query( $sql, $lab_no )->list ) {
return join ' ', @date_time; # use Date/Time from History if available
}
elsif ($date_field) {
return join ' ', $date_field, '00:00:00'; # time unknown
}
else { # should never happen ?
warn Dumper [ $function, $date_field, $sql, $lab_no ];
return undef;
}
}
=begin # ? not used, was RequestHistory - function should be in Role::User:
sub __get_user_id {
my ($self, $function, $vals) = @_; # function = screener, reportby, authorisedby
my $signature = $vals->{$function} || return;
my $username = lc $self->signature_userid_map->{$signature};
my $user_id = $self->username_userid_map->{$username}
|| $self->substitute_user->{$signature}
|| warn "no user id for $signature ($vals->{dbid})"; # warn $user_id;
}
=cut
=begin # these are wrong !!
sub _do_history_for_revisediag {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
my $diagnosis = $vals->{diagnosis}; # original diagnosis
my $signature = $vals->{revisedby}; # who changed it
my $date = $vals->{revisedate} || '0000-00-00'; # early data didn't record date
my $diagnosis_map = $self->diagnosis_map;
my $user_id = $self->_get_user_id_from_sig($signature)
|| die "Cannot find users.id for $signature";
my $diagnosis_id = $diagnosis_map->{$diagnosis}
|| die "Cannot find diagnosis_id for $diagnosis";
my %data = (
request_id => $vals->{_request_id},
diagnosis_id => $diagnosis_id,
user_id => $user_id,
reason => 'error',
time => join ' ', $date, '00:00:00',
);
$dbh->insert('request_diagnosis_history', \%data);
}
sub _do_history_for_finaldiag {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
my $diagnosis = $vals->{diagnosis}; # original diagnosis
my $signature = $vals->{finalby}; # who changed it
my $date = $vals->{finaldate} || '0000-00-00'; # early data didn't record date
my $diagnosis_map = $self->diagnosis_map;
my $user_id = $self->_get_user_id_from_sig($signature)
|| die "Cannot find users.id for $signature";
my $diagnosis_id = $diagnosis_map->{$diagnosis}
|| die "Cannot find diagnosis_id for $diagnosis";
my %data = (
request_id => $vals->{_request_id},
diagnosis_id => $diagnosis_id,
user_id => $user_id,
reason => 'update',
time => join ' ', $date, '00:00:00',
);
$dbh->insert('request_diagnosis_history', \%data);
}
sub _update_request_diagnosis_with_diagnosis { # Diagnosis:
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
my $diagnosis = $vals->{diagnosis};
my $signature = $vals->{reportby};
my $diagnosis_map = $self->diagnosis_map;
my $user_id = $self->_get_user_id_from_sig($signature)
|| die "Cannot find users.id for $signature";
my $diagnosis_id = $diagnosis_map->{$diagnosis}
|| die "Cannot find diagnosis_id for $diagnosis";
my $date = $vals->{reportdate} || '0000-00-00'; # early data didn't record date
my %data = (
request_id => $vals->{_request_id},
diagnosis_id => $diagnosis_id,
user_id => $user_id,
time => join ' ', $date, '00:00:00',
);
$dbh->insert('request_diagnosis_history', \%data);
}
sub _update_request_diagnosis_with_revised_diagnosis {
my $self = shift;
my $vals = shift;
my $dbh = $self->db->{dbix4};
my $diagnosis_map = $self->diagnosis_map;
my $diagnosis = $vals->{revisediag};
my $signature = $vals->{revisedby};
my $user_id = $self->_get_user_id_from_sig($signature)
|| die "Cannot find users.id for $signature";
my $diagnosis_id = $diagnosis_map->{$diagnosis}
|| die "Cannot find diagnosis_id for $diagnosis";
my $date = $vals->{revisedate} || '0000-00-00'; # early data didn't record date
my %data = (
request_id => $vals->{_request_id},
diagnosis_id => $diagnosis_id,
user_id => $user_id,
time => join ' ', $date, '00:00:00',
);
$dbh->insert('request_diagnosis_history', \%data);
}
=cut
1;
