package Role::Referrer;
use Moose::Role;
has unknown_referrers => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
has unknown_referrers_total => ( is => 'rw', isa => 'Int', default => 0);
has $_ => ( is => 'ro', isa => 'HashRef', lazy_build => 1 )
foreach qw(
private_referrers unknown_referrer_id referrer_id_map known_referrers
known_hiv_referrers known_location_referrers default_unknown_code
parent_organisation_id_map
);
use Text::CSV::Simple;
# returns referrer national code, or default unknown for referrer_type:
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} || ''; # only present > 643
if ( my ($g_id) = $clinician_code =~ /\A(G\d+)/ ) {
return $self->gp_practice->{$g_id}->{gp_code}
|| $self->default_unknown_code->{practitioner};
}
# Clinician = 'General Practitioner' & Source = 'Surgery/Medical Centre':
elsif ( $clinician_code == 25 && $vals->{source} == 78 ) { #
return $self->default_unknown_code->{practitioner};
}
# Clinician = 'Not stated/known' or 'Unknown':
elsif ( grep $clinician_code == $_, (62, 643) ) { #
return $self->default_unknown_code->{clinician};
}
# known referrers list:
elsif ( $clinician_name && $self->known_referrers->{$clinician_name} ) { # warn 'known referrer';
return $self->known_referrers->{$clinician_name}{ref_code};
}
if ( my $orgCode = $vals->{orgcode} ) { # null if Source = 54, 57, 78
my ($org_code_prefix) = $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_prefix =~ /$referrers->{$clinician_name}{org_code}/;
}
}
{ # known location referrers:
my $referrers = $self->known_location_referrers;
if ( $clinician_name && $referrers->{$clinician_name} ) { # warn 'known location referrer';
return $referrers->{$clinician_name}{ref_code}
if $org_code_prefix eq $referrers->{$clinician_name}{org_code};
}
}
{ # known location & initialdiag/screen referrers:
my $referrers = $self->known_hiv_referrers;
if ( $referrers->{$clinician_name} ) { # warn 'known location screen referrer';
return $referrers->{$clinician_name}{ref_code}
if $org_code_prefix =~ /$referrers->{$clinician_name}{org_code}/
&& $vals->{initialdiag} eq $referrers->{$clinician_name}{initialdiag};
}
}
{ # if clinician name unique to location:
# warn $org_code_prefix; die;
my $parent_organisation_id
= $self->parent_organisation_id_map->{$orgCode};
if ( $parent_organisation_id ) {
# won't find a national code without 'last_name':
return $self->default_unknown_code->{clinician} if ! $vals->{last_name};
my $sql = q!select r.national_code from referrers r join referrer_department
rd on (rd.referrer_id = r.id) where `name` like ? and
`parent_organisation_id` = ? having count(*) = 1!;
my $name = $vals->{last_name} . '%';
my $national_code
= $dbh->query($sql, $name, $parent_organisation_id)->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 $national_code || $self->default_unknown_code->{clinician};
}
else {
warn "Cannot find parent_organisation_id for $orgCode [$vals->{dbid}]"
}
}
}
# warn Dumper [ $vals->{dbid}, $clinician_name, $vals->{orgcode} || 'NULL ORG_CODE' ];
$self->unknown_referrers->{$clinician_name}{ $vals->{orgcode} || 'UNKNOWN' }++;
$self->unknown_referrers_total($self->unknown_referrers_total + 1);
# can't match it so return unknown:
return $self->default_unknown_code->{clinician};
}
# converts referrer national_code to referrer.id:
sub convert_referrer_code_to_id {
my ($self, $referrer_code) = @_;
return $self->referrer_id_map->{$referrer_code};
}
=begin # might not need this - outreach referrers & practices now loaded in Referrer & ReferralSource
sub add_missing_practitioners_to_referrer_department {
my $self = shift;
my $dbh = $self->db->{dbix4};
# get list of outreach practices which have no GP's in referrer_department table:
my $sql = q!
select po.parent_code
from hilis4.parent_organisations po
left join hilis4.referrer_department rd on rd.parent_organisation_id = po.id
where po.parent_code in (
select distinct(rs.organisation_code)
from outreach.patient_dispatch_detail pdd
join hilis4.patient_demographics pd on pd.patient_id = pdd.patient_id
join hilis4.referral_sources rs on rs.id = pd.practice_id
) and rd.parent_organisation_id is null!;
my $practice_codes = $dbh->query($sql)->list;
my $path_to_file = $self->path_to_app . '/src/data/egpcur.csv';
my $parser = Text::CSV::Simple->new();
my @fields = qw( code name null null addr1 addr2 addr3 addr4 null post_code
null null null null practice_code);
$parser->field_map(@fields);
my @data = $parser->read_file($path_to_file);
ROW:
foreach my $row (@data) { # warn Dumper $row; next;
# skip unless required GP practice:
next ROW unless grep $row->{practice_code} eq $_, @$practice_codes;
my %GP = (
name => $row->{name},
national_code => $row->{code},
referral_type_id => '',
active => 'yes',
);
$dbh->insert('referrer', \%GP);
my $data = {
referrer_id => $clinician_id,
parent_organisation_id => $parent_organisation_id,
hospital_department_code => $speciality_code,
}; # print Dumper $data;
my %data = (
practice_code => $row->{practice_code},
referral_type_id => $referral_type->id,
hospital_department_code => $hospital_department->id,
parent_organisation_id => $parent_organisation_id_map{$practice_code},
);
$dbh->insert('referrer_department', \%data);
}
}
=cut
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' },
Owen => { org_code => 'RR8', ref_code => 'C3271078' },
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 => 'RR8', 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
Braithwaite
=> { org_code => 'RWY', ref_code => 'C2308535' },
'McDonald Hull'
=> { org_code => 'RXF', ref_code => 'C1552852' },
# 2 Macdonalds at Mid-Yorks - Histopathology & Dermatology (Macdonald Hull)
# Macdonald => { org_code => 'RXF', ref_code => 'C1552852' }, # MacDonald Hull
);
return \%referrers;
}
sub _build_known_hiv_referrers {
my $self = shift;
my %referrers = (
Wilson => { org_code => 'RR8', ref_code => 'C2645429',
initialdiag => 'HIV' },
Clarke => { org_code => 'RR8', ref_code => 'C2718156',
initialdiag => 'HIV' },
Lee => { org_code => 'RXF|RR8', ref_code => 'C4202019',
initialdiag => 'HIV' }, # Lee, RA
);
return \%referrers;
}
sub _build_referrer_id_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = 'select national_code, id from referrers';
my $referrer_id_map = $dbh->query( $sql )->map;
return $referrer_id_map;
}
sub _build_default_unknown_code {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = q!select default_unknown from referral_types where description = ?!;
my %default_unknown = map {
$_ => $dbh->query( $sql, $_ )->list;
} qw(clinician practitioner);
return \%default_unknown;
}
sub _build_unknown_referrer_id {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = q!select id from referrers where national_code = ?!;
my %unknown_referrer;
map {
my $national_code = $self->default_unknown_code->{$_};
$unknown_referrer{$_} = $dbh->query( $sql, $national_code )->list;
} qw(clinician practitioner);
return \%unknown_referrer;
}
sub _build_parent_organisation_id_map {
my $self = shift;
my $dbh = $self->db->{dbix4};
my $sql = 'select organisation_code, parent_organisation_id from referral_sources';
my $parent_organisation_id_map = $dbh->query( $sql )->map;
return $parent_organisation_id_map;
}
1;
