• Files
• Commits
• Log
• Graph
• Stats

package Test;

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

has db  => (is => 'ro', isa => 'HashRef', required => 1);
has sql => (is => 'ro', isa => 'HashRef', required => 1);

has unknown_referrers => ( is => 'ro', isa => 'HashRef', default => sub { {} } );

# need to force delay until after db passed in from new():
has specimen_map    => ( is => 'ro', isa => 'HashRef', lazy_build => 1 );
has options_map     => ( is => 'ro', isa => 'HashRef', lazy_build => 1 );
has known_referrers => ( is => 'ro', isa => 'HashRef', lazy_build => 1 );
has diagnosis_map => ( is => 'ro', isa => 'HashRef', lazy_build => 1 );

has private_referrers 				=> ( is  => 'ro', isa => 'HashRef', lazy_build => 1 );
has known_location_referrers 		=> ( is  => 'ro', isa => 'HashRef', lazy_build => 1 );
has known_location_screen_referrers => ( is  => 'ro', isa => 'HashRef', lazy_build => 1 );

no Moose;
__PACKAGE__->meta->make_immutable;

my $total_unknowns = 0;

=begin
sub run {
    my $self = shift; # warn 'HERE'; # appears after _build_specimen_map if lazy_build = 1

    my @specimens = qw(BMAT PB LBL PB XB);

    my @unique = keys %{
        { map { $_ => 1 } @specimens }
    };

    my $specimen_map = $self->specimen_map; # print Dumper $specimen_map;

    SPECIMEN: foreach my $specimen(@unique) {
        if ( my $specimen_id = $specimen_map->{$specimen} ) {
			warn "$specimen = $specimen_id";
        }
        else {
            print "no such sample_code: $specimen\n";
            next SPECIMEN;
        }
    }
}
=cut

sub run {
    my $self = shift;

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

    my $REQ = q!
        SELECT m.`DBID`, YEAR(m.`Date`) as 'year', m.`HMDS`, p.`LName`, p.`FName`,
            p.`DoB`, p.`Sex`, p.`PatNo`, p.`NHSNo`, m.`Source`, m.`Specimen`,
            s.`OrgCode`,m.`Clinician`, c.`cons_code`, c.`last_name`,
			m.`TimeStamp` as 'main_time', p.`TimeStamp` as 'pid_time',
            r.`InitialDiag` as 'screen'
        FROM Main m, Report r, Source s, PID p, Clinician c
        WHERE cons_code IS NULL
            AND m.DBID = r.Rpt_ID
            AND m.Source = s.Src_ID
            AND m.Pat_ID = p.P_ID
            AND m.Clinician = c.c_id
        ORDER BY m.DBID!;

    my $hilis3 = $dbix3->query($REQ);

    while ( my $vals = $hilis3->hash ) {
        $self->_get_referrer_code($vals);
    }
}

sub test_diagnosis {
	my $self = shift;
	
	my $dbix3 = $self->db->{dbix3}; 
	my $dbix4 = $self->db->{dbix4};
	
	my $hilis3_sql = q!select HMDS, year(Date) as 'year', if(FinalDiag is not null,
		FinalDiag, if(ReviseDiag is not null, ReviseDiag, Diagnosis)) as 'diagnosis'
		from Main, Report where DBID = Rpt_ID!;
		
	my $hilis4_diagnosis_sql = q!select t3.name from requests t1 join request_report
		t2 on t2.request_id = t1.id join diagnoses t3 on t2.diagnosis_id = t3.id
		where t1.request_number = ? and t1.year = ?!;
	
	my $hilis3 = $dbix3->query($hilis3_sql);
	
	while ( my $vals = $hilis3->hash ) { # warn $diagnosis;
		my $hilis3_diagnosis = $vals->{diagnosis};
		my $hilis4_diagnosis
			= $dbix4->query( $hilis4_diagnosis_sql, $vals->{hmds}, $vals->{year} )->list;
	
		{
			no warnings 'uninitialized'; # some records without diagnosis
			if ( $hilis3_diagnosis ne $hilis4_diagnosis ) {
				warn "$hilis3_diagnosis ne $hilis4_diagnosis for $vals->{hmds} / $vals->{year}";
			}
		}
    }	
}

