package LIMS::Local::HL7;

use Moo; # using faster Moo
use LIMS::Local::MooX::Types qw(NetHL7Request HashReference);

has msg => (
	is 		=> 'ro',
	isa 	=> NetHL7Request, # MooX::Types::MooseLike def
#	isa 	=> sub { ref $_[0] eq 'Net::HL7::Request' }, non-MooX::Types::MooseLike
	default => sub { new Net::HL7::Request() }
);
has settings  => ( is => 'ro', required => 1, isa => HashReference ); 
#__PACKAGE__->meta->make_immutable; # Moo does this automatically

use Net::HL7::Request;
use Net::HL7::Message;
use Net::HL7::Segment;
use Net::HL7::Connection;
use Net::HL7::Segments::MSH;

use Text::Wrap qw($columns fill); $columns = 68;
use LIMS::Local::Utils;
use Data::Dumper;

use Regexp::Common qw(pattern);
# ==============================================================================
use constant SLASH => "\\"; # have to escape slash !! 
{
	pattern name => [ qw(hl7 escape_character) ],
		create => quotemeta "\\", # not used in ->subs() context
		subs   => sub {
			my $a = quotemeta "\\";
			my $b = SLASH.'E'.SLASH; # \ => \E\
			$_[1] =~ s/$a/$b/g;
		};
	pattern name => [ qw(hl7 field_delimiter) ],
		create => quotemeta '|', # not used in ->subs() context
		subs   => sub {
			my $a = quotemeta '|';
			my $b = SLASH.'F'.SLASH; # | => \F\
			$_[1] =~ s/$a/$b/g;
		};
	pattern name => [ qw(hl7 repetition_separator) ],
		create => quotemeta '~', # not used in ->subs() context
		subs   => sub {
			my $a = quotemeta '~';
			my $b = SLASH.'R'.SLASH; # ~ => \R\
			$_[1] =~ s/$a/$b/g;
		};
	pattern name => [ qw(hl7 component_delimiter) ],
		create => quotemeta '^', # not used in ->subs() context
		subs   => sub {
			my $a = quotemeta '^';
			my $b = SLASH.'S'.SLASH; # ^ => \S\
			$_[1] =~ s/$a/$b/g;
		};
	pattern name => [ qw(hl7 sub_component_delimiter) ],
		create => quotemeta '&', # not used in ->subs() context
		subs   => sub {
			my $a = quotemeta '&';
			my $b = SLASH.'T'.SLASH; # & => \T\
			$_[1] =~ s/$a/$b/g;
		};
}
# ==============================================================================

sub _build_msg { new Net::HL7::Request() }

my $now = LIMS::Local::Utils::time_now();
my $wrap_text = sub { LIMS::Local::Utils::text_wrap(@_) };

