• Files
• Commits
• Log
• Graph
• Stats

package Outreach;

use Moose;
with qw(
	Role::RebuildTables
	Role::ReferralSource
);

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_id_map => ( is => 'rw', isa => 'HashRef[Str]', default => sub { {} });

__PACKAGE__->meta->make_immutable;

$|++;

# abbr. for db name:
my $CM = 'community_monitoring';

# rebuilds:
# biochemistry, flow_cytometry, followup_decisions, haematology, immunology,
# pack_dispatches, patient_details, questionnaire_*
# need to manually copy 'static' data tables:
# alternate_address, defaults_and_ranges, followup_options, menu_fields,
# non_participant_practices

sub convert { 
    my $self = shift;
	
    # retain case-sensitivity of cols (CHANGES $DB::dbix3 SO MUST REVERSE THIS AFTER):
    $self->db->{dbix3}->lc_columns = 0;

	$self->do_patient_details(); return;
	$self->do_followup_decisions();
	$self->do_lab_params();
	$self->do_pack_dispatches();
	$self->do_questionnaires();
	
	$self->db->{dbix3}->lc_columns = 1; # reset to default
}

sub do_followup_decisions {
    my $self = shift;

    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};
    my $dbh4 =  $self->db->{dbh4};
    
	my $table = 'outreach.followup_decisions';
	
	# need to remove FK first:
	$dbh4->do( qq!ALTER TABLE $table DROP FOREIGN KEY `followup_decisions_ibfk_1`! );
	
	$self->clear_table($table);

	# followup_decisions map:
	my $followup_decisions_map
		= $dbix3->query(qq!select `option`, `id` from $CM.followup_options!)->map;
	
	# followup_decisions table:
	my $sql = qq!select m.HMDS, year(m.Date) as 'YEAR', fd.*
		from $CM.followup_decisions fd left join Main m on fd.dbid = m.DBID!;
		
	my $query = $dbix3->query($sql);
	while ( my $vals = $query->hash ) {
		# get request_id or skip (will have warned to output):
		my $request_id = $self->_get_request_id($vals) || next;
		
		my $decision = $vals->{decision};
		
		my %data = (
			request_id => $request_id,
			followup_option_id => $followup_decisions_map->{$decision},
			time => $vals->{timestamp},
		);
		$dbix4->insert($table, \%data);
	}
	
	# restore FK:
	$dbh4->do( qq!ALTER TABLE $table ADD CONSTRAINT `followup_decisions_ibfk_1`
		FOREIGN KEY (`followup_option_id`) REFERENCES `followup_options` (`id`)! );
}
	
sub do_lab_params {
	my $self = shift;
	
    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};
	
	my $table = 'outreach.request_results';
	
	$self->clear_table($table);

	my $params_map
		= $dbix4->query(q!select param_name, id from outreach.lab_params!)->map;
	# warn Dumper $params_map; exit;
		
	# create data structure for all departments:
	my %data = ();
	
	my @depts = qw(biochemistry immunology haematology flow_cytometry);
	
	foreach my $dept (@depts) {
		my $sql = qq!select m.HMDS, year(m.Date) as 'YEAR', tbl.*
			from $CM.$dept tbl left join Main m on tbl.dbid = m.DBID!;
		my $query = $dbix3->query($sql);
		
		while ( my $vals = $query->hash ) {
			# get request_id or skip (will have warned to output):
			my $request_id = $self->_get_request_id($vals) || next;

			while ( my ($param, $val) = each %$vals ) { # warn Dumper [ $param, $val ];
				next if grep $param eq $_, qw(dbid HMDS YEAR); # ie non-tests
				next unless $val; # skip null cols
				
				my $param_id = $params_map->{$param} or die "no param id for $param";
				$data{$request_id}{$param_id} = $val;
			}			
		}
	}
	
	while ( my ($request_id, $results) = each %data ) { # warn Dumper [ $request_id, $results ];
		while ( my ($param_id, $val) = each %$results ) {
			my %data = (
				request_id => $request_id,
				param_id   => $param_id,
				result     => $val,
			);
			$dbix4->insert($table, \%data);
		}
	}	
}