sub phonelog {
	my $self = shift;
	
	my $dbix3 = $self->db->{dbix3}; 
	my $dbix4 = $self->db->{dbix4};
	
	my $hilis3 = $dbix3->query(q!select * from PhoneLog!);
	
	my $users_map = $dbix4->query('select username, id from users')->map;		
		
	LOG:
	while ( my $vals = $hilis3->hash ) { # warn $diagnosis;
		my ($hmds, $yr) = $vals->{labno} =~ m!H(\d+)/(\d{2})!;
		
		my $request_id = $dbix4->query( q!select id from requests where request_number
			= ? and year = ?!, $hmds, $yr + 2000 )->list;
		
		if (! $request_id ) {
			warn "no request_id for $vals->{labno}";
			next LOG;
		}
		
		my $user_id = $vals->{userid} eq 'ADMIN' ?
			# substitute RAJ for ADMIN
			$users_map->{raj}
				: $users_map->{ lc $vals->{userid} };
		
		if (! $user_id ) {
			warn "no user_id for $vals->{userid}";
			next LOG;
		}
		
		my %data = (
			request_id => $request_id,
			user_id    => $user_id,
			status     => lc $vals->{direction} . 'bound',
			contact    => $vals->{contact},
			details    => $vals->{summary},
			time       => $vals->{datetime},
		);
		$dbix4->insert('request_phone_log', \%data);
    }	
	
}

sub clinical_trials {
    my $self = shift;
    
    my $dbh3  = $self->db->{dbix3};
    my $dbh4  = $self->db->{dbix4};
    
    my $hilis3_trials = $dbh3->query('select TrialName, id from Trials')->map;
    my $hilis4_trials = $dbh4->query('select trial_name, id from clinical_trials')->map;    
    
    { # 'Community monitoring' changed to 'HMDS outreach'
        my $cmp_id = $hilis3_trials->{'Community monitoring'};
        delete $hilis3_trials->{'Community monitoring'};
        $hilis3_trials->{'HMDS outreach'} = $cmp_id;
    }
    
    # map hilis3 Trials.id => hilis4 clinical_trials.id    
    my %map = map {
        my $hilis3_trial_name = $_; # warn $hilis3_trial_name;
        my $hilis3_trial_id = $hilis3_trials->{$hilis3_trial_name};
        my $hilis4_trial_id = $hilis4_trials->{$hilis3_trial_name};
        
        $hilis3_trial_id => $hilis4_trial_id;
    } keys %$hilis3_trials;
    
    # warn Dumper \%map;
	my $sql = q!select HMDS, year(Date) as 'year', Study from Main where Study is not null!;
	my $hilis3_trial_cases = $dbh3->query( $sql );

    while ( my $vals = $hilis3_trial_cases->hash ) {
		my $request_id = $dbh4->query( q!select id from requests where request_number
			= ? and year = ?!, $vals->{hmds}, $vals->{year})->list;

		my $hilis3_trial_id = $vals->{study};
		
		my %data = (
			request_id => $request_id,
			trial_id   => $map{$hilis3_trial_id},
		);
		$dbh4->insert( 'request_trial', \%data );
	}
}

sub request_diagnosis_history {
	my $self = shift;

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

	$self->rebuild_tables(['request_diagnosis_history']);
	
	my $REQ = q!
        SELECT
            m.`DBID`,
            m.`HMDS`,
            YEAR(m.`Date`) as 'year',
            r.`Diagnosis`,
            r.`ReportBy`,
            r.`ReportDate`,
            r.`ReviseDiag`,
            r.`RevisedBy`,
            r.`ReviseDate`,
            r.`FinalDiag`,
            r.`FinalBy`,
            r.`FinalDate`
        FROM Main m
			LEFT JOIN Report r on m.DBID = r.Rpt_ID
		WHERE `ReviseDiag` IS NOT NULL OR `FinalDiag` IS NOT NULL
        ORDER BY m.DBID!;
		
	my $hilis3 = $dbix3->query($REQ);
	
    while ( my $vals = $hilis3->hash ) {		
		my $request_id = 
			$dbix4->query( q!SELECT id FROM requests WHERE request_number = ?
				AND year = ?!, $vals->{hmds}, $vals->{year} )->list;

		$vals->{_request_id} = $request_id
			|| die "Cannot find request_id for $vals->{hmds}, $vals->{year}";

		if ( $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);
			}
		}
		elsif ( $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);
			}
		}
	}
	$self->do_update_from_history_file;
}

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 $date       = $data->{datetime} || '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   => $data->{request_id},
        diagnosis_id => $diagnosis_id,
        user_id      => $user_id,
		reason       => $data->{reason},
        time         => join ' ', $date, '00:00:00',
    );
    $dbh->insert('request_diagnosis_history', \%data);		
}