# ------------------------------------------------------------------------------
sub build_msh_segment {
	my $self = shift;
	
	my $seg = new Net::HL7::Segments::MSH();
	
	# MSH field 3 Sending application
	$seg->setField(3, 'HILIS');
	# MSH field 4 Sending facility
	$seg->setField(4, 'HMDS');
	# MSH field 5 Receiving application
	$seg->setField(5, 'ICE');
	# MSH field 6 Receiving facility
	$seg->setField(6, 'ICE00');
	# MSH field 7 date and time of message in format YYYYMMDD[HHMM]
	$seg->setField(7, $now->strftime('%Y%m%d%H%M') );
	# MSH field 9 message type
	$seg->setField(9, 'ORU^R01');
	# MSH field 10 message control ID
	$seg->setField(10, sprintf 'hmds_%s.001', $now->strftime('%Y%m%d'));
	# MSH field 11 processing ID, P for production
	$seg->setField(11, 'P');
	# MSH field 12 version ID 2.4
	$seg->setField(12, '2.4');
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------ 
sub build_pid_segment {
	my ($self, $vars) = @_;

	my $seg = new Net::HL7::Segment('PID');

	my $unit_number = $vars->{unit_number};
	my $nhs_number  = $vars->{nhs_number};
	my $first_name	= $vars->{first_name};
	my $last_name	= $vars->{last_name};
	my $gender		= $vars->{gender} || 'U';
	my $dob			= $vars->{dob};
	
	# eliminate dob separators:
	$dob =~ s/\D//g; # warn $dob;

	my $NULL = ( $self->settings->{hl7d_addr} eq '127.0.0.1' )
        ? $Net::HL7::NULL # to prevent uninitialized warnings in HL7d
        : undef; # warn $NULL;

	# PID field 1 PID ID, will only ever be 1 as only 1 patient per message
	$seg->setField(1, 1);
	# PID field 3, local hospital number followed by NHS number (if exists):
	if ( $nhs_number ) {
		$seg->setField(3,
			"$unit_number^$NULL^$NULL^MRN~$nhs_number^$NULL^$NULL^NHS");
		# PID field 19 NHS number
		# $seg->setField(19, $nhs_number);
	}
	else {
		$seg->setField(3, "$unit_number^$NULL^$NULL^MRN");
	}
	# PID field 5 surname and forename
#	$seg->setField(5, "$last_name^$first_name^$NULL^$NULL^$NULL^$NULL^L");
	$seg->setField(5, join '^', $last_name, $first_name ); # middle name ??
	# PID field 7 DOB format is YYYYMMDD
	$seg->setField(7, $dob);
	# PID field 8 gender, F – Female, M – Male, U – Unknown
	$seg->setField(8, $gender);
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
sub build_pv1_segment { # patient visit 1
	my ($self, $vars) = @_;

	my $seg = new Net::HL7::Segment('PV1');
	
	my $organisation_code = $vars->{organisation_code};
	my $referrer_code 	  = $vars->{referrer_code};
	my $referrer_name  	  = $vars->{referrer_name};
	
	my $location = _hl7_escape($vars->{location});
	
	# PV1 field 3 location national code^description^national code
	$seg->setField(3, "$organisation_code^$location^$organisation_code");
	# PV1 field 8 Referring Doctor National Code^Name
	$seg->setField(8, "$referrer_code^$referrer_name");
	# PV1 field 9 Consulting Doctor National Code^Name
#	$seg->setField(9, "$referrer_code^$referrer_name"); # do we need this ??
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
# ORC segment - Order Control with sample number, requesting clin, etc
sub build_orc_segment {
	my ($self, $vars) = @_;

	my $seg = new Net::HL7::Segment('ORC');
	
	my $organisation_code	= $vars->{organisation_code};
	my $referrer_code 		= $vars->{referrer_code};
	my $referrer_name		= $vars->{referrer_name};
	my $request_number 		= _get_request_number($vars);
	
	# ORC field 1 message type, RE - Results Transaction
	$seg->setField(1, 'RE');
	# ORC field 3 sample number
	$seg->setField(3, $request_number);
	# ORC field 12 requesting clinician - local code^name
	$seg->setField(12, "$referrer_code^$referrer_name^$referrer_code");
	# ORC field 13 requesting location code
	$seg->setField(13, $organisation_code);
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
# OBR segment - Observation Request Segment acting as report header with request
# date, time, etc
sub build_obr_segment {
	my ($self, $vars) = @_;

	my $seg = new Net::HL7::Segment('OBR');
	
	my $organisation_code	= $vars->{organisation_code};
	my $referrer_code 		= $vars->{referrer_code};
	my $referrer_name		= $vars->{referrer_name};
	my $request_date		= $vars->{created_at};
	my $auth_date			= $vars->{updated_at};

	my $request_number 		= _get_request_number($vars);
	
	# convert dates to ICE format	
	$request_date =~ s/\D//g;
	$auth_date    =~ s/\D//g;

	# OBR field 1 Set ID, incrementing number per segment
	$seg->setField(1, 1);
	# OBR field 3 sample number
	$seg->setField(3, $request_number);
	# OBR field 4 universal service id - order code code^description^LC
	# (to denote local code, no suitable read code available
	$seg->setField(4, 'DSR^HMDS Report^LC');
	# OBR field 6 collection date/time in format ccyyMMddHHmm, does not exist
	# in HiLIS, will use request date/time
	$seg->setField(7, $request_date);
	# OBR field 14 recieve date/time in format ccyyMMddHHmm (time sample requested)
	$seg->setField(14, $request_date);
	# Specimen Characteristic, will send as unspecified as multiple may be sent
	# which are detailed in primary NTE segment
	$seg->setField(15, 'T026^TYPE UNSPECIFIED');
	# OBR field 16 Requesting/Receiving physician
	$seg->setField(16, "$referrer_code^$referrer_name^$referrer_name");
	# OBR field 20 sample number
	$seg->setField(20, $request_number);
	# OBR field 22 report date/time in format ccyyMMddHHmm
	$seg->setField(22, $auth_date);
	# OBR field 24 specialty code
	$seg->setField(24, '820^ICE General Pathology');
	# OBR field 25 status : final report
 	$seg->setField(25, 'F');
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
# OBX segment - Observation Result Segment
sub build_obx_segment {
	my ($self, $vars) = @_;

	my $seg = new Net::HL7::Segment('OBX');
	
	my $sample_number = _get_request_number($vars);
	my $request_date  = $vars->{created_at};
  
	$seg->setField(1, 1);
	# OBX field 2 data type - ST standard text
	$seg->setField(2, 'ST');
	# OBX field 3 investigation code
	$seg->setField(3, 'DSR^HMDS Report^LC');
	
	$seg->setField(4, 1);
	# OBX field 14 collection date (using date booked in)
	$seg->setField(14, $request_date);
	# OBX field 15 sample number
	$seg->setField(15, $sample_number);
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
sub build_nte_segment { # notes and comments
	my ($self, $vars) = @_;

	my $seg = new Net::HL7::Segment('NTE');
	
	my $specimen = $vars->{specimen};
	my $quality	 = $vars->{specimen_quality} || '';
	
	# NTE field 1 Set ID, Sequential Number incrementing by 1 for each NTE
	$seg->setField(1, 1);
	# NTE field 2 Source of Comment C = Clinical Comment follows PID
	# R = Result Comment Usually follows an OBR or OBX
	$seg->setField(2, 'R');
	# NTE field 3 free text comment, in this case specimen details
	$seg->setField(3, "Specimen Data: $specimen, Quality: $quality");
	
	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------	
sub build_report_segment {
	my ($self, $vars) = @_; # warn Dumper $vars;

	# comment:
	my $comment = _hl7_escape($vars->{summaries}); # warn $comment;

	# wrap long lines:
	my $text = $self->_wrap_text($comment, 68); # warn $text;
	
	my $i = 0; # field 1 counter
	# split $text into rows, add each as a new segment with '|' appended:
	for my $line ( split "\n", $text ) { # warn $line;
		$line .= '|'; # effectively replace "\n" with '|'
		my $seg = new Net::HL7::Segment('NTE');
		$seg->setField(1, ++$i); # autoincrement before use
		$seg->setField(2, 'I');
		$seg->setField(3, $line); 
		$self->msg->addSegment($seg);
	}	
}

# ------------------------------------------------------------------------------
sub send_message {
	my ($self, $vars) = @_; # warn Dumper $vars;

	my $msg = $self->msg; # warn Dumper $msg; # Net::HL7::Request object

    my $cfg = $self->settings; # warn Dumper $cfg;
    
	# open HL7 connection via socket
	my $hl7d = new Net::HL7::Connection($cfg->{hl7d_addr}, $cfg->{hl7d_port})
	or die 'Could not connect to HL7d on port ' . $cfg->{hl7d_port};

	# send the HL7 message and wait for acknowledgement
	my $response = $hl7d->send($msg);
    
	# set default error - what ??
	my $error = "Acknowledgement received";
	
	# process hl7 response and correct error accordingly
	if ($response) {
        my $msa_seg = $response->getSegmentByIndex(1);
        # retrieve field 1 of MSA segment
        my $msa_field1 = $msa_seg->getFields(1, 1); # warn $msa_field1;

        # initially set description as successful message
        my $description = "successful transaction";
	
        # check there is no error
        if ( $msa_field1 ne "AA" ) {
            # retrieve field 3 of MSA segment (description of error).
            $description = $msa_seg->getFields(1, 3); # warn $description;
        }
    }
    
	$hl7d->close();
    
    return $error;
	# print $msg->toString(1)."\n";
	# wait five seconds before processing next message
	# sleep 5; # why? - does ICE require this?
}

# --------------------------------------------------------
sub _hl7_escape {
	my $str = shift;
	
=begin # line-noise:
	$str =~ s/\\/\\E\\/g;
	$str =~ s/&/\\T\\/g;
	$str =~ s/\|/\\F\\/g;
	$str =~ s/\^/\\S\\/g;
	$str =~ s/~/\\R\\/g;
	return $str;
=cut	

	$str = $RE{hl7}{escape_character}->subs($str); # DO THIS FIRST
	$str = $RE{hl7}{field_delimiter}->subs($str);
	$str = $RE{hl7}{component_delimiter}->subs($str);
	$str = $RE{hl7}{repetition_separator}->subs($str);
	$str = $RE{hl7}{sub_component_delimiter}->subs($str);
	return $str;
}

# format text: indent, max 68 chars / line:
sub _wrap_text { # Text::Wrap
	my ($self, $str, $cols) = @_;
	
	my $indent = $self->settings->{indent};
	my @args = ( $indent, $indent, $str );
	my $formatted = LIMS::Local::Utils::text_wrap($cols, \@args); # warn $formatted;
	return $formatted; 
}

sub _get_request_number {
	my $vars = shift;
	return join '/', $vars->{request_number}, $vars->{year} - 2000;
}

1;