package Referrer;
use LIMS::Local::ExcelHandler;
use Moose;
with 'Role::RebuildTables';
use namespace::clean -except => 'meta';
use Data::Dumper;
has $_ => ( is => 'ro', isa => 'HashRef', required => 1 )
for qw(db sql);
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
for qw(
parent_organisation_id_map
custom_parent_organisation_id_map
unknown_referrer_unknown_parent_org_id_map
);
has unknown_org_codes => (
is => 'rw',
isa => 'HashRef',
default => sub { {} },
);
__PACKAGE__->meta->make_immutable;
my @tables = qw(referrers referrer_department);
sub convert {
my $self = shift;
my $dbh4 = $self->db->{dbh4};
my $dbix3 = $self->db->{dbix3};
my $dbix4 = $self->db->{dbix4};
#=begin
my %SQL = (
clinician_id => q!SELECT `id` FROM `referrers` WHERE `national_code` = ?!,
referrer_organisation_combination_exists =>
q!SELECT 1 FROM `referrer_department` WHERE `referrer_id` = ?
AND `parent_organisation_id` = ?!,
hilis3_clinicians => q!
SELECT `cons_code`, `last_name`, `initials`, `speciality_code`, `org_code`
FROM `hilis3`.`Clinician`
WHERE `c_id` > 643 and `org_code` like '%00'!,
);
$self->rebuild_tables(\@tables);
my $parent_org_id_map = $self->parent_organisation_id_map;
CLINICIAN:
for my $ref ($dbix3->query( $SQL{hilis3_clinicians} )->arrays) {
my ($cons_code, $last_name, $inits, $speciality_code, $org_code) = @{ $ref };
$org_code = uc $org_code; # a few are lc in src table
my $clinician_id = $dbix4->query( $SQL{clinician_id}, $cons_code)->list;
# if no referrers.id, create new clinician:
if (! $clinician_id ) {
# join with space for consistency with GP's:
my $name = join ' ', $last_name, $inits;
my $data = {
national_code => $cons_code,
name => $name,
referral_type_id => 1, # clinician
}; # print Dumper $data;
$dbix4->insert('referrers', $data) or die $dbix4->error;
$clinician_id
= $dbix4->last_insert_id( undef, undef, qw/referrers id/ )
|| die 'no last_insert_id';
}
{ # changed Notts. City Hospital org_code to match current etrust file:
no warnings 'uninitialized';
$org_code =~ s/^(RCS)/RHA/;
}
# only need 1st 3 chars of org_code (eg SEK00, X60000, RR800, ):
my ($org_code_prefix) = $org_code =~ /\A(...)/;
# look for prefix in parent_organisation_id_map:
my $parent_organisation_id = $parent_org_id_map->{$org_code_prefix};
if (! $parent_organisation_id) {
# try to match 1st 3 chars of parent_code from restricted list:
my $custom_parent_organisation_id_map
= $self->custom_parent_organisation_id_map;
$parent_organisation_id
= $custom_parent_organisation_id_map->{$org_code_prefix};
}
# if still no $parent_organisation_id:
if (! $parent_organisation_id) {
$self->unknown_org_codes->{$org_code_prefix} += 1;
#warn "Cannot find parent_organisation_id for $org_code"
#. " (clinician = $cons_code)";
next CLINICIAN;
}
next CLINICIAN if
$dbix4->query( $SQL{referrer_organisation_combination_exists},
$clinician_id, $parent_organisation_id )->list;
my $data = {
referrer_id => $clinician_id,
parent_organisation_id => $parent_organisation_id,
hospital_department_code => $speciality_code,
}; # print Dumper $data;
$dbix4->insert('referrer_department', $data) or die $dbix4->error;
# next CLINICIAN if $clinician_id % 1000; print $clinician_id, "\n";
}
{ # unknown referrers:
my $unknown_parent_org_id_map
= $self->unknown_referrer_unknown_parent_org_id_map;
foreach my $referrer_type (qw/clinician practitioner/) {
my $sql = qq!select id, default_unknown from referral_types
where description = '$referrer_type'!;
my ($referral_type_id, $default_unknown) = $dbix4->query($sql)->list;
{ # referrers:
my %data = (
name => "Unknown $referrer_type",
national_code => $default_unknown,
referral_type_id => $referral_type_id,
);
$dbix4->insert('referrers', \%data) or die $dbix4->error;
}
{ # referrer_department:
my $referrer_id
= $dbix4->last_insert_id( undef, undef, qw/referrers id/ )
|| die 'no last_insert_id';
my $parent_organisation_id
= $unknown_parent_org_id_map->{$referrer_type};
my %data = (
referrer_id => $referrer_id,
parent_organisation_id => $parent_organisation_id,
hospital_department_code => 999, # unknown/other
);
$dbix4->insert('referrer_department', \%data) or die $dbix4->error;
}
}
}
#=cut
{ # GP's (based on Admin::Config::GeneralPractitioners::regenerate():
# get map of all practice_codes => parent_organisation.id:
my $parent_organisation_id_map = $self->parent_organisation_id_map;
# list of parent_codes from $parent_organisation_id_map keys:
my @parent_codes = keys %$parent_organisation_id_map;
my $xl = LIMS::Local::ExcelHandler->new(); # $self->debug($xl);
$xl->source('GP');
# get ref to array of all rows in egpcur.csv:
my $general_practitioners = $xl->fetch_all;
GP:
foreach my $row (@$general_practitioners) { # warn Dumper $row; next;
# skip row unless $row->{practice_code} matches entry in @practice_codes:
next GP unless grep { $row->{practice_code} eq $_ } @parent_codes;
my $practice_code = $row->{practice_code};
{ # referrers table:
my %data = (
name => $row->{name},
national_code => $row->{code},
referral_type_id => 3, # practitioner
);
$dbix4->insert('referrers', \%data) or die $dbix4->error;
}
{ # referrer_department table:
my $referrer_id
= $dbix4->last_insert_id( undef, undef, qw/referrers id/ )
|| die 'no last_insert_id';
my %data = (
referrer_id => $referrer_id,
hospital_department_code => 600,
parent_organisation_id
=> $parent_organisation_id_map->{$practice_code},
);
$dbix4->insert('referrer_department', \%data) or die $dbix4->error;
}
}
}
#=cut
{ # known missing GP's in referrers table (not in egpcur):
my @missing_gps = (
[ 'MCEWAN A', 'S3299276', 'S78024' ],
[ 'ALEXANDER CM', 'G3381913', 'B86052' ],
[ 'TAYLOR PF', 'G3333109', 'B86044' ],
# [ 'SMITH DA', 'G8908649', 'B87029' ], # now at B87001 in 26/2/2010 egpcur.csv
[ 'DOWSON DG', 'G8202185', 'B86054' ],
# [ 'SMITH ML', 'G9501098', 'B83009' ], # now at B84007 in 4/10/2010 egpcur.csv
# missing from Nov 2009 egpcur update:
[ 'EISNER MC', 'G3356694', 'B83063' ],
[ 'JARVIS EH', 'G3391855', 'B86071' ],
[ 'BAILEY S', 'G8142056', 'B83058' ],
[ 'HARRIS AL', 'G3363492', 'B82026' ],
[ 'CARPENTER RM', 'G3371088', 'B82026' ],
# [ 'CAMERON AW', 'G8209508', 'B86014' ], # now at Y02002 in 4/10/2010 egpcur.csv
[ 'SHERWOOD GJ', 'G8105910', 'B86052' ],
# missing from Oct 2010 egpcur update:
[ 'FURNESS F', 'G3301072', 'B87031' ],
[ 'ANTROBUS RD', 'G3314728', 'B83042' ],
[ 'MACFIE AJ', 'G3390328', 'B82026' ],
[ 'FITZGERALD TA','G9608294', 'B86041' ], # now at B81014 in 4/10/2010 egpcur.csv
# outreach GP's moved to new practice:
[ 'WACHSMUTH CW', 'G8135258', 'B86058' ],
[ 'HAYES G', 'G9406564', 'B82056' ],
[ 'GRIFFITHS SH', 'G8532350', 'B86054' ],
[ 'DAVIES RL', 'G8334095', 'B86050' ],
[ 'GOODMAN HE', 'G8440431', 'B86057' ],
);
my $parent_organisation_id_map = $self->parent_organisation_id_map;
foreach (@missing_gps) {
my %data = (
name => $_->[0],
national_code => $_->[1],
referral_type_id => 3, # GP
active => 'no', # assume retired
);
$dbix4->insert('referrers', \%data) or die $dbix4->error;
my $referrer_id
= $dbix4->last_insert_id( undef, undef, qw/referrers id/ )
|| die 'no last_insert_id';
{
my $parent_organisation_id
= $parent_organisation_id_map->{$_->[2]}
|| die "Cannot find parent_organisation_id for GP $_->[0] ($_->[1])";
my %data = (
referrer_id => $referrer_id,
hospital_department_code => 600,
parent_organisation_id => $parent_organisation_id,
);
$dbix4->insert('referrer_department', \%data) or die $dbix4->error;
}
}
}
# now check all clinicians & gp's from hilis3 are in referrers table:
{ # clinicians:
my $sql = q!select distinct(c.cons_code) from Main m left join
Clinician c on m.Clinician = c.c_id where c.cons_code is not null!;
my $hili3_clinicians = $dbix3->query( $sql )->flat;
{
my $sql = 'select 1 from referrers where national_code = ?';
foreach (@$hili3_clinicians) {
warn "Cannot find $_ in referrers table"
unless $dbix4->query($sql, $_)->list;
}
}
}
{ # GP's:
my $sql = q!select distinct(g.gp_code) from Main m left join
GP g on m.Clinician = g.g_id where g.gp_code is not null!;
my $hili3_gps = $dbix3->query( $sql )->flat;
{
my $sql = 'select 1 from referrers where national_code = ?';
foreach (@$hili3_gps) {
warn "Cannot find $_ in referrers table"
unless $dbix4->query($sql, $_)->list;
}
}
}
$self->convert_to_InnoDB($_) for @tables;
=begin
{ # dump unknown organisation codes to stdout:
my $unknown_org_codes = $self->unknown_org_codes;
print "$_: $unknown_org_codes->{$_}\n"
foreach sort { $unknown_org_codes->{$b} <=> $unknown_org_codes->{$a} }
keys %$unknown_org_codes;
}
=cut
}
# returns hash of parent_org_id for unknown practice & hospital:
sub _build_unknown_referrer_unknown_parent_org_id_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = q!select parent_organisation_id from referral_sources where
display_name = ?!;
my %referrer_org_code_id = (
clinician => $dbh->query( $sql, 'Hospital (unknown/other)' )->list,
practitioner => $dbh->query( $sql, 'Practice (unknown/other)' )->list,
);
return \%referrer_org_code_id;
}
sub _build_parent_organisation_id_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $map
= $dbh->query( 'select parent_code, id from parent_organisations' )->map;
return $map;
}
# parent_organisation prefix -> id map for non-gp_practice org_codes > 3 chars:
sub _build_custom_parent_organisation_id_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = q!select left(parent_code,3), id from parent_organisations
where parent_code not like 'B_____' and length(parent_code) > 3!;
my $map = $dbh->query( $sql )->map;
return $map;
}
1;
