• Files
• Commits
• Log
• Graph
• Stats

package Main;

# rebuilds patients, patient_case, requests, request_specimen
# & request_initial_screen tables:
# anonymises patients if source is LTH server

=begin # how it works:
passes hilis3 data to Roles::Patient::get_patient_id to see if nhs_number match
exists, if so uses patients.id. Otherwise, if hilis3 data has nhs_no, creates
new patient record & uses new patients.id. Next, tries to match on last_name,
first_name, dob & unit_number. 
=cut

use Moose;
    with qw(
        Role::User
		Role::Main
        Role::Report
        Role::Specimen
        Role::Patient
        Role::Referrer
        Role::RebuildTables
    );

use namespace::clean -except => 'meta';

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

has $_ => ( is => 'ro', required => 1 )
	foreach qw(log_file path_to_app );

has cfg => ( is => 'ro', isa => 'Config::Tiny', required => 1 );

# need to force delay until after db passed in from new():
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
    foreach qw(
		gp_practice
		referral_source
		request_status_options_map
		resolved_nhsno_duplicates_map
		screen_map
		signature_userid_map
        specimen_map
		substitute_user
		unknown_source
        username_userid_map
		substitute_screening_terms
		unknown_referrer_id_referrer_department_id_map
    );

has $_ => ( is => 'rw', isa => 'HashRef', default => sub { {} } )
	foreach qw(	no_referral_source nhs_number_map );

has path_to_app => ( is  => 'ro', isa => 'Str', required => 1 );

__PACKAGE__->meta->make_immutable;

use Data::Dumper;
use Anonymise::LIMS;

my @tables = qw(
    patients
    requests
    patient_case
	request_trial
	request_option
	request_report
    request_specimen
	request_external_ref
    request_initial_screen
	request_gross_description
    request_diagnosis_history
);

