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

use Moose::Role;
use Data::Dumper;
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 = shift;
    my $args = shift; # warn Dumper $args->{patient}->as_tree(deflate => 0);

    my $patient  = $args->{data}->as_tree(deflate => 0); # warn Dumper $patient;
    my $messages = $args->{msgs};
    my $config   = $args->{config}; # warn $config->{pds_proxy};    
	
	my $pds = PDS::Interfaces::PatientInterface::PatientInterfaceSoap->new();
    $pds->set_proxy($config->{pds_proxy})if $ENV{DEVEL_SERVER}; # dev server can't find 'regint'
#    $pds->outputxml(1);
=begin # alternate method - doesn't work
    use SOAP::WSDL::Client;
    my $urn = 'urn:Leeds-Renal.service/'
        . 'LTH.Renal.BusinessService.RenalWebService.GetPatientDetails'; 
    my %method = (
       soap_action => $urn,
       operation   => 'GetPatientDetails',
       style       => 'document',
       use         => 'literal',
    );
    my @parts = %h; warn Dumper \@parts;
    
    my $soap = SOAP::WSDL::Client->new({ proxy => $config->{pds_proxy} });
    my $result2 = $soap->call( \%method, [] ); warn Dumper $result2; 
=cut

    my $result;
    { # get PDS result inside a Sys::SigAction::timeout_call - normal alarm/eval/die doesn't work with $pds
        my $args = $self->_process_patient_details($patient); # warn Dumper $args;
        my $sub  = sub {
            $result = $pds->GetPatientDetails($args);
        };
        # Sys::SigAction::timeout_call( $duration, sub ):
        if ( timeout_call( 10, $sub ) ) { return $messages->{pds_timeout} } 
    } # warn Dumper $result; # PDS::Elements::GetPatientDetailsResponse object 

=begin # normal alarm/eval/die doesn't work
    eval { # in case we're in off-line testing mode
        local $SIG{ALRM} = sub { die $messages->{pds_timeout} . "\n" }; # NB \n required
        # create data structure from $patient to hand to PDS:
        my $args = $self->_process_patient_details($patient); # warn Dumper $args;

        alarm 10;
        # while (1) {} # this triggers timeout, PDS offline doesn't - why ?? does $pds use alarm ??
		$result = $pds->GetPatientDetails($args); # warn Dumper $result;
        alarm 0; # warn Dumper $result; # PDS::Elements::GetPatientDetailsResponse object 
    };
    return $@ if $@;
    # return $result if not $result; # see docs for reasons for stupid syntax
=cut
	# parse PDS return:
	my $data = $self->_process_pds_response($result); # warn Dumper $data;
	return $data || $messages->{pds_no_xml}; # sub returns 0 if no xml passed
}

# create a data structure to hand to the PDS:
sub _process_patient_details {
	my ($self, $patient) = @_;

    # reformat dob as yyyymmdd if supplied (mandatory field so should be):
    if ( $patient->{dob} ) {
        my $str = $patient->{dob}->ymd(''); # string, no spaces
        $patient->{dob} = $str;
    } # warn Dumper $patient;
	else { # mandatory field
        $patient->{dob} = '19000101'; 
    }
    
	# replace gender with numerical index:
	if ( my $gender = $patient->{gender} ) {
		my %o = (
			U => 0, # PDS = not recorded
			M => 1,
			F => 2,
		);
		$patient->{gender} = $o{$gender} || $o{U}; # default unknown
	}
	my %h = (
        Surname  =>  $patient->{last_name},
        Forename =>  $patient->{first_name},
        Gender   =>  $patient->{gender},
		DOB 	 =>  $patient->{dob},
#       Postcode =>  $some_value, # string
	);
	# add NHS number if exists:
	$h{NHSNumber} = $patient->{nhs_number} if $patient->{nhs_number};
	# add user ID for audit:
	$h{VitalDataUserID} = 'HMDS-' . $self->user_profile->{id};
	# warn Dumper \%h;
	return \%h;
}

sub _process_pds_response {
	my ($self, $pds) = @_;
    return 0 unless $pds; # PDS::Elements::GetPatientDetailsResponse object 

=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 $patient = $ref->{GetPatientDetailsResult}; # warn Dumper $patient; # hashref
    
    my $pds_return_codes = $self->get_yaml_file('pds_return_codes'); # warn Dumper $pds_return_codes;
    
    { # return 'error code' unless SMSP-0000 (success):
        my $code = $patient->{ErrorCode};
        my $result = $pds_return_codes->{$code};
        return $result unless lc $result eq 'success';
    }
    
    # reformat DoB (yyyymmdd) as yyyy-mm-dd:
    if ( $patient->{DoB} ) {
        $patient->{DoB} =~ s/(\d{4})(\d{2})(\d{2})/$1-$2-$3/;
    } # warn Dumper $patient;
    # decode PDS Gender:
	if ( my $gender = $patient->{Gender} ) {
		my %o = (
			1 => 'M',
			2 => 'F',
		);
		$patient->{Gender} = $o{$gender} || 'U'; # default unknown
	}

	my %data = (
		prefix      => $patient->{Prefix},
		first_name  => $patient->{GivenName1},
		last_name   => $patient->{FamilyName},
		nhs_number  => $patient->{NHSNumber},
		gender      => $patient->{Gender},
		dob			=> $patient->{DoB},
#		error_code  => $patient->{ErrorCode}, # handled above
		post_code   => $patient->{HomePostCode},
	);
	
    # only include middle name if > 1 char:
    $data{middle_name} = $patient->{GivenName2}
        if $patient->{GivenName2} && length $patient->{GivenName2} > 1;

    # create $data{home_address} attr from HomeAddr1 .. HomeAddr5 components:
	if ( grep $patient->{'HomeAddr'.$_}, 1 .. 5 ) {
		my $str = join ', ',
			map  $patient->{'HomeAddr'.$_},
			grep $patient->{'HomeAddr'.$_},
            (1 .. 5); # empty field is {}, or undef if using SuppressEmpty
	
		$data{home_address} = $str;
	}
	
	return \%data;
}

1;