sub do_pack_dispatches {
	my $self = shift;
	
    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};
	
	my $table = 'outreach.pack_dispatches';
	
	$self->clear_table($table);

	my $sql = qq!select m.HMDS, year(m.Date) as 'YEAR', pd.*
		from $CM.pack_dispatches pd left join Main m on pd.dbid = m.DBID!;
		
	my $query = $dbix3->query($sql);
	while ( my $vals = $query->hash ) {
		# get request_id or skip (will have warned to output):
		my $request_id = $self->_get_request_id($vals) || next;

		my %data = (
			request_id => $request_id,
			date_due   => $vals->{date_due},
			date_sent  => $vals->{date_sent},
			time 	   => $vals->{timestamp},
		);
		$dbix4->insert($table, \%data);
	}	
}

sub do_patient_details {
	my $self = shift;
	
    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};
	
	my $table = 'outreach.patient_details';
	
	$self->clear_table($table);
	
	# get organisation_codes like '[^BCY]____' from referral_sources:
	my $practices_map = $self->referral_source_practices;
	# get national_code like 'G%' from referrers:
	my $practitioners_map = $self->_get_practitioners_map;
	# get distinct community_monitoring.practice_id's (ie org_code):
	my $cm_practices = $dbix3->query(
        q!select distinct(practice_id) from community_monitoring.patient_details
        where practice_id is not null and practice_id <> 'B00000'!
    )->flat;
	# warn Dumper $cm_practices; 

	# get referrer.id for unknown gp:
	$dbix4->query(q!select id from referrers where national_code = 'G9999998'!)
		->into( my $unknown_gpid); # warn $unknown_gpid;
	# get referral_source.id for unknown practice:
	$dbix4->query(q!select id from referral_sources where organisation_code = 'V81999'!)
		->into( my $unknown_practice_id); # warn $unknown_practice_id; 
	
	# ensure all practices in cm.patient_details exist in referral_sources:
	$self->add_new_practices_to_referral_sources($cm_practices); 
	# check GP's from cm.patient_details exist in referrers - just prints warning:
	$self->_check_outreach_practitioners($practitioners_map); 

	my $sql = qq!select * from $CM.patient_details!; # don't need join
	
	my $query = $dbix3->query($sql);
	while ( my $vals = $query->hash ) {
		my $practice_code = $vals->{practice_id} || ''; # actually org code
		my $gp_code = $vals->{gp_id} || ''; # actually GMC number
		
		my $practice_id = $practices_map->{$practice_code};
		#	|| warn "no practice_id for $practice_code"; # WRONG - GETS SET TO '1'
		if (! $practice_id) { #	warn "no practice_id for $practice_code";
			$practice_id = $unknown_practice_id; # warn "$practice_code:$practice_id";
		}

		my $practitioner_id = $practitioners_map->{$gp_code} || $unknown_gpid;
		
		# replace gp_id & practice_id with real values:
		$vals->{gp_id} = $practitioner_id;
		$vals->{practice_id} = $practice_id;
		
		$dbix4->insert($table, $vals);
		
		# now add to patient_demographics table (from YHHN conversion):
		$self->_do_patient_demographics($vals);
	}	
}

sub do_questionnaires {
	my $self = shift;
	
    my $dbix3 = $self->db->{dbix3};
    my $dbix4 = $self->db->{dbix4};
	
	my @tables = qw(
		questionnaire_pain
		questionnaire_details
		questionnaire_symptoms
		questionnaire_locality
		questionnaire_adenopathy
		questionnaire_treatment );
	
	for my $table (@tables) {
		$self->clear_table("outreach.$table");
		
		my $sql = qq!select m.HMDS, year(m.Date) as 'YEAR', tbl.*
			from $CM.$table tbl left join Main m on tbl.dbid = m.DBID!;
	
		my $query = $dbix3->query($sql);
	
		while ( my $vals = $query->hash ) {
			# get request_id or skip (will have warned to output):
			my $request_id = $self->_get_request_id($vals) || next;

			# remove unwanted vals, add $vals->{request_id}:
			$vals->{request_id} = $request_id;
			map delete $vals->{$_}, qw(dbid HMDS YEAR);
			
			$dbix4->insert("outreach.$table", $vals);
		}
	}
}