sub convert {
    my $self = shift;
#=begin
    # open my $file, '>', './new.txt' or die $!;
    $self->rebuild_tables(\@tables);

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

	my $log_file = $self->log_file;

	$dbix4->keep_statements = 50; # might speed up process with a lot of queries

    my $REQ = q!
        SELECT
            m.`DBID`,
            m.`HMDS`,
            m.`Date`,
            YEAR(m.`Date`) as 'year',
            m.`Specimen`,
            m.`Source`,
            m.`Clinician`,
			m.`BlockRef`,
			m.`Study`,
			m.`Urgent`,
			m.`DoI`,
			m.`Private`,
			m.`CopyTo`,
			m.`Teaching`,
			m.`TimeStamp` as 'main_time',
            p.`LName`,
            p.`FName`,
            p.`DoB`,
            p.`Sex`,
            p.`PatNo`,
            p.`NHSNo`,
            p.`TimeStamp` as 'pid_time',
            s.`OrgCode`,
            c.`cons_code`,
            c.`last_name`,
            r.`Rpt_ID`,
            r.`InitialDiag`,
            r.`Screener`,
            r.`ScreenDate`,
            r.`Diagnosis`,
            r.`ReportBy`,
            r.`ReportDate`,
            r.`AuthorisedBy`,
            r.`AuthDate`,
            r.`ReviseDiag`,
            r.`RevisedBy`,
            r.`ReviseDate`,
            r.`FinalDiag`,
            r.`FinalBy`,
            r.`FinalDate`,
            r.`Comment`, r.`ClinDetails`,
			r.`NewDiagnosis`,
            r.`SpecQuality`,
			r.`GrossDesc`,
			r.`TimeStamp` as 'ReportTime'
        FROM Main m
			LEFT JOIN Report r on m.DBID = r.Rpt_ID
            LEFT JOIN Source s on m.Source = s.Src_ID
            LEFT JOIN PID p on m.Pat_ID = p.P_ID
            LEFT JOIN Clinician c on m.Clinician = c.c_id
        ORDER BY m.DBID!;

    my $t0 = DateTime->now;
    
	my $hilis3 = $dbix3->query($REQ);
        my $duration = DateTime->now - $t0;
        printf "hilis3 query took %sm %ss\n", $duration->minutes, $duration->seconds;

    REQUEST:
    while ( my $vals = $hilis3->hash ) {
        $vals->{dbid} % 1000 ||
            print $vals->{dbid}, "\n"; # print $SELECT_PATIENT_ID . "\n";

        my @first_names = split ' ', $vals->{fname};

        if ($first_names[1]) {
            if (length $first_names[1] > 1) {
                @{$vals}{qw/fname mname/} = @first_names;
            }
            else { # don't want single letter middle name !
                $vals->{fname} = $first_names[0];
            }
        }
#=cut

#=begin
       # retrieve/create patient.id:
        my $patient_id = $self->get_patient_id($vals)
			or die 'No patient_id value set';

        my $referral_source_id = 0;

        { # changed Notts. City Hospital org_code to match current etrust file:
            no warnings 'uninitialized';
            $vals->{orgcode} =~ s/^(RCS)/RHA/;
        }

        my $org_code  = $vals->{orgcode}   || '';
        my $clinician = $vals->{clinician} || '';
        my $source    = $vals->{source}    || '';

		# cons_code only exists for Clinician > 643:
		my $referrer_code = $vals->{cons_code}
			|| $self->get_referrer_code($vals);

		my $referrer_id = $self->convert_referrer_code_to_id($referrer_code);

        if (! $referrer_id) {
            $referrer_id = $clinician =~ /\A(G\d+)/ ?
                $self->unknown_referrer_id->{practitioner} :
                    $self->unknown_referrer_id->{clinician};

            warn "Cannot find referrer.id for $referrer_code [$vals->{dbid}]";
        }

        # if Main.Clinician = G\d+ :
        if ( my ($g_id) = $clinician =~ /\A(G\d+)/ ) {
            my $practice_code = $self->gp_practice->{$g_id}->{practice_code};

            $referral_source_id = $self->referral_source->{$practice_code}
            || $self->unknown_source->{78}; # unknown practice
        }
        # unknown OrgCode due to m.Source = 57 (Other), 78 (Surgery/MC),
        # 54 (Mid Yorks Nuffield), PathLinks, Ghana, etc
        elsif ( my $ref_source = $self->unknown_source->{$source} ) {
#            warn ($vals->{dbid},'UNKNOWN SOURCE');
            $referral_source_id = $ref_source;
        }
        # if hilis3.OrgCode found in hilis4.referral_sources:
        elsif ( $org_code && $self->referral_source->{$org_code} ) {
            $referral_source_id = $self->referral_source->{$org_code}
#            || warn Dumper ( $org_code, $self->referral_source->{$org_code});
        }
        # can't set referral_source_id:
		else {
			$self->no_referral_source->{$source} += 1;
            die "No referral_source_id value set for $source on $vals->{dbid}\n";
            # next REQUEST; # no point - lost the request !!
        }

        my %case_data = (
            patient_id         => $patient_id,
            referral_source_id => $referral_source_id,
            unit_number        => $vals->{patno} || 'UNKNOWN',
            time               => $vals->{pid_time},
        );

        # retrieve or create new case_id:
        my $case_id = $self->get_case_id(\%case_data);

        if (! $case_id ) {
            $case_id = $self->find_or_create_new_patient_case(\%case_data);
        }

        $case_id or die 'No case_id value set';

        {
            # get referrer_department.id from referrer_id & referral_source_id:
            my $sql = q!select id from referrer_department where referrer_id = ?
                and parent_organisation_id = ( select parent_organisation_id from
                referral_sources rs where rs.id = ?)!;

            my $referrer_department_id
                = $dbix4->query( $sql, $referrer_id, $referral_source_id )->list;

			if (! $referrer_department_id) {
				my $referrer_department_id_map
					= $self->unknown_referrer_id_referrer_department_id_map;

				my $sql = 'select description from referral_types t join
					referral_sources s on s.referral_type_id = t.id where
					s.id = ?';

				my $referral_type
					= $dbix4->query( $sql, $referral_source_id )->list;

				# warn unless unknown referrer id's:
				warn "Cannot find referrer_department_id for referrer_id " .
					"$referrer_id & referral_source_id $referral_source_id " .
					"[$vals->{dbid}]"  unless map { $referrer_id == $_ }
						($self->unknown_referrer_id->{clinician},
                            $self->unknown_referrer_id->{practitioner});

				# set to referrer_department.id for unknown referrer:
				$referrer_department_id
					= $referrer_department_id_map->{$referral_type};
			}

			my $status_option_id = $self->_get_request_status($vals);
			
            # create new request:
            my %request_data = (
                year                    => $vals->{year},
                request_number          => $vals->{hmds},
                patient_case_id         => $case_id,
                referrer_department_id  => $referrer_department_id,
				status_option_id        => $status_option_id,
				created_at              => '0000-00-00 00:00:00', # will be updated in History
                updated_at              => $vals->{main_time},
            );

            $dbix4->insert('requests', \%request_data);
        }

        # add request.id to $vals for use in do_specimens() & do_report():
        $vals->{_request_id} = $dbix4->last_insert_id(undef, undef, 'requests', 'id')
        || die 'no request_id found';

        $self->do_specimens($vals);
		$self->do_clinical_trials($vals);
		$self->do_additional_options($vals);
        $self->do_report($vals);
		
		# block_ref:
		if ( my $block_ref = $vals->{blockref} ) {
			my ($ref, $status) = $block_ref =~ /(.*)\[(.*)\]\Z/; # foo [bar]
			if ($ref) { $ref =~ s/\s+$// }; # remove any trailing space(s)
			
			# set external ref to $ref if exists, or $block_ref:
			my $value = $status ? $ref : $block_ref;
			
			my %data = (
				request_id => $vals->{_request_id},
				external_reference => $value,
			);
			if ($status) { $data{status} = $status }

			$dbix4->insert('request_external_ref', \%data);
		}
    }
#=cut

    # need to anonymise patients if source is LTH && andLinux host:
	my $src = $self->cfg->{_}->{src_host};
#    if ( $src =~ /\A163\.160/ && $ENV{PULSE_SERVER} ) {
    if ( $ENV{PULSE_SERVER} ) {
#        $self->_anonymise();
    }

	# test converted diagnosis eq original diagnosis:
	print "Testing diagnoses.....\n";
	$self->test_diagnoses;

	my $no_referral_source = $self->no_referral_source;
    print "$_: $no_referral_source->{$_}\n" foreach keys %$no_referral_source;

#   print $log_file Dumper $self->unknown_referrers;
    print 'Total unknown referrers: '.$self->unknown_referrers_total, "\n";
}

sub test_diagnoses {
	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 ) {
				next if $vals->{year} <= 2003 && $hilis4_diagnosis eq 'Not required'; # Molecular
				warn "$hilis3_diagnosis ne $hilis4_diagnosis for $vals->{hmds} / $vals->{year}";
			}
		}
    }	
}

