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;