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;