sub additional_options {
    my $self = shift;
	
    my $dbh3  = $self->db->{dbix3};
    my $dbh4  = $self->db->{dbix4};

	# urgent, private, copy_to, doi, teaching:
    my $options = $self->options_map;
	
	my $sql = q!select HMDS, year(Date) as 'year', Urgent, DoI, Teaching, Private,
		CopyTo from Main!;
	
	my $src = $dbh3->query( $sql );
	while ( my $vals = $src->hash ) {
		next unless grep $vals->{$_}, qw(urgent private teaching copyto doi);
		
		my $request_id = $dbh4->query( q!select id from requests where request_number
			= ? and year = ?!, $vals->{hmds}, $vals->{year})->list;

		foreach my $opt( keys %$options ) {
			next unless $vals->{$opt};
			
			my %data = (
				request_id => $request_id,
				option_id  => $options->{$opt},
			);
			$dbh4->insert('request_option', \%data);
		}		
	}    
}

sub block_ref {
    my $self = shift;
	
    my $dbh3  = $self->db->{dbix3};
    my $dbh4  = $self->db->{dbix4};
	
	$self->clear_table('request_external_ref');
	
	my $sql = q!select HMDS, year(Date) as 'year', BlockRef from Main where
		BlockRef is not null!;
	
	my $src = $dbh3->query( $sql );
	while ( my $vals = $src->hash ) {
		my $request_id = $dbh4->query( q!select id from requests where request_number
			= ? and year = ?!, $vals->{hmds}, $vals->{year})->list;
			
		my ($ref, $status) = $vals->{blockref} =~ /(.*)\[(.*)\]\Z/; # foo [bar]
		if ($ref) { $ref =~ s/\s+$// }; # remove trailing space(s)
		
		# set external ref to $ref if exists, or $block_ref:
		my $external_ref = $status ? $ref : $vals->{blockref};
		
		my %data = (
			request_id => $request_id,
			external_reference => $external_ref,
		);
		if ($status) { $data{status} = $status }
		
		$dbh4->insert('request_external_ref', \%data);
	}
}

sub general_notes {
    my $self = shift;
	
    my $dbh3  = $self->db->{dbix3};
    my $dbh4  = $self->db->{dbix4};
	
	my $sql = q!select HMDS, year(Date) as 'year', Notes from Main join Others
		on O_ID = DBID where length(Notes) > 1!; # exclude crap
	
	my $src = $dbh3->query( $sql );
	while ( my $vals = $src->hash ) {
		my $request_id = $dbh4->query( q!select id from requests where request_number
			= ? and year = ?!, $vals->{hmds}, $vals->{year})->list;
			
		my %data = (
			request_id => $request_id,
			detail     => $vals->{notes},
		);
		$dbh4->insert('request_general_notes', \%data);
	}
}

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

	my $REQ = q!
        SELECT
			request_id,
			action,
			user_id,
			time
        FROM request_history
		WHERE action regexp 'FinalDiag|ReviseDiag'
		ORDER BY time!;
		
	my $query = $dbix4->query($REQ);
	
    while ( my $vals = $query->hash ) {
		# both if's in case both entered together:
		if ($vals->{action} =~ /ReviseDiag/) {
			$dbix4->update('request_diagnosis_history',
				{ time => $vals->{time} }, # set
				{ # where:
					request_id => $vals->{request_id},
					user_id    => $vals->{user_id},
					reason     => 'error',
				} 
			);
		}
		if ($vals->{action} =~ /FinalDiag/) {
			$dbix4->update('request_diagnosis_history',
				{ time => $vals->{time} }, # set
				{ # where:
					request_id => $vals->{request_id},
					user_id    => $vals->{user_id},
					reason     => 'update',
				} 
			);
		}
	}
}

