package LIMS::Controller::Roles::PatientDemographics;

use IO::All;
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
use SOAP::Lite; # alternative to SOAP::WSDL uses in PDS::*

use Moose::Role;
=begin # get: Can't call method "set" on unblessed reference:
has patient_data => (
    traits    => ['Hash'],
    is        => 'ro',
    isa       => 'HashRef',
    default   => sub { {} },
    handles   => {
        set_patient_data => 'set',
        get_patient_data => 'get',
    },
);
=cut
has _patient_data => ( is => 'rw', isa => 'HashRef' ); # works instead of above

# method wrappers - overridden in D2 app classes (eg uses D2::Core::Session):
#-------------------------------------------------------------------------------
sub get_session_data { # CGI::App uses CGI::Session
    my $self = shift;
    my $data = $self->session->dataref;
    return $data->{_pds_data};
}
sub require_proxy { $ENV{DEVEL_SERVER} } # returns true if dev server
sub get_username  { shift->authen->username } # CAP::Authen
sub get_user_ctr  { shift->cfg('settings')->{_centre} }
sub get_logfile   { shift->cfg('path_to_app_root') . '/logs/sms.csv' }
#-------------------------------------------------------------------------------

sub get_extended_pds_data { # uses SOAP::Lite & GetExtendedPatientDetails:
    my ($self, $patient) = @_; # warn Dumper $patient; # hashref (with DoB = DT)

    my $action = 'GetExtendedPatientDetails'; # move this to config
    my $addr   = '163.160.171.118'; # rie-test
    my $port   =  1983;
    my $urn    = 'Leeds-SMS.service';

    my $proxy = "http://$addr:$port/lthspine";
    my $soap  = SOAP::Lite->new( proxy => $proxy );
# SOAP::Lite->import(+trace => 'all'); # to switch on output for debug

    $soap->on_action( sub { "urn:$urn/$action" } ); # join with '/' for .NET compat
    $soap->autotype(0);
    $soap->default_ns("urn:$urn");

    # get patient hashref formatted for get_pds_data:
    my $ref = $self->_format_patient_details($patient); # warn Dumper $ref;
    # GEPD uses FamilyName/DateOfBirth in place of Surname/DOB:
    $ref->{DateOfBirth} = delete $ref->{DOB};     # required field
    $ref->{FamilyName}  = delete $ref->{Surname}; # required field
    # create array of Soap::Data objects:
    my @data = map { SOAP::Data->name($_)->value($ref->{$_}) } keys %$ref;

    my $som = $soap->call($action,
        SOAP::Data->name('request')->value( SOAP::Data->value(\@data) )
    ); # $som->fault ? warn Dumper $som->fault : warn Dumper $som->result;
    # send $som to modification of _process_pds_response()
 }

sub get_pds_data { # uses SOAP::WSDL/PDS:: & GetPatientDetails:
    my ($self, $patient) = @_; # warn Dumper $patient; # hashref (with DoB = DT)

    # set patient_data for _verify_demographics_data():
    # $self->set_patient_data(%$patient); # requires hash not href - throws error
    $self->_patient_data($patient);

	# 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->get_session_data ) { # warn Dumper $session_data;
			# set $pds_data to session-retrieved data if nhs_no matches:
            if ( $session_data->{nhs_number} == $nhs_number ) {
                $self->_verify_demographics_data($session_data); # don't care about return value
                return $session_data;
            }
		}
	}

	{ # not returned session data so do a PDS lookup & store in session:
		my $messages = $self->messages('demographics');
		my $config   = $self->cfg('settings');

		my $pds = PDS::Interfaces::PatientInterface::PatientInterfaceSoap->new();
		$pds->set_proxy($config->{pds_proxy}) if $self->require_proxy; # dev server can't find 'regint'
        # $pds->no_dispatch(1); # for testing without sending query
        # $pds->outputxml(1);   # to output xml query

		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:
		my $pds_response = $self->_process_pds_response($result); # hashref or string (error)
        # validate demographics (returns 0 if $pds_response not a hashref or contains
        # a PDS error, otherwise sets 'demographics_verified' key & returns true):
        if ( $self->_verify_demographics_data($pds_response) ) { # $pds_response must be a href
            # store $pds_data (confirmed href) in session for possible future access:
			$self->session_store_hashref($pds_response, '_pds_data')
				if $pds_response->{nhs_number}; # to allow NHS no. match next time round
        } # warn Dumper $pds_data;
        # log PDS lookup details (do AFTER _verify_demographics_data):
        $self->_log($t0, $t1, $patient, $pds_response);
        return $pds_response;
	}
    # no return value - already returned
}

#-------------------------------------------------------------------------------
# checks PDS fields against original patient fields and adds/amends
# demographics_verified flag:
sub _verify_demographics_data {
    my ($self, $pds_data) = @_; # warn Dumper $pds_data; # PDS return (hashref or err string)

    # can only validate if PDS returned hashref and error code was 0000 (OK):
    return 0 unless ref $pds_data eq 'HASH'
        && $pds_data->{ErrorCode} eq 'SMSP-0000';

    my $patient = $self->_patient_data; # original patient data href (dob = DT)
    my @fields  = qw(last_name first_name gender nhs_number dob);

	my $i = 0; # starts 0
    { no warnings 'uninitialized'; # perl 5.14 complains if lc called on any
        $i += ( lc $pds_data->{$_} eq lc $patient->{$_} ) for @fields; # dob will fail, so:
        # check patient dob DT object against PDS string:
        $i += ( $pds_data->{dob} eq $patient->{dob}->ymd ); # warn $i;
    }
	# add 'demographics_verified' flag - true if $matches same number as fields:
	$pds_data->{demographics_verified} = ( $i == @fields ) ? 1 : 0; # ensure numeric for session
    return 1;
}

#-------------------------------------------------------------------------------
# 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 a user ID for audit:
        my $user_id = join '-', 'HMDS', $self->get_username, $self->get_user_ctr;
        $h{VitalDataUserID} = uc $user_id; # warn $h{VitalDataUserID};
    } # 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;

    # temp log PDS response - collect responses to create our own mock object:
    _log_pds_response($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

    # get username, pass 'for_log' arg - used by RequestForm::Validate::get_username
    # ignored by __PACKAGE__::get_username:
    my $username = uc $self->get_username(for_log => 1); # warn $username;
    my $centre   = uc $self->get_user_ctr;

	# 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, $username, $centre,
		@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->get_logfile;
        my $csv = Text::CSV_XS->new({ binary => 1, eol => $/ });
        $csv->combine(@cols);
        io($logfile)->append($csv->string);
    }
}

#-------------------------------------------------------------------------------
sub _log_pds_response {
    my $pds_response = shift;

    my $log = '/home/raj/apps/HILIS4/logs/pds_response.log'; # hard-code, used by 2 apps
    if ( ref $pds_response eq 'HASH' ) {
        # don't need to log success:
        return 0 if $pds_response->{ErrorCode} eq 'SMSP-0000';
        io($log)->append(Dumper $pds_response);
    }
    else {
        io($log)->append($pds_response);
    }
}

1;