sub _anonymise {
    my $self = shift; print "anonymising patients .. ";

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

	# get all existing nhs_numbers so we don't attempt to duplicate one still unprocessed:
	my $sql = 'select nhs_number from patients where nhs_number is not null';
	my $all_nhs_numbers = $dbh->query( $sql )->flat;
		
    my $anonymiser = Anonymise::LIMS->new(
		path_to_app => $self->path_to_app,
		existing_nhs_numbers => $all_nhs_numbers,
	);

    # Anonymise::LIMS::anonymise_patient() needs hashref of PID rows:
    my $patient = $dbh->query('select id, last_name, first_name, dob, gender,
        nhs_number from patients');

    while ( my $vals = $patient->hash ) {
		# anonymise $vals:
        $anonymiser->anonymise_patient($vals);

        my $id = $vals->{id};
        delete $vals->{id};
        $dbh->update('patients', $vals, { id => $id } );
    }

	print "finished\n";
}

# will be updated in RequestStatus if outstanding tests:
sub _get_request_status {
	my $self = shift;
	my $vals = shift;
	
	my $status_options_map = $self->request_status_options_map;
	
    # set all requests before 2008 to complete:
	return $status_options_map->{complete} if $vals->{year} < 2008;
	
	return $status_options_map->{complete} if $vals->{authorisedby};
	return $status_options_map->{reported} if $vals->{reportby};
	return $status_options_map->{screened} if $vals->{screener};
	return $status_options_map->{new};
}

# Moose builder methods:
sub _build_screen_map {
    my $self = shift;
    my $dbh  = $self->db->{dbix4};

    # create Report.InitialDiag -> screen.id map:
    my $map = $dbh->query( 'select description, id from screens' )->map;

    return $map;
}

sub _build_request_status_options_map {
	my $self = shift;
    my $dbh  = $self->db->{dbix4};
	
    my $map = $dbh->query( q!select description, id from status_options! )->map;

    return $map;
}

sub _build_resolved_nhsno_duplicates_map {
	my $self = shift;
    my $dbh  = $self->db->{dbix3};
	
	my $map = $dbh->query('select * FROM test.ResolvedNHSNo')->map_hashes('nhsno');

	return $map;
}

sub _build_signature_userid_map {
    my $self = shift;
    my $dbh  = $self->db->{dbix3};

    # create Users.Signature -> user.id map:
    my $map = $dbh->query( q!select Signature, UserID from Users where
        Signature is not null! )->map;

    return $map;
}

sub _build_substitute_screening_terms {
    my $self = shift;

    return {
        'Myeloma/P\'cytoma' => $self->screen_map->{'Myeloma/Plasmacytoma'},
		'Reactive Node'     => $self->screen_map->{'Reactive node'},
        '[NULL]'            => $self->screen_map->{Other},
        '---'               => $self->screen_map->{ITP},
    };
}

sub _build_substitute_user {
    my $self = shift;

    return {
        'S Richmond' => $self->username_userid_map->{bagguley},
        Molecular    => $self->username_userid_map->{evans},
		Admin        => $self->username_userid_map->{raj},
        # for early hilis requests:
        admin        => $self->username_userid_map->{raj},
        fielding     => $self->username_userid_map->{douglas},
		westgate 	 => $self->username_userid_map->{wilkinson},
    };
}

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

	# create users.username -> users.id map:
    my $map = $dbh->query( 'select username, id from users' )->map;

    return $map;
}

