package LIMS::Controller::Roles::PatientDemographics;
use IO::All;
use Moose::Role;
use Data::Dumper;
use Text::CSV_XS;
use Sys::SigAction qw( timeout_call ); # for PDS service
use lib '/home/raj/perl-lib'; # PDS classes
# PDS::* classes generated using SOAP::WSDL function:
# wsdl2perl.pl -b lib -p PDS:: file:RenalWebService.wsdl.xml
use PDS::Interfaces::PatientInterface::PatientInterfaceSoap; # SOAP::WSDL classes
sub get_pds_data {
my ($self, $patient) = @_; # warn Dumper $patient; # hashref (with DoB = DT)
my $data = {}; # container for PDS data
# check session for SMSP-0000 verified data before hitting PDS:
if ( my $nhs_number = $patient->{nhs_number} ) { # warn $nhs_number;
if ( my $session_data = $self->session->dataref->{_pds_data} ) { # warn Dumper $session_data;
# set $data to session-retrieved data if nhs_no matches:
$data = $session_data if ($session_data->{nhs_number} == $nhs_number);
} # warn Dumper $data;
}
if (! %$data) { # data not in session so do PDS lookup:
my $messages = $self->messages('demographics');
my $config = $self->cfg('settings');
my $pds = PDS::Interfaces::PatientInterface::PatientInterfaceSoap->new();
$pds->set_proxy($config->{pds_proxy}) if $ENV{DEVEL_SERVER}; # dev server can't find 'regint'
my ($result, $t0, $t1);
{ # get PDS result inside a Sys::SigAction::timeout_call
# normal alarm/eval/die doesn't work with $pds
my $ref = $self->_format_patient_details($patient); # warn Dumper $ref;
my $getpatient = sub { $result = $pds->GetPatientDetails($ref) };
$t0 = LIMS::Local::Utils::time_now_hires();
# Sys::SigAction::timeout_call( $duration, sub ):
if ( timeout_call( 10, $getpatient ) ) {
my %args = ( ErrorCode => $messages->{pds_timeout} );
return \%args;
}
$t1 = LIMS::Local::Utils::time_now_hires();
} # warn Dumper $result; # PDS::Elements::GetPatientDetailsResponse object
# parse PDS return:
$data = $self->_process_pds_response($result);
# log PDS lookup details (_log() ensures $data is hashref otherwise returns):
$self->_log($t0, $t1, $patient, $data); # won't log if $data is a string
} # warn Dumper $data;
# check if PDS details (maybe retrieved from session) match supplied patient
# details (adds/amends 'demographics_verified' flag):
if ( ref $data eq 'HASH' ) {
if ( $data->{ErrorCode} eq 'SMSP-0000' ) { # if PDS returned success
my %args = ( pds => $data, patient => $patient );
$self->_check_demographic_details(\%args);
# store in session for possible future access:
$self->session_store_hashref($data, '_pds_data')
if $data->{nhs_number}; # do NHS no. match next time round
}
}
return $data;
}
#-------------------------------------------------------------------------------
# checks PDS return fields against original patient fields and adds demographics_verified flag:
sub _check_demographic_details {
my ($self, $args) = @_; # warn Dumper $args;
my $patient = $args->{patient}; # original patient data (dob = DT)
my $pds = $args->{pds}; # PDS return
my @fields = qw(last_name first_name gender nhs_number dob);
my $i = 0; # starts 0
$i += ( lc $pds->{$_} eq lc $patient->{$_} ) for @fields; # dob will fail, so:
# check patient dob DT object against PDS string:
$i += ( $pds->{dob} eq $patient->{dob}->ymd ); # warn $i;
# add 'demographics_verified' flag - true if $matches same number as fields:
$pds->{demographics_verified} = ( $i == @fields ) ? 1 : 0; # ensure numeric for session
}
#-------------------------------------------------------------------------------
# create a data structure to hand to the PDS:
sub _format_patient_details {
my ($self, $patient) = @_; # warn Dumper $patient; # hashref (with dob = DT)
my %h = ( # mandatory fields:
Surname => $patient->{last_name},
Gender => 0, # default, maybe updated below
DOB => '19000101', # default, maybe updated below
);
# reformat $H{DOB} as yyyymmdd if supplied (mandatory field so should be):
if ( my $dob = $patient->{dob} ) { # DT object
$h{DOB} = $dob->ymd(''); # string, no spaces
}
# update $h{Gender} with numerical index:
if ( my $gender = $patient->{gender} ) {
my %o = ( M => 1, F => 2 ); # 'U' will retain default 0
$h{Gender} = $o{$gender} if $o{$gender}; # update default unknown 0 if M/F
}
# add optional fields:
$h{NHSNumber} = $patient->{nhs_number} if $patient->{nhs_number};
$h{Forename} = $patient->{first_name} if $patient->{first_name};
$h{Postcode} = $patient->{post_code} if $patient->{post_code};
# add user ID for audit:
$h{VitalDataUserID} = 'HMDS-' . $self->user_profile->{id}; # warn Dumper \%h;
return \%h;
}
#-------------------------------------------------------------------------------
sub _process_pds_response {
my ($self, $pds) = @_; # PDS::Elements::GetPatientDetailsResponse object
my $messages = $self->messages('demographics');
return $messages->{pds_no_xml} unless $pds;
=begin # using as_hash_ref() on $pds object directly now
my @args = (
ForceArray => 0, # force nested elements to be represented as arrays
KeyAttr => '', # don't need it, but required by :strict
SuppressEmpty => undef, # default empty is {}, displayed as HASHREF by tt
);
my $ref = XMLin($pds, @args); warn Dumper $ref; return 1;
my $patient = $ref->{GetPatientDetailsResult}; # warn Dumper $patient; # hashref
=cut
# can call serialize() on $pds to get xml, or as_hash_ref():
my $ref = $pds->as_hash_ref; # warn Dumper $ref;
my $result = $ref->{GetPatientDetailsResult}; # warn Dumper $result; # hashref
return $messages->{pds_no_xml} unless $result; # eg SMS doesn't return a GetPatientDetailsResult
=begin # don't need to return early as tt tests for ErrorCode anwyay
{ # return 'error code' unless SMSP-0000 (success)
my $pds_return_codes = $self->get_yaml_file('pds_return_codes'); # warn Dumper $pds_return_codes;
my $code = $result->{ErrorCode};
my $outcome = $pds_return_codes->{$code};
return $result unless lc $outcome eq 'success'; # single hash value = ErrorCode
}
=cut
# reformat DoB (yyyymmdd) as yyyy-mm-dd:
if ( $result->{DoB} ) {
$result->{DoB} =~ s/(\d{4})(\d{2})(\d{2})/$1-$2-$3/;
} # warn Dumper $patient;
# decode PDS Gender:
if ( my $gender = $result->{Gender} ) {
my %o = ( 0 => 'U', 1 => 'M', 2 => 'F' );
$result->{Gender} = $o{$gender};
}
my %data = (
prefix => $result->{Prefix},
first_name => $result->{GivenName1},
last_name => $result->{FamilyName},
nhs_number => $result->{NHSNumber},
post_code => $result->{HomePostCode},
gender => $result->{Gender},
dob => $result->{DoB},
);
# only include middle name if > 1 char:
$data{middle_name} = $result->{GivenName2}
if $result->{GivenName2} && length $result->{GivenName2} > 1;
# create $data{home_address} attr from HomeAddr1 .. HomeAddr5 components:
if ( grep $result->{'HomeAddr'.$_}, 1 .. 5 ) {
my $str = join ', ',
map $result->{'HomeAddr'.$_},
grep $result->{'HomeAddr'.$_},
(1 .. 5); # empty field is {}, or undef if using SuppressEmpty
$data{home_address} = $str;
}
# include PDS error-code for tt; key = same as PDS return:
$data{ErrorCode} = $result->{ErrorCode};
return \%data;
}
#-------------------------------------------------------------------------------
# log performance of SMS:
sub _log {
my ($self, $t0, $t1, $patient, $result) = @_; # warn Dumper $result;
return 0 unless ( ref $result eq 'HASH' ) ; # eg PDS returned error-code string
# duration of SMS/PDS/RIE query:
my $tdiff = sprintf '%.1f', ( $t1->hires_epoch - $t0->hires_epoch );
my $datetime = $t0->datetime; $datetime =~ s/T/@/; # replace 'T' with '@'
$result->{demographics_verified} ||= '0'; # var is either 1 or undef
# stringify patient DoB dt object (WRONG!! - will persist beyond here - handled below):
# if ( my $dob = $patient->{dob} ) { $patient->{dob} = $dob->ymd }
# common fields:
my @fields = qw(last_name first_name gender nhs_number dob);
# handle patient dob DT carefully - do NOT stringify (will persist):
my @patient_fields = map $patient->{$_}, grep $_ ne 'dob', @fields;
push @patient_fields, ref $patient->{dob} eq 'DateTime'
? $patient->{dob}->ymd # always IS datetime object, but JIC
: $patient->{dob};
my @cols = (
$datetime,
$self->authen->username, # user id
@patient_fields, # common patient fields (dob -> str)
@{$result}{@fields}, # common result fields
$result->{ErrorCode}, # SMS outcome
$result->{demographics_verified}, # our verification flag
$tdiff, # SMS query duration
);
{ # write data to logfile:
my $logfile = $self->cfg('path_to_app_root') . '/logs/sms.csv';
my $csv = Text::CSV_XS->new({ binary => 1, eol => $/ });
$csv->combine(@cols);
io($logfile)->append($csv->string);
}
}
1;
