package LIMS::Local::PAS;
=begin nd
Class: LIMS::Local::PAS
exports nothing, call PAS->new(\%args)->query() or PAS->new(\%args)->demographics()
returns ref to array of hashrefs (last_name, first_name, dob, nhs_number, case_number),
or string if nothing found; see __END__ for list of PAS codes
=cut
use LWP::UserAgent;
use LIMS::Local::Debug;
use XML::Simple qw(:strict); # need to specify ForceArray & KeyAttr if using :strict here
use Data::Dumper;
use Moose;
use MooseX::AttributeHelpers;
use namespace::clean -except => 'meta';
# args passed in from calling class:
has [ qw(config patient messages) ] => (
is => 'ro',
isa => 'HashRef',
required => 1,
);
has xml => (
is => 'ro',
isa => 'ArrayRef[HashRef]',
default => sub { [] },
metaclass => 'Collection::Array',
provides => { push => 'add_to_xml' }, # MooseX::AttributeHelpers
);
has diffs => (
is => 'ro',
isa => 'ArrayRef[HashRef]',
default => sub { [] },
metaclass => 'Collection::Array',
provides => {
push => 'add_to_diffs',
count => 'have_diffs', # predicate => has_diffs doesn't work: '[]' is always true
}, # MooseX::AttributeHelpers
);
has response => (
is => 'ro',
isa => 'ArrayRef[HTTP::Response]', # HTTP::Response objects
default => sub { [] },
metaclass => 'Collection::Array',
provides => { push => 'add_to_response' }, # MooseX::AttributeHelpers
);
has errors => (
is => 'ro',
isa => 'ArrayRef[Str]', # $r->status_line
default => sub { [] },
metaclass => 'Collection::Array',
provides => { push => 'add_to_errors' }, # MooseX::AttributeHelpers
);
has patient_validated => (
is => 'rw',
isa => 'Int',
predicate => 'have_valid_patient',
# trigger => sub { warn 'patient_validated' },
);
has user_agent => (
is => 'ro',
isa => 'LWP::UserAgent',
lazy_build => 1, # equivalent to lazy => 1, builder => _build_foo
);
has searchable_field_names => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub { [] },
);
__PACKAGE__->meta->make_immutable;
my $fh; # uncomment line below to debug query:
# open $fh, '>', '/home/raj/www/apps/HMDS/trunk/logs/pas.txt';
# TODO: make these part of object:
# list of searchable patient params to create PAS query:
my @INITIAL_SEARCH_FIELDS = qw(unit_number nhs_number);
my @FOLLOW_UP_SEARCH_FIELDS = qw(
last_name
first_name
unit_number
nhs_number
post_code
dob
);
# list of patient params for comparison in detect_diffs():
my @PATIENT_FIELDS = qw(last_name first_name dob nhs_number);
# conversion table for converting patient params to PAS terms:
my %PAS_TERMS = (
last_name => 'SN',
first_name => 'FN',
unit_number => 'PAS',
nhs_number => 'NNN',
post_code => 'PCODE',
dob => 'DOB',
);
# variable: $QUERY_STRING_SEPARATOR
# query string separator character
my $QUERY_STRING_SEPARATOR = '&';
=begin nd
Function: query()
Query PAS system to check submitted demographic data. Uses XML::Simple::XMLin()
to parse content returned by LWP::UserAgent from PAS into a Perl-readable complex
data structure. Returns a ref to an array of hashrefs of PAS demographic data if any
patient data field differs from PAS data, or a status message (eg no PAS matches,
demographic data verified, PAS server error, etc)
=cut
#-------------------------------------------------------------------------------
sub query {
my $self = shift;
my $patient = $self->patient; # DEBUG $patient;
# load list of field names on which to do PAS search:
$self->set_searchable_fields($patient);
my $unit_number_data = $patient->{unit_number};
# $patient->{unit_number} can be string or arrayref:
if ( ref $unit_number_data eq 'ARRAY' ) { # warn 'ARRAY';
UNIT_NUMBER:
foreach my $unit_number (@$unit_number_data) { # warn $unit_number;
# need to clone patient so we don't clobber $patient->{unit_number}:
my %cloned_patient = %$patient;
# replace unit_number array with each string value:
$cloned_patient{unit_number} = $unit_number;
my $response = $self->do_query(\%cloned_patient) || next UNIT_NUMBER;
$self->add_to_response($response);
}
}
else {
my $response = $self->do_query($patient); # warn Dumper $response;
$self->add_to_response($response) if $response; # or will crash Moose
}
my $result = $self->process_response;
return $result;
}
=begin nd
Function: do_query()
Called by <query()> on each entry in patient unit_number array. Returns empty
if it can't create a query string from submitted patient params. Uses LWP::UserAgent
to send http query to PAS server, and returns HTTP::Response, or error message.
=cut
#-------------------------------------------------------------------------------
sub do_query {
my $self = shift;
my $patient = shift;
my $config = $self->config;
my $searchable_field_names = $self->searchable_field_names;
# variable $query
# Constructs query string to send to PAS interface. Generates list of name=value
# pairs from $patient hashref. Converts application fieldname -> PAS equivalent
# fieldname if necessary (eg nhs_number => 'NNN')
my $query = join $QUERY_STRING_SEPARATOR,
map {
sprintf '%s=%s',
$PAS_TERMS{$_} || $_,
$patient->{$_};
} grep $patient->{$_}, @$searchable_field_names; # warn $query;
return unless $query;
# full url for query:
my $url = sprintf 'http://%s?CMD=GETPAT&%s',
$config->{pas_address},
$query; # warn $url;
my $ua = $self->user_agent;
# variable: $response
# captures return from query sent to PAS interface
my $response;
eval { # in case we're in off-line testing mode
local $SIG{ALRM} = sub {
die $self->messages->{pas_timeout} . "\n"; # NB \n required
};
alarm 15;
$response = $ua->get( $url ); # DEBUG($response);
alarm 0;
};
return $response;
}
=begin nd
Function: process_response()
Called by <query()> to processes $self->response arrayref. Returns 'insufficient info'
message if array empty. Otherwise, analyses each HTTP::Response object for
'is_success' flag. If present, parses $o->content with XML::Simple::XMLin,
and pushes $xml onto $self->xml array if $xml->{PERSON} exists. If 'is_success'
not set, pushes $o->status_line onto $self->errors array. Function returns 'result',
either from <process_xml()> if $self->xml exists, or from $self->errors if exists,
otherwise 'no PAS matches'
=cut
#-------------------------------------------------------------------------------
sub process_response {
my $self = shift;
my $response = $self->response; # warn Dumper $response;
my $messages = $self->messages; # DEBUG $messages;
# empty $response array means insufficient info to process query:
return $messages->{pas_insufficient_info} unless @$response;
RESPONSE:
foreach my $r (@$response) { # $self->_debug($r);
# if not success, capture message:
unless ($r->is_success) {
$self->add_to_errors($r->status_line);
next RESPONSE;
}
my $xml = XMLin($r->content, ForceArray => 0, KeyAttr => '');
# if PERSON block populated, we have a result:
if ($xml->{PERSON}) { # warn Dumper $xml;
$self->add_to_xml($xml);
}
}
my $result;
# $self->xml means we have a result:
if ( @{ $self->xml } ) { # warn Dumper $self->xml;
$result = $self->process_xml;
}
# $self->errors means one (or more) responses failed is_success() test:
elsif ( my @errs = @{ $self->errors } ) {
$result = join ', ', @errs; warn $result;
}
# all responses = is_success() and no $xml->{PERSON} = no PAS matches:
else {
$result = $messages->{pas_no_matches};
}
return $result;
}
=begin
# if ($@) { # doesn't trigger $@ after alarm period expired so $response contains HTTP::Request object
# $response->{_msg} contains query status (eg 'OK', or failure message):
if ($response->{_msg} =~ /pas_server_timeout/) { # pas_server_timeout = PAS error msg
$response = $messages->{pas_timeout};
} # DEBUG ($response);
=cut
=begin nd
Function: process_xml()
Called by <process_response()> if $self->xml array exists. Sends each XMLin
object in $self->xml array to <process_patient_data()> which sets $self->diffs
or $self->patient_validated, and function return depends on which one is set.
=cut
#-------------------------------------------------------------------------------
sub process_xml {
my $self = shift;
foreach my $xml ( @{ $self->xml } ) {
# $xml->{PERSON} exists, checked in RESPONSE block:
my $patient_data = $xml->{PERSON};
# If $patient_data is single hashref send to <_process_patient_data()>,
# which calls <_detect_diffs> to compare patient data with PAS
# demographics, pushing hashrefs of mismatching patient data into
# $self->diffs array. If $patient_data is arrayref then it contains data
# on > 1 patient. Send each dataset to <_process_patient_data()>:
if (ref $patient_data eq 'ARRAY') { # warn 'ARRAY';
$self->process_patient_data($_) for @$patient_data;
}
else { # warn 'NOT ARRAY';
$self->process_patient_data($patient_data);
}
}
my $result;
# should now have either $self->diffs or $self->patient_validated:
if ($self->have_diffs) { # warn Dumper $self->diffs;
$result = $self->diffs;
}
elsif ($self->have_valid_patient) { # warn 'validated';
$result = $self->messages->{pas_verified};
}
else {
# TODO: is ok if query for new_patient without nhs_no - might not have
#die 'shouldn\'t get here - have neither $self->diffs
# or $self->patient_validated';
}
return $result;
}
=begin nd
Function: process_patient_data()
Called by <process_xml()> on each $xml->{PERSON} dataset. Calls <detect_diffs()>
on each <PATIENT_ID> block, until $self->patient_validated detected. Might
return empty if no unit_number matches and no nhs_number supplied.
=cut
#-------------------------------------------------------------------------------
sub process_patient_data {
my $self = shift;
# variable: $pas_dataset
# hashref containing XML %PERSON dataset
my $pas_dataset = shift; # DEBUG($pas_dataset);
# variable: $case_number_data
# ref to array of 'content' and 'TYPE' hashrefs from PATIENT_IDS block
#(content = case_number, TYPE = [CPSJ])
# numbers such as case-note numbers and PAS numbers will be tied to a patient
# record as <PATIENT_IDS> elements with one of four attributes to identify
# their <TYPE> as follows:
# C = LGI case-note number - there may be multiple of these per patient
# P = LGI PAS number
# S = SMS Number
# J = SJ PAS number
my $patient_ids = $pas_dataset->{PATIENT_IDS}->{PATIENT_ID}; # DEBUG($patient_ids);
my $patient = $self->patient; # warn Dumper $patient;
# function: ENTRY
# send each (TYPE != SMS) entry in $patient_ids arrayref + %PERSON hashref
# ($pas_dataset) to <_detect_diffs()> if PAS case-number ($entry->{content}) matches
# patient unit_number. $entry = hashref of 'content' and 'TYPE' from PATIENT_IDS
# block (content = case_number, TYPE = [CPSJ])
if ( my $patient_unit_number = $patient->{unit_number} ) { # warn Dumper $unit_number;
if ( ref $patient_unit_number eq 'ARRAY' ) {
UNIT_NUMBER:
foreach my $unit_number (@$patient_unit_number) {
ENTRY:
foreach my $entry (@$patient_ids) { # warn Dumper $entry;
next ENTRY if $entry->{TYPE} eq 'S'; # skip SMS numbers
next ENTRY unless $entry->{content} eq $unit_number;
$self->detect_diffs($pas_dataset, $entry);
}
last UNIT_NUMBER if $self->have_valid_patient; # no need to proceed further
}
}
else {
ENTRY:
foreach my $entry (@$patient_ids) { # warn Dumper $entry;
next ENTRY if $entry->{TYPE} eq 'S'; # skip SMS numbers
next ENTRY unless $entry->{content} eq $patient_unit_number;
$self->detect_diffs($pas_dataset, $entry);
}
}
}
return if $self->have_valid_patient; # no need to proceed further
# if unit_number not supplied, or doesn't match PAS demographics,
# $self->patient_validated will be undef so try nhs_number
# (if supplied), or a direct request from pas.cgi for PAS search
# TODO: do we need this:
return unless grep $patient->{$_}, qw( nhs_number _do_pas_search);
{ # same as previous ENTRY block, but omits unit_number checks
ENTRY:
foreach my $entry (@$patient_ids) {
next ENTRY if $entry->{TYPE} eq 'S'; # skip SMS numbers
$self->detect_diffs($pas_dataset, $entry);
# exit loop if $self->patient_validated flag set in _detect_diffs():
last ENTRY if $self->have_valid_patient;
}
}
}
=begin nd
Function: detect_diffs()
Called by <process_single_patient()> to perform comparison between PAS and
patient datasets. Constructs temporary hash of fieldname/value from PAS data,
and pushes ref to it onto $self->diffs arrayref (via $self->add_to_diffs) if
any of the PAS values differs from corresponding patient data
=cut
#-------------------------------------------------------------------------------
sub detect_diffs {
my ($self, $pas_dataset, $patient_id) = @_;
# DEBUG($pas_dataset, $patient_id);
my $diffs = $self->diffs;
# return if PAS unit_number already included in $self->diffs array:
return if grep {
$patient_id->{content} eq $_->{unit_number};
} @$diffs;
# variable: $address
# string constructed from %PERSON ADDRESS1 & ADDRESS2 fields that are not
# empty hashref fields
my $address = join ', ', map $pas_dataset->{ADDRESSES}->{ADDRESS}->{$_},
grep ! ref $pas_dataset->{ADDRESSES}->{ADDRESS}->{$_}, qw/ADDRESS1 ADDRESS2/;
# ADDRESS3 - don't need it
# variable: %demographics
# hash of patient demographic data constructed from PAS dataset & case_number_data,
# to be stored in $self->diffs arrayref if any of the values differ from
# corresponding patient data field.
# Address & zip keys used by Pas::do_search() only
my %demographics = (
last_name => $pas_dataset->{DEMOGRAPHICS}->{SURNAME},
first_name => $pas_dataset->{DEMOGRAPHICS}->{FORENAME},
dob => $pas_dataset->{DEMOGRAPHICS}->{DOB},
nhs_number => $pas_dataset->{DEMOGRAPHICS}->{NNN},
unit_number => $patient_id->{content},
address => substr($address, 0, 30), # truncate at x chars
zip => $pas_dataset->{ADDRESSES}->{ADDRESS}->{POSTCODE},
); # DEBUG \%demographics;
# empty vals are in the form of an empty hashrefs, so need coverting to empty
# string for printing (or get hashref memory address printed):
while ( my ($key, $value) = each %demographics ) {
$demographics{$key} = '' if ref $value; # convert empty hashref to string
}
my $patient = $self->patient;
{
no warnings 'uninitialized';
# map { DEBUG "PAS: $demographics{$_}; patient: $patient->{$_}" } @PATIENT_FIELDS;
}
# send %demographics to $self->diffs if any of the values differs from
# corresponding patient data:
my $difference_detected = grep {
lc $demographics{$_} ne lc $patient->{$_}
} @PATIENT_FIELDS;
if ( $difference_detected ) {
$self->add_to_diffs(\%demographics);
}
# all submitted patient vals match PAS vals, so set 'validated' flag:
else {
$self->patient_validated(1);
}
}
=begin nd
Function: set_searchable_fields()
initial query from Register searches only unit_number & nhs_number, follow-up
search can include all patient demographics fields - uses '_do_pas_search' flag
in query to distinguish.
=cut
#-------------------------------------------------------------------------------
sub set_searchable_fields {
my $self = shift;
my $patient = shift;
if ( $patient->{_do_pas_search} ) {
$self->searchable_field_names(\@FOLLOW_UP_SEARCH_FIELDS);
}
else {
$self->searchable_field_names(\@INITIAL_SEARCH_FIELDS);
}
$self->searchable_field_names or die 'Failed to set searchable filed names';
}
=begin nd
Function: _build_user_agent()
Moose 'lazy_build' function, called on first call to $self->user_agent. Returns
LWP::UserAgent object.
=cut
#-------------------------------------------------------------------------------
sub _build_user_agent {
my $self = shift; # warn '_build_user_agent'; # should only be called once
# use a private var to hold UserAgent object as we can be called >1 per query:
# return $self->{__user_agent} if $self->{__user_agent};
my $config = $self->config;
# variable: $ua
# creates LWP::UserAgent object
my $ua = LWP::UserAgent->new;
# $ua->timeout(20); # pas server handles this, but need it for off-line testing
# variable: $pas_server_address
# PAS interface IP (163.160.107.60 = live system, 163.160.104.239/sysdev01 = test system)
my $pas_addr = $config->{pas_address}; # warn $config->{pas_address};
my $username = $config->{pas_username};
my $password = $config->{pas_pwd};
# get server IP address from $pas_addr (ie (foo)/bar/etc):
my ($server_ip_addr) = $pas_addr =~ m!\A(.*?)/.*!; # warn $server_ip_addr;
# supply port, username & password to PAS interface for authorisation
$ua->credentials( $server_ip_addr . ':80', '', $username, $password );
# add user_agent to $self for _do_query():
# $self->{__user_agent} = $ua;
return $ua;
}
#-------------------------------------------------------------------------------
sub _debug {
my $self = shift;
my $r = shift;
return unless $fh;
print $fh Dumper (
$r->is_success, # 1
$r->content,
$r->status_line, # 200 OK
$r->as_string,
$r->message, # OK
);
}
1;
__END__
How to query cross-city index:
command: GETPAT
parameter: PATID|NNN|PAS|PASTYPE|SN|FN|SXFN|SXSN|INIT|DOB|ADDR1|PCODE|GP|PRAC|SITE|STYPE|STQ
example: http://server:port/xciservlet?CMD=GETPAT&SN=BLOGGS&FN=JOE
Abbreviations:
ADDR1 Any address line
DOB Date of Birth
FN Forename
GP National GP code
INIT Initials
NNN NHS Number
PAS Patient Administration System, any PAS or case-note or SMS number
PASTYPE A code to identify a number as a PAS, case-note or SMS number
PATID PATIENT_ID
PCODE Postcode
PRAC National Practice code
SITE Which SITE data is required from
SN Surname
STQ Start Query
STYPE How matches should be defined � exact, starting with or containing the specified text
SXFN Soundex of Forename
SXSN Soundex of Surname
1;