sub _build_specimen_map {
    my $self = shift;

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

    my $specimen_map = $dbh->query('SELECT sample_code, id FROM specimens')->map;
    #    ->map_hashes('sample_code'); # don't need this if only 2 fields mapped

	# truncated/incorrect sample_codes:
	$specimen_map->{E}   = 13; # EF
	$specimen_map->{L}   = 25; # LU (checked)
	$specimen_map->{X}   = 43; # XU (checked)
	$specimen_map->{SER} = 33; # SE

    return $specimen_map;
}

sub _build_gp_practice {
	my $self = shift;

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

	my $practices = $dbh->query('SELECT g_id, gp_code, practice_code FROM GP')
        ->map_hashes('g_id');

	return $practices;

}

sub _build_referral_source { # warn 'HERE';
    my $self = shift; # warn Dumper $self->db;

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

	my $referral_source =
		$dbh->query('SELECT organisation_code, id FROM referral_sources')->map;
    # print $log_file Dumper $referral_source; exit;

}

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

	# get referrer_department.id from referrer_department for default unknown referrers:
	my $sql =
		q!select id from referrer_department where referrer_id in (
			select id from referrers where national_code in (
              select default_unknown from referral_types where description = ?
			)
		)!;

	my %referrer_department_id = (
		hospital => $dbh->query( $sql, 'clinician' )->list,
		practice => $dbh->query( $sql, 'practitioner' )->list,
	);

	return \%referrer_department_id;
}


sub _build_unknown_source {
	my $self = shift;

	my $dbh = $self->db->{dbix4};
    my $sql = q!SELECT id FROM referral_sources WHERE organisation_code = ?!;

    my %unknown_source = (
        54  => $dbh->query($sql, 'NT225' )->list, # Mid-Yorks -> Leeds Nuffield
        56  => $dbh->query($sql, 'RHALB' )->list, # Notts. City Hospital
        57  => $dbh->query($sql, 'X99999')->list, # Other hospital
        78  => $dbh->query($sql, 'V81999')->list, # Surgery/Med. Ctr
        217 => $dbh->query($sql, 'RWD00' )->list, # PathLinks
        220 => $dbh->query($sql, 'RTD00' )->list, # Newcastle Uni.
        234 => $dbh->query($sql, 'GHANA' )->list, # Ghana
    ); # warn Dumper \%unknown_source;

	return \%unknown_source;
}


1;