sub resolved_nhsno {
    my $self = shift;

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

	{ # split mname from fname:
		my $sql = q!SELECT fname, nhsno FROM test.ResolvedNHSNo where fname like '% %'!;
		for my $row ( $dbh4->query($sql)->hashes ) {
			my ($fname, $mname) = split ' ', $row->{fname};
			$dbh4->update(
				'test.ResolvedNHSNo',
				{ fname => $fname, mname => $mname },
				{ nhsno => $row->{nhsno} },
			);
		}
	}

	{ # update timestamp:
		my @list = $dbh4->query('SELECT nhsno FROM test.ResolvedNHSNo')->flat;
		foreach my $nhsno (@list) { # 1st one will do if >1:
			$dbh3->query('SELECT TimeStamp FROM PID WHERE NHSNo = ?', $nhsno)->into(my $time);
			$dbh4->update(
				'test.ResolvedNHSNo',
				{ pid_time => $time },
				{ nhsno => $nhsno },
			);			
		}
	}
}

sub _build_specimen_map { # warn 'HERE'; # to check it only loads once
    my $self = shift;

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

    my $specimen_map = $dbh->query('SELECT sample_code, id FROM specimens')->map;
    #    ->map_hashes('sample_code');

    return $specimen_map;
}

sub _build_options_map {
    my $self = shift;
    
    my $dbh4  = $self->db->{dbix4};
    
    my $options = $dbh4->query( 'select option_name, id from additional_options')->map;
    
    { # 'CopyTo' => 'copy_to'
        my $cc_id = $options->{copy_to};
        delete $options->{copy_to};
        $options->{copyto} = $cc_id;
    }
    
    return $options;
}

sub _build_diagnosis_map {
    my $self = shift;

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

    my $map = $dbh->query( 'select name, id from diagnoses ')->map;

    return $map;
}

sub _get_referrer_code {
	my $self = shift;
	my $vals = shift;

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

	my $clinician_code = $vals->{clinician};
	my $clinician_name = $vals->{last_name};

    if ( my ($g_id) = $clinician_code =~ /\A(G\d+)/ ) {
        return $self->gp_practice->{$g_id}->{gp_code} || 'G9999998';
	}
	# Clinician = 'General Practitioner' & Source = 'Surgery/Medical Centre':
	elsif ( $clinician_code == 25 && $vals->{source} == 78 ) { #
		return 'G9999998';
	}
	# Clinician = 'Not stated/known' or 'Unknown':
	elsif (	grep $clinician_code == $_, (62, 643) ) { #
		return 'C9999998';
	}
    # known referrers list:
    elsif ( $self->known_referrers->{$clinician_name} ) { # warn 'known referrer';
        return $self->known_referrers->{$clinician_name}{ref_code};
    }

	if ( $vals->{orgcode} ) { # null if Source = 54, 57, 78
		my ($org_code) = $vals->{orgcode} =~ /\A(...)/; # just need 1st 3 chars

        { # known private referrers:
            my $referrers = $self->private_referrers;
            if ( $referrers->{$clinician_name} ) { # warn 'private referrer';
                return $referrers->{$clinician_name}{ref_code}
                    if $org_code =~ /$referrers->{$clinician_name}{org_code}/;
            }
        }
        { # known location referrers:
            my $referrers = $self->known_location_referrers;
            if ( $referrers->{$clinician_name} ) { # warn 'known location referrer';
                return $referrers->{$clinician_name}{ref_code}
                    if $org_code eq $referrers->{$clinician_name}{org_code};
            }
        }
        { # known location & initialdiag/screen referrers:
            my $referrers = $self->known_location_screen_referrers;
            if ( $referrers->{$clinician_name} ) { # warn 'known location screen referrer';
                return $referrers->{$clinician_name}{ref_code}
                    if $org_code eq $referrers->{$clinician_name}{org_code}
                    && $vals->{screen} eq $referrers->{$clinician_name}{screen};
            }
        }
        { # if clinician name unique to location:
            my $sql = q!select national_code from clinicians c join clinician_organisation
                co on (co.clinician_id = c.id) where `surname` = ? and `region_prefix` = ?
                having count(*) = 1!;

            if ( my $referrer_code =
               $dbh->query($sql, $vals->{last_name}, $org_code)->list ) {
                # add it to $self->known_location_referrers: ? IS THIS SAFE - NO!!!!!
                # overwrites existing Clinician entries:
                # $self->known_location_referrers->{$clinician_name} =
                #    { org_code  => $org_code, ref_code  => $referrer_code };
                return $referrer_code if $referrer_code;
            }
        }
	}
    # warn Dumper [ $vals->{dbid}, $clinician_name, $vals->{orgcode} || 'NULL ORG_CODE' ];
    $self->unknown_referrers->{$clinician_name}{ $vals->{orgcode} || 'UNKNOWN' }++;
    $total_unknowns++;
   # can't match it so return unknown:
	return 'C9999998';
}

