package LabTest; use Moose; with qw( Role::User Role::RebuildTables ); use namespace::clean -except => 'meta'; use Data::Dumper; use DateTime::Format::MySQL; has $_ => (is => 'ro', isa => 'HashRef', required => 1) foreach qw( db sql ); has log_file => ( is => 'ro', required => 1 ); has $_ => (is => 'ro', isa => 'HashRef', lazy_build => 1) foreach qw( status_map user_id_map hilis4_users field_label_map lab_section_map status_option_map hilis3_lab_test_map hilis4_lab_test_map lab_test_lab_section_map ); has request => ( is => 'ro', isa => 'HashRef', default => sub { {} } ); __PACKAGE__->meta->make_immutable; my @tables = qw( request_lab_test_status request_lab_test_results request_result_summaries request_lab_section_notes ); $|++; sub convert { my $self = shift; my $dbix3 = $self->db->{dbix3}; my $dbix4 = $self->db->{dbix4}; my $dbh4 = $self->db->{dbh4}; # retain case-sensitivity of cols (CHANGES $DB::dbix3 SO MUST REVERSE THIS AFTER): $dbix3->lc_columns = 0; my $log_file = $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_lab_test_results`! ); my $sql = q!select m.DBID, m.HMDS, date_format(m.Date, '%Y') as 'Year', cp.*, fp.*, fs.*, hp.*, mg.*, mg.TimeStamp as 'MolTime', fp.TimeStamp as 'FlowTime', hp.TimeStamp as 'HistTime', fs.TimeStamp as 'ScreenTime', cp.TimeStamp as 'CytoTime' from Main m left join CytoPanel cp on Cyto_ID = DBID left join FlowPanel fp on Flow_ID = DBID left join FlowScreen fs on FS_ID = DBID left join HistoPanel hp on Hist_ID = DBID left join MolGen mg on Mol_ID = DBID!; my $lab_tests = $dbix3->query($sql); # data maps: my $status_map = $self->status_map; my $user_id_map = $self->user_id_map; my $lab_section_map = $self->lab_section_map; my $field_label_map = $self->field_label_map; my $status_option_map = $self->status_option_map; my $hilis3_lab_test_map = $self->hilis3_lab_test_map; my $hilis4_lab_test_map = $self->hilis4_lab_test_map; my $lab_test_lab_section_map = $self->lab_test_lab_section_map; my %unknown_users; # unknown / unwanted entries in cols: my @crap = ( '.','-','_', '=' ); TEST: while ( my $vals = $lab_tests->hash ) { my $dbid = $vals->{DBID}; # $dbid % 1000 || print $dbid, "\n"; # create lab_no -> request.id map if not already exists: my $request_id = $self->request->{$dbid} ||= $dbix4->query( q!SELECT id FROM requests WHERE request_number = ? AND year = ?!, $vals->{HMDS}, $vals->{Year} )->list; FIELD: foreach my $field ( keys %$vals ) { # warn $field; next FIELD unless defined $vals->{$field} && $vals->{$field} ne ''; next FIELD if grep $field eq $_, qw(DBID HMDS Year TimeStamp); next FIELD if $field =~ /_id|req(rec|out)|cig|tpll/i; # cIgu & TPLL discontinued next FIELD if $field =~ /hother|checked/i; # discontinued Checked & HOther1,2,3 next FIELD if $field =~ /time\Z/i; next FIELD if grep $vals->{$field} eq $_, @crap; # deselected tests & other crap # section_details to request_lab_section_notes: if ( $field =~ /(Flow|Hist)Details/ ) { my $time = $vals->{$1 . 'Time'}; # warn $time; my %data = ( request_id => $request_id, lab_section_id => $lab_section_map->{$1}, details => $vals->{$field}, time => $time, ); $dbix4->insert('request_lab_section_notes', \%data); } # if it's a result - put it in request_result_summaries table: elsif ( $field =~ /(Flow|Hist|Mol|Fish|Gen)Result/ ) { my $time = $1 eq 'Flow' ? $vals->{'FlowTime'} : $1 eq 'Hist' ? $vals->{'HistTime'} : $vals->{'MolTime'}; # warn $time; my %data = ( request_id => $request_id, lab_section_id => $lab_section_map->{$1}, results_summary => $vals->{$field}, time => $time, ); $dbix4->insert('request_result_summaries', \%data); } # active request: elsif ( length $vals->{$field} == 1 ) { my $val = $vals->{$field}; my $status = $status_map->{$val}; my $status_option_id = $status_option_map->{$status}; unless ($status_option_id) { my $msg = qq!unrecognised status for $field = $val ! . qq!for $vals->{DBID}\n!; print $log_file, $msg; next FIELD; } my $lab_test_id = $hilis3_lab_test_map->{$field} || die "no lab_test_id for $field"; # warn $lab_test_id; my $time = $self->_get_table_timestamp($field, $vals); # unknown user (or could use screened_by): my $user_id = $self->_get_user_id('unknown'); my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, status_option_id => $status_option_id, user_id => $user_id, time => $time, ); $dbix4->insert('request_lab_test_status', \%data); } # signed-out: elsif ( length $vals->{$field} == 2 ) { my $inits = $self->_get_inits($vals->{$field}); my $user_id = $user_id_map->{uc $inits}; if ($field eq 'Genetics' && ! $user_id) { $user_id = $user_id_map->{HD}; } if (grep $inits eq $_, qw/KR KH/) { $user_id = $self->_get_user_id('henshaw'); } elsif ($inits eq 'GB') { $user_id = $self->_get_user_id('laycock-brown'); } unless ($user_id) { $unknown_users{$field}{$inits}++; #my $msg = qq!unrecognised inits for $field = $inits ! #. qq!for $vals->{DBID}\n!; #print $log_file, $msg; # next FIELD; $user_id = $self->_get_user_id('unknown'); } my $lab_test_id = $hilis3_lab_test_map->{$field}; my $time = $self->_get_table_timestamp($field, $vals); my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, status_option_id => 2, user_id => $user_id, time => $time, ); $dbix4->insert('request_lab_test_status', \%data); } # H&E: elsif ( $field eq 'HandE' ) { my @fields = split ',', $vals->{$field}; my $lab_test_id = $hilis3_lab_test_map->{$field} || die "no lab_test_id for $field"; # warn $lab_test_id; my $time = $self->_get_table_timestamp($field, $vals); my ($user_id, $quality); my $quality_int = 0; FIELD: foreach(@fields) { next if $_ =~ m!/!; # date if ( $_ =~ /\A([A-Za-z]{2})\Z/i ) { my $inits = $self->_get_inits($1); $user_id = $user_id_map->{uc $inits}; # print $inits, "\n" unless $user_id; } elsif ($_ =~ /\A([1-9])\Z/) { $quality_int = $1; } } $user_id ||= $self->_get_user_id('unknown'); my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, status_option_id => 2, user_id => $user_id, time => $time, ); $dbix4->insert('request_lab_test_status', \%data); if ($quality_int > 1) { # 1 used for other reason if ($quality_int >= 7) { $quality = 'good'; } elsif ($quality_int < 6) { $quality = 'poor'; } else { $quality = 'adequate'; } my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, result => $quality, time => $time, ); $dbix4->insert('temp', \%data); } } # CutUp: elsif ( $field eq 'CutUp' ) { my @fields = split ',', $vals->{$field}; my $lab_test_id = $hilis3_lab_test_map->{$field} || die "no lab_test_id for $field"; # warn $lab_test_id; my $time = $self->_get_table_timestamp($field, $vals); # reset: my $user_id = my $paraffin = my $storage = my $pieces_and_blocks = ''; FIELD: foreach(@fields) { next if $_ =~ m!\d+/\d+!; # date # inits in their own field: if ( $_ =~ m!\A([A-Za-z]{2})(/[A-Za-z]{2,3}?)\Z!i ) { my $inits = $self->_get_inits($1); # just get user_id & loop next: $user_id = $user_id_map->{uc $inits}; # print $inits, "\n" unless $user_id; next FIELD; } # 'frozen' in its own field: if (my ($frozen) = $_ =~ /\AF(\d)/i) { my $local_lab_test_id = $hilis4_lab_test_map->{'Frozen tissue'}; my %data = ( request_id => $request_id, lab_test_id => $local_lab_test_id, result => $frozen, time => $time, ); $dbix4->insert('temp', \%data); # warn 'here'; next FIELD; } # paraffin (shared with storage): if ( ($paraffin) = $_ =~ /P(\d)/i) { $pieces_and_blocks .= $paraffin; } # storage (shared with paraffin): if ( ($storage) = $_ =~ /(AE|RP)/i) { $pieces_and_blocks .= $storage; } # resin (maybe shared with storage) - just register status change: # if ( $_ =~ /R(\d)/i && $user_id ) { # only if have user_id # my %data = ( # request_id => $request_id, # user_id => $user_id, # action => 'set Cut Up status to final cut-up', # time => $time, # ); # no point doing this - table rebuilt in History conversion: # $dbix4->insert('request_lab_test_history', \%data); # warn 'here' # } } $user_id ||= $self->_get_user_id('unknown'); my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, status_option_id => 2, user_id => $user_id, time => $time, ); $dbix4->insert('request_lab_test_status', \%data); if ($pieces_and_blocks) { my $local_lab_test_id = $hilis4_lab_test_map->{'Pieces & blocks'}; my %data = ( request_id => $request_id, lab_test_id => $local_lab_test_id, result => $pieces_and_blocks, time => $time, ); $dbix4->insert('temp', \%data); # warn 'here' } # default is 1 resin unless specified otherwise: # unless ($paraffin || $resin) { # my $lab_test_id = $hilis4_lab_test_map->{'Resin blocks'}; # my %data = ( # request_id => $request_id, # lab_test_id => $lab_test_id, # result => 1, # time => $time, # ); # $dbix4->insert('temp', \%data); # warn 'here'; # } } # else die, or will lose data: else { my $val = $vals->{$field}; die "$field ($val) is orphaned"; } } } #=cut # get results & move temp table to request_lab_test_results: $self->do_lab_test_results(); $self->do_histology_sample_type_tests(); $self->convert_to_InnoDB($_) for @tables; $dbix3->lc_columns = 1; # reset to default # print 'Unknown users for tests:'; # print Dumper \%unknown_users; } sub do_lab_test_results { my $self = shift; my $dbix4 = $self->db->{dbix4}; my $dbix3 = $self->db->{dbix3}; my $dbh4 = $self->db->{dbh4}; $self->do_histology_results; $self->do_fish_results; # transfer data from temp to request_lab_test_results in request_id order: my $data = $dbix4->query( q!select request_id, lab_test_id, result from `temp` order by `request_id`,`id`! ); # don't want id while ( my $vals = $data->hash ) { # warn $vals->{request_id}; $dbix4->insert('request_lab_test_results', $vals); } $dbh4->do( q!DROP TABLE `temp`! ); } sub do_histology_results { my $self = shift; my $dbix3 = $self->db->{dbix3}; my $dbix4 = $self->db->{dbix4}; my $histology_data = $dbix3->query('select * from Histology'); my $sql = q!select lt.field_label, lt.id from lab_tests lt join lab_sections ls on lt.lab_section_id = ls.id where section_name = 'Immunohistochemistry' and test_type = 'test'!; my $lab_test_map = $dbix4->query($sql)->map; # hash so duplicate entries removed: my %local_data; while ( my $row = $histology_data->hash ) { # print Dumper $row; next; my $hmds = $row->{HMDS}; my ($request_number,$yr) = $hmds =~ m!H(\d+)/(\d{2})!; # print Dumper ($request_number,$yr); next; # create lab_no -> request.id map if not already exists: my $request_id = $dbix4->query( q!SELECT id FROM requests WHERE request_number = ? AND year = ?!, $request_number, $yr + 2000 )->list; if (! $request_id) { print "no request_id for $hmds\n"; next; } FIELD: foreach my $field ( keys %$row ) { # warn $field; next FIELD unless $field =~ '_'; # all tests have underscore next FIELD unless defined $row->{$field} && $row->{$field} ne ''; my ($panel,$test_name) = split '_', $field; # warn $test_name; $test_name =~ s/bcl/BCL/; # to match lab_tests; $test_name =~ s/Pax(-?)5/PAX-5/; $test_name =~ s/PU-1/PU1/; # $test_name =~ s/EBV/EBV ISH/; # reverted name to EBV; EBV-ISH moved to FISH $test_name =~ s/Co57/CD57/; # combine - Co57 is misprint for CD57 $test_name =~ s/BCL-2/E17/; my $result = $row->{$field}; # warn $result; my $lab_test_id = $lab_test_map->{$test_name} || print "no lab_test_id for $test_name\n"; $local_data{$request_id}{$lab_test_id} = $result; } } foreach my $request_id ( keys %local_data ) { # warn $request_id; # warn Dumper $local_data{$request_id}; next; while ( my ($test_id, $result) = each %{ $local_data{$request_id} } ) { # warn $test_id; warn $result; next; my %data = ( request_id => $request_id, lab_test_id => $test_id, result => $result, ); # warn Dumper \%data; $dbix4->insert( 'temp', \%data ); } } } sub do_fish_results { my $self = shift; my $dbix3 = $self->db->{dbix3}; my $dbix4 = $self->db->{dbix4}; my $fish_data = $dbix3->query('select * from FISH'); my $sql = q!select lt.field_label, lt.id from lab_tests lt join lab_sections ls on lt.lab_section_id = ls.id where section_name = 'FISH' and test_type = 'test'!; # create lab test => test id map: my $lab_test_map = {}; # $dbix4->query($sql)->map; # need to convert new HUGO names to HILIS3 equivalents first: for ( $dbix4->query($sql)->arrays ) { my ($field_name, $lab_test_id) = @$_; $field_name =~ s/(alpha)\-/$1/; $field_name =~ s/(MYC)/c-$1/; $field_name =~ s/CCND1/BCL-1/; $field_name =~ s/(BCL|PAX)(\d)/$1\-$2/; # do AFTER above $field_name =~ s/IGH/IgH/; $field_name =~ s/IGK/IgKappa/; $field_name =~ s/IGL/IgLambda/; $field_name =~ s/TP53/p53/; $lab_test_map->{$field_name} = $lab_test_id; } # warn Dumper $lab_test_map; # hash so duplicate entries removed: my %local_data; while ( my $row = $fish_data->hash ) { # print Dumper $row; next; my $hmds = $row->{HMDS}; my ($request_number,$yr) = $hmds =~ m!H(\d+)/(\d{2})!; # print Dumper ($request_number,$yr); next; # create lab_no -> request.id map if not already exists: my $request_id = $dbix4->query( q!SELECT id FROM requests WHERE request_number = ? AND year = ?!, $request_number, $yr + 2000 )->list; if (! $request_id) { print "no request_id for $hmds\n"; next; } FIELD: foreach my $field ( keys %$row ) { # warn $field; next FIELD if grep $field eq $_, qw(F_ID HMDS Diagnosis Time); next FIELD unless defined $row->{$field} && $row->{$field} ne ''; my $result = $row->{$field}; # warn $result; my $lab_test_id = $lab_test_map->{$field} || print "no lab_test_id for $field\n"; $local_data{$request_id}{$lab_test_id} = $result; } } foreach my $request_id ( keys %local_data ) { # warn $request_id; # warn Dumper $local_data{$request_id}; next; while ( my ($test_id, $result) = each %{ $local_data{$request_id} } ) { # warn $test_id; warn $result; next; my %data = ( request_id => $request_id, lab_test_id => $test_id, result => $result, ); # warn Dumper \%data; $dbix4->insert( 'temp', \%data ); } } } sub do_histology_sample_type_tests { my $self = shift; my $dbix3 = $self->db->{dbix3}; my $dbix4 = $self->db->{dbix4}; my $hilis3_lab_test_map = $self->hilis3_lab_test_map; { # from H&E worklist: my $sql = q!SELECT `DBID`,`HMDS`, YEAR(`Date`) as 'Year' FROM `Main` LEFT JOIN `HistoPanel` on `Hist_ID` = `DBID` WHERE `HandE` IS NULL AND `Specimen` REGEXP '[DGLRX][BL|F|SL|U]|T[B.|S.]|BMAT'!; my $lab_test_id = $hilis3_lab_test_map->{HandE}; my $query = $dbix3->query($sql); while ( my $vals = $query->hash ) { # print Dumper $row; next; my $dbid = $vals->{DBID}; # warn Dumper $vals; # create lab_no -> request.id map if not already exists: my $request_id = $self->request->{$dbid} ||= $dbix4->query( q!SELECT id FROM requests WHERE request_number = ? AND year = ?!, $vals->{HMDS}, $vals->{Year} )->list; my $hmds = sprintf 'H%s/%02d', $vals->{HMDS}, $vals->{Year} - 2000; my $sql = q!select UserID, Date, Time from History where HMDS = ? and Action = 'registered'!; my $history = $dbix3->query($sql, $hmds)->hash; # warn Dumper $history; my $username = lc $history->{UserID}; my $user_id = $self->hilis4_users->{$username} || warn "no user_id for $username [$hmds]"; # Date & Time will fail my $time = join ' ', $history->{Date}, $history->{Time}; $time ||= DateTime::Format::MySQL->format_datetime(DateTime->now); my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, status_option_id => 1, user_id => $user_id || 24, # unknown user time => $time, ); $dbix4->insert('request_lab_test_status', \%data); } } { # from CutUp worklist my $sql = q!SELECT `DBID`,`HMDS`, YEAR(`Date`) as 'Year' FROM `Main` LEFT JOIN `HistoPanel` on `Hist_ID` = `DBID` LEFT JOIN `Report` on Rpt_ID = DBID WHERE `CutUp` IS NULL AND `ReportBy` IS NULL AND `Specimen` REGEXP '[DFGLRX]U|[DGLRX]F|BMAT|TBP'!; my $lab_test_id = $hilis3_lab_test_map->{CutUp}; my $query = $dbix3->query($sql); while ( my $vals = $query->hash ) { # print Dumper $row; next; my $dbid = $vals->{DBID}; # create lab_no -> request.id map if not already exists: my $request_id = $self->request->{$dbid} ||= $dbix4->query( q!SELECT id FROM requests WHERE request_number = ? AND year = ?!, $vals->{HMDS}, $vals->{Year} )->list; my $hmds = sprintf 'H%s/%02d', $vals->{HMDS}, $vals->{Year} - 2000; my $sql = q!select UserID, Date, Time from History where HMDS = ? and Action = 'registered'!; my $history = $dbix3->query($sql, $hmds)->hash; my $username = lc $history->{UserID}; my $user_id = $self->hilis4_users->{$username} || warn "no user_id for $username [$hmds]"; # Date & Time will fail my $time = join ' ', $history->{Date}, $history->{Time}; $time ||= DateTime::Format::MySQL->format_datetime(DateTime->now); my %data = ( request_id => $request_id, lab_test_id => $lab_test_id, status_option_id => 1, user_id => $user_id || 24, # unknown user time => $time, ); $dbix4->insert('request_lab_test_status', \%data); } } } sub _get_table_timestamp { my ($self, $field, $vals) = @_; my $lab_test_lab_section_map = $self->lab_test_lab_section_map; my $time; if( $lab_test_lab_section_map->{$field} eq 'Cytochemistry' ) { $time = $vals->{CytoTime}; } elsif( $lab_test_lab_section_map->{$field} eq 'Flow cytometry' ) { $time = $vals->{FlowTime}; } elsif( $lab_test_lab_section_map->{$field} eq 'Flow screen' ) { $time = $vals->{ScreenTime}; } elsif( $lab_test_lab_section_map->{$field} =~ /\AHistology/ ) { # H&E/CutUp $time = $vals->{HistTime}; } elsif( $lab_test_lab_section_map->{$field} eq 'Immunohistochemistry' ) { $time = $vals->{HistTime}; } elsif( $lab_test_lab_section_map->{$field} eq 'Molecular' ) { $time = $vals->{MolTime}; } elsif (grep $field eq $_, qw/FISH Genetics/) { $time = $vals->{MolTime}; } elsif (grep $field eq $_, qw/PML Ki67/) { # Ki67 now 'selection' $time = $vals->{FlowTime}; } else { warn "Cannot set a timestamp for field $field" } return $time; } sub _build_hilis3_lab_test_map { my $self = shift; my $dbh = $self->db->{dbix4}; my $map = $dbh->query( q!select `TestName`, `id` from `_lab_test_map`! )->map; return $map; } sub _build_hilis4_lab_test_map { my $self = shift; my $dbh = $self->db->{dbix4}; my $map = $dbh->query( q!select `field_label`, `id` from `lab_tests`! )->map; return $map; } sub _build_user_id_map { my $self = shift; my $dbh3 = $self->db->{dbix3}; my $dbh4 = $self->db->{dbix4}; my $h4_users = $self->hilis4_users; my $h3_users = $dbh3->query( q!select `Initials`, `UserID` from `Users` where `Initials` is not null! )->map; # change RD: # $h3_users->{RD} = 'DE TUTE'; my %map = map { my $userid = $h3_users->{$_}; # warn $userid; $_ => $h4_users->{lc $userid}; # warn $h4_users->{lc $userid}; } keys %$h3_users; return \%map; } sub _build_hilis4_users { my $self = shift; my $dbh4 = $self->db->{dbix4}; my $users = $dbh4->query( q!select `username`, `id` from `users`! )->map; return $users; } sub _build_field_label_map { my $self = shift; my $dbh = $self->db->{dbix4}; my $map = $dbh->query( q!select `id`, `field_label` from `lab_tests`! )->map; return $map; } sub _build_status_map { my $self = shift; my %map = ( 'x' => 'new', 'p' => 'new', '+' => 'stabilised', '/' => 'microtomy', 'c' => 'checked', 'r' => 'primary report', 's' => 'setup', ); return \%map; } sub _build_status_option_map { my $self = shift; my $dbh = $self->db->{dbix4}; my $map = $dbh->query( 'select description, id from lab_test_status_options')->map; return $map; } sub _build_lab_test_lab_section_map { my $self = shift; my $dbh = $self->db->{dbix4}; my $sql = q!select `TestName`, `section_name` from `_lab_test_map` ltm join `lab_tests` lt on ltm.id = lt.id join `lab_sections` ls on lt.lab_section_id = ls.id!; my $map = $dbh->query( $sql )->map; return $map; } sub _build_lab_section_map { my $self = shift; my $dbh = $self->db->{dbix4}; my $lab_sections = $dbh->query( q!select `section_name`, `id` from `lab_sections`! )->map; # add these: $lab_sections->{Flow} = $lab_sections->{'Flow cytometry'}; $lab_sections->{Hist} = $lab_sections->{'Immunohistochemistry'}; $lab_sections->{Fish} = $lab_sections->{'FISH'}; $lab_sections->{Mol} = $lab_sections->{'Molecular'}; $lab_sections->{Gen} = $lab_sections->{'Cytogenetics'}; return $lab_sections; } sub _get_user_id { my ($self, $username) = @_; my $user_map = $self->hilis4_users; return $user_map->{$username}; } sub _get_inits { my $self = shift; my $inits = shift; { # corrections: $inits = 'PE' if grep $inits eq $_, qw(+_ +P 00 +p); $inits = 'AR' if grep $inits eq $_, qw(\r AF CM); $inits = 'SO' if grep $inits eq $_, qw(S0); # zero $inits = 'AK' if $inits eq 'AD'; $inits = 'FB' if $inits eq 'XB'; $inits = 'IF' if $inits eq 'IM'; # H&E/CutUp # $inits = ? if $inits eq 'LD'; # H&E/CutUp } # AN & NA = unknown & not applicable, so converted to 'unknown user' return $inits; } 1;