sub _get_request_id {
	my ($self, $vals) = @_;	
	
	my $dbid = $vals->{dbid};
	
	if ( my $request_id = $self->request_id_map->{$dbid} ) {
		return $request_id;
	}
	
	my $dbix4 = $self->db->{dbix4};
	my $request_id = $dbix4->query( q!select id from requests where request_number
		= ? and year = ?!, $vals->{HMDS}, $vals->{YEAR} )->list;
	
	if (! $request_id) {
		warn "no request_id for $dbid [" . $vals->{HMDS} . '/' . $vals->{YEAR} . ']';
		return 0; 
	}
	
	# stash it for next time:
	$self->request_id_map->{$dbid} = $request_id;
	return $request_id;
}

sub _get_practitioners_map {
	my $self = shift;
	
	my $sql = q!select national_code, id from referrers
		where national_code like 'G%'!;
	
	return $self->db->{dbix4}->query($sql)->map;
}

sub _do_patient_demographics {
	my $self = shift;
	my $vals = shift;
	
    my $dbix4 = $self->db->{dbix4};


	my $hilis4_patient_id = $dbix4->query(
		'select id from patients where nhs_number = ?', $vals->{nhs_number}
	)->list || warn "cannot find patient_id for $vals->{nhs_number}";
	
	my $sql = 'select * from patient_demographics where patient_id = ?';
	# skip if we already have data from YHHN:
	if ( my $data = $dbix4->query($sql, $hilis4_patient_id)->hash ) {
		# warn "have data on $hilis4_patient_id";
		my $have_diffs = $self->_parse_data($data, $vals);

		# update patient_demographics with outreach details (tel no & referrer id):
		my %new = (
			contact_number 	=> $vals->{telephone_no},
			gp_id 			=> $vals->{gp_id},
			status 			=> $vals->{status}, # do this anyway in case diff
		);
		
		# also update address, post_code & practice_id if have diffs:
		if ($have_diffs) {
			map $new{$_} = $vals->{$_}, qw(address post_code practice_id);
		}
		$dbix4->update(
			'patient_demographics', \%new, { patient_id => $hilis4_patient_id }
		);
	}
	else { # warn "no data";
		my %data = (
			contact_number 	=> $vals->{telephone_no},
			practice_id 	=> $vals->{practice_id},
			patient_id 		=> $hilis4_patient_id,
			post_code 		=> $vals->{post_code},
			address 		=> $vals->{address},
			status			=> $vals->{status},
			gp_id 			=> $vals->{gp_id},			
		); # warn Dumper \%data;
		$dbix4->insert('patient_demographics', \%data);
	}
}	
	
sub _check_outreach_practitioners {
	my ($self, $practitioners_map) = @_; # warn Dumper $practitioners_map; 
	
    my $dbix3 = $self->db->{dbix3};

	my $log_file = $self->log_file;

	my $cm_practitioners
		= $dbix3->query(qq!select distinct(gp_id) from $CM.patient_details
			where gp_id is not null!)->flat;
	# warn Dumper $cm_practitioners;
	
	my @unknown_gps;
	
	for my $gp_code (@$cm_practitioners) {
		push @unknown_gps, $gp_code unless $practitioners_map->{$gp_code};
	}
	
	if (@unknown_gps) {
		print $log_file "outreach GP's not in referrers table:\n";
		print $log_file Dumper \@unknown_gps;
	}
}

sub _parse_data {
	my ($self, $data, $vals) = @_;
	
	my $log_file = $self->log_file;
	my @flds = qw(address post_code practice_id);
	
	# don't log if data identical, retunrn 0 - no diffs:
	return 0 unless grep $data->{$_} ne $vals->{$_}, @flds;

	my $yhhn = 'yhhn';
	my $outr = 'outr';
	
	if ($data->{post_code} ne $vals->{post_code}) {
		$yhhn = uc $yhhn;
		$outr = uc $outr;
	}
	
	printf $log_file "$yhhn: %s\n", join ' :: ', map $data->{$_}, @flds;
	printf $log_file "$outr: %s\n", join ' :: ', map $vals->{$_}, @flds;
	
	return 1; # have diffs
}	

1;