sub _build_known_referrers {
    my $self = shift;

    # names that occur only once in clinicians
    # (gets incremented in _get_referrer_code):
	my %referrers = (
        Parapia => { ref_code => 'C1741582' },
        McVerry => { ref_code => 'C1356458' },
        Hillmen => { ref_code => 'C3084182' },
        Moreton => { ref_code => 'C4043672' },
    );

    return \%referrers;
}

sub _build_private_referrers {
	my $self = shift;

	my %referrers = (
		Williams => { org_code  => 'NT[38]', ref_code  => 'C3198942' },
		Child    => { org_code  => 'NT[23]', ref_code  => 'C0139522' },
		Owen     => { org_code  => 'NT2',    ref_code  => 'C3271078' },
		Batman   => { org_code  => 'NT8',    ref_code  => 'C2469160' },
        Tijani   => { org_code  => 'NT8',    ref_code  => 'C4785635' },
        Morgan   => { org_code  => 'NT2',    ref_code  => 'C2718723' },
        Horgan   => { org_code  => 'NT3',    ref_code  => 'C2918341' },
        Gouldesbrough
                 => { org_code  => 'NT8',    ref_code  => 'C2604231' },
    );

    return \%referrers;
}

sub _build_known_location_referrers {
	my $self = shift;
=begin
HILIS3:
SELECT * FROM Main,Source,Clinician
WHERE OrgCode like 'RR8%' AND
last_name like 'clarke%' AND
Src_ID = Source AND
Clinician = c_id

HILIS4:
select national_code, initials, display_name
from clinicians c
     join clinician_organisation co on (co.clinician_id = c.id)
     join hospital_departments h on (co.hospital_department_id = h.id)
where `surname` = 'thomas' and `region_prefix` = 'rwy'
# having count(*) = 1
=cut

	my %referrers = (
		Child    => { org_code  => 'RR8', ref_code  => 'C0139522' },
		Smith    => { org_code  => 'RR8', ref_code  => 'C2653558' },
		Johnson  => { org_code  => 'RR8', ref_code  => 'C3244348' },
		Morgan   => { org_code  => 'RR8', ref_code  => 'C2718723' },
		Knight   => { org_code  => 'RR8', ref_code  => 'C3079991' },
		Newton   => { org_code  => 'RAE', ref_code  => 'C3555307' },
        Calvert  => { org_code  => 'RAE', ref_code  => 'C3313507' },
        Elliott  => { org_code  => 'RAE', ref_code  => 'C3468531' },
        Patmore  => { org_code  => 'RWA', ref_code  => 'C3309946' }, # Patmore, RD
        Williams => { org_code  => 'RWD', ref_code  => 'C3198942' },
        Carter   => { org_code  => 'RWY', ref_code  => 'C2378716' },
        Thomas   => { org_code  => 'RWY', ref_code  => 'C1624801' },
        McEvoy   => { org_code  => 'RCD', ref_code  => 'C2394967' }, # Bynoe
        Lee      => { org_code  => 'RXF', ref_code  => 'C4202019' }, # Lee, RA
        Braithwaite
                  => { org_code  => 'RWY', ref_code  => 'C2308535' },
        # 2 Macdonalds at Mid-Yorks - Histopathology & Dermatology (Macdonald Hull)
#        Macdonald => { org_code  => 'RXF', ref_code  => 'C1552852' }, # MacDonald Hull
	);

	return \%referrers;
}

sub _build_known_location_screen_referrers {
	my $self = shift;

	my %referrers = (
		Wilson => { org_code => 'RR8', ref_code  => 'C2645429', screen => 'HIV' },
		Clarke => { org_code => 'RR8', ref_code  => 'C2718156', screen => 'HIV' },
    );

	return \%referrers;
}

1;