package LIMS::Local::HL7;

use Moo; # default seems to be to die on uninitialized warnings
use LIMS::Local::MooX::Types qw(NetHL7Request NetHL7Connection HashReference String);

has msg => (
	is 		=> 'ro', # 'lazy' is valid Moo option also (does same as lazy_build)
	isa 	=> NetHL7Request, # MooX::Types::MooseLike def
#	isa 	=> sub { ref $_[0] eq 'Net::HL7::Request' }, non-MooX::Types::MooseLike
	default => sub { new Net::HL7::Request() }, # returns on 1st call
);
has hl7_socket => ( is => 'ro', isa => NetHL7Connection, required => 1 );
has msg_count  => ( is => 'rw', isa => String );
has settings   => ( is => 'ro', isa => HashReference,    required => 1 );
has dataset    => ( is => 'rw', isa => HashReference,
                                      coerce => \&_stringify_datetimes );
has $_ => ( is => 'ro', isa => String, required => 1 )
	for qw(
        sending_application
        receiving_facility
        receiving_system
        sending_facility
    );

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

use LIMS::Local::Utils;
use Data::Printer alias => 'p';
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;
		};
}
# ==============================================================================

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

# ------------------------------------------------------------------------------
sub build_msh_segment {
	my $self = shift;

    my $vars = $self->dataset;
	my $seg  = new Net::HL7::Segments::MSH();

	# MSH field 3 Sending application
	$seg->setField(3, $self->sending_application);
	# MSH field 4 Sending facility
	$seg->setField(4, $self->sending_facility);
	# MSH field 5 Receiving application
	$seg->setField(5, $self->receiving_system);
	# MSH field 6 Receiving facility
	$seg->setField(6, $self->receiving_facility);
	# 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, $vars->{message_type});
	{ # MSH field 10 message control ID
		my $id = sprintf 'hmds_%s.%03d',
            $now->strftime('%Y%m%d'), $self->msg_count;
		$seg->setField(10, $id);
	}
	# MSH field 11 processing ID, P for production
	$seg->setField(11, 'P');
	# MSH field 12 version ID 2.4
	$seg->setField(12, '2.4');

    my $field_count = 12; # for fill_undefs()

    if ( my $val = $vars->{accept_acknowledgement_type} ) {
        $seg->setField(15, $val);
        $field_count += 2; # will have blanks fields 13 & 14 before #15
    }
    if ( my $val = $vars->{application_acknowledgement_type} ) {
        $seg->setField(16, $val);
    }
	# avoid uninitialized warnings in HL7::Segment using hl7d:
    $self->fill_undefs($seg, 1 .. $field_count); # p $seg;

	$self->msg->addSegment($seg);
}

# ------------------------------------------------------------------------------
sub build_pid_segment {
    my $self = shift;

	my $NULL = $self->_get_null_field();
    my $vars = $self->dataset;
	my $seg  = new Net::HL7::Segment('PID');

	my $first_name	= $vars->{first_name};
	my $middle_name	= $vars->{middle_name};
	my $last_name	= $vars->{last_name};
	my $unit_number = $vars->{unit_number};
	my $nhs_number  = $vars->{nhs_number};
	my $gender		= $vars->{gender} || 'U';
    my $mrn_id      = $vars->{mrn_id} || 'MRN';
	my $dob			= $vars->{dob};

	# eliminate dob separators:
	$dob =~ s/\D//g; # warn $dob;

	# 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):
		no warnings 'uninitialized'; # for Moo in case $NULL is undef
		my $str = $nhs_number
			? "$unit_number^$NULL^$NULL^$mrn_id~$nhs_number^$NULL^$NULL^NHS^NHS"
			: "$unit_number^$NULL^$NULL^$mrn_id";
		$seg->setField(3, $str);
	}
	{ # PID field 5 surname and forename
		no warnings 'uninitialized'; # for Moo in case $middle_name is undef
		$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);

	# add NHS number to position 19 if exists (TODO: what's the point ??):
	$seg->setField(19, $nhs_number) if $nhs_number;

	# avoid uninitialized warnings in HL7::Segment using hl7d:
    $self->fill_undefs($seg, 1 .. 19); # p $seg;

	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
sub build_pv1_segment { # patient visit 1
    my $self = shift;

    my $vars = $self->dataset;
	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});

	$seg->setField(1, 1);
	# PV1 field 2 Patient Class
	$seg->setField(2, 'U'); # unknown
	# PV1 field 3 location national code^description^national code
	$seg->setField(3, "$organisation_code^$location^$organisation_code");
    { # Referrer National Code^Name - ICE wants this in PV1#8, Winpath in PV1#9:
        my $referrer = join '^', $referrer_code, $referrer_name;
        $seg->setField(8, $referrer) if $self->receiving_system eq 'ICE';
        $seg->setField(9, $referrer) if $self->receiving_system eq 'WinPath';
    }

	# avoid uninitialized warnings in HL7::Segment using hl7d (#9 either used
    # (WinPath) or doesn't exist (ICE) so only need to consider 1st 8 fields):
    $self->fill_undefs($seg, 1 .. 8); # p $seg;

	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
# ORC segment - Order Control with sample number, requesting clin, etc
sub build_orc_segment {
    my $self = shift;

    my $vars = $self->dataset;
	my $seg  = new Net::HL7::Segment('ORC');

    my $assigning_authority = $vars->{assigning_authority}; # optional, may use lab_number
	my $organisation_code	= $vars->{organisation_code};
    my $request_datetime    = $vars->{created_at};
	my $referrer_code 		= $vars->{referrer_code};
	my $referrer_name		= $vars->{referrer_name};
    my $order_control       = $vars->{order_control};
    my $request_id          = $vars->{request_id};
	my $lab_number          = $vars->{lab_number}; # optional, may use order number/assigning authority

	# ORC field 1 message type:
	$seg->setField(1, $order_control);
    # ORC field 2 placer order number/assigning authority
    if ( $assigning_authority ) {
        my $val = join '^', $request_id, $assigning_authority;
        $seg->setField(2, $val);
    }
	# ORC field 3 sample number
	$seg->setField(3, $lab_number) if $lab_number;
    # ORC field 9 datetime of transaction (created_at):
    $seg->setField(9, $request_datetime);
	# 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);

	# avoid uninitialized warnings in HL7::Segment using hl7d:
    $self->fill_undefs($seg, 1 .. 13); # p $seg;

	$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 = shift;

    my $vars = $self->dataset;
	my $seg  = new Net::HL7::Segment('OBR');

    my $registration_datetime = $vars->{created_at};
    my $observation_datetime  = $vars->{observation_datetime};
    my $assigning_authority   = $vars->{assigning_authority}; # optional, may use lab_number
    my $requested_datetime    = $vars->{requested_datetime}; # not used for NBT ICE
	my $organisation_code	  = $vars->{organisation_code};
    my $speciality_code       = $vars->{speciality_code};
	my $report_datetime		  = $vars->{report_datetime};
    my $request_id            = $vars->{request_id};
	my $lab_number            = $vars->{lab_number}; # optional, may use placer_order_number
	my $authoriser	     	  = $vars->{authoriser}; # not in use by either NBT functions
	my $reporter			  = $vars->{reporter};
	my $referrer			  = $vars->{referrer_name};
	my $specimen 			  = $vars->{sample_code};

	my $NULL = $self->_get_null_field();

	# OBR field 1 Set ID, incrementing number per segment
	$seg->setField(1, 1);
    # OBR field 2 placer order number (used if signing authority supplied for ORC segment)
    if ( $assigning_authority ) { # not used here, just request_id (see ORC segment)
        $seg->setField(2, $request_id);
    }
	# OBR field 3 Filler Order Number (use sample number)
	$seg->setField(3, $lab_number) if $lab_number;
	# OBR field 4 Universal Service Identifier (identifierST^text^nameofcodingsystem)
	$seg->setField(4, 'DSR^HMDS Report^LC');
	# OBR field 6 Requested date/time
    $seg->setField(6, $requested_datetime);
	# OBR field 7 Observation date/time
    $seg->setField(7, $observation_datetime);
	# OBR field 14 Recieve date/time (time sample requested)
	$seg->setField(14, $registration_datetime);
	# OBR field 15 Specimen Source
	$seg->setField(15, $specimen);
	{ # OBR field 16 Ordering Provider
		no warnings 'uninitialized'; # for Moo in case $NULL is undef
		my ($lname, $inits) = split ' ', $referrer;
		$seg->setField(16, "$lname^$NULL^$inits");
	}
	# OBR field 22 report date/time
	$seg->setField(22, $report_datetime);
	# OBR field 24 speciality code:
	$seg->setField(24, $speciality_code);
	# OBR field 25 status : final report
 	$seg->setField(25, 'F');
	# OBR field 32 Principal Result Interpreter (reporter)
	$seg->setField(32, $reporter);
	# OBR field 33 Assistant Result Interpreter (authoriser)
	$seg->setField(33, $authoriser); # not in use for NBT

	# avoid uninitialized warnings in HL7::Segment using hl7d:
    $self->fill_undefs($seg, 1 .. 33); # p $seg;

	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
# OBX segment - Observation Result Segment
sub build_obx_segment {
	my $self = shift;
    my ($field, $value, $i) = @_; # warn Dumper [$field, $value, $i];

	$value ||= 'N/A';
    $i ||= 1; # may come from loop, or not (optional)
	my $n = 0; # field 4 counter

	# wrap any long lines, then split on new-line marker(s):
	my @text = split /\n/, $self->_wrap_text($value, 68); # warn Dumper \@text;

	for my $row (@text) {
		$row =~ s/\r//g; # wrecks formatting if left intact

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

		$seg->setField(1, $i);
		# OBX field 2 data type
		$seg->setField(2, 'TX');
		# OBX field 3 Observation Identifier
		$seg->setField(3, $field);
		# OBX field 4 Observation Sub-Id
		$seg->setField(4, ++$n);  # auto-increment before use
		# OBX field 5 Observation Value
		$seg->setField(5, $row);
		# OBX field 11 Observation Result Status
		$seg->setField(11, 'F'); # F = can only be changed with a corrected result

		# avoid uninitialized warnings in HL7::Segment using hl7d:
		$self->fill_undefs($seg, 1 .. 11); # p $seg;

		$self->msg->addSegment($seg);
	}
}

# ------------------------------------------------------------------------------
sub build_nte_segment { # notes and comments
    my $self = shift;

    my $vars = $self->dataset;
	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"); # p $seg;

	$self->msg->addSegment($seg); # warn Dumper $self->msg;
}

# ------------------------------------------------------------------------------
sub build_report_segment {
    my $self = shift;
    my $vars = $self->dataset;

	# 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); # p $seg;
		$self->msg->addSegment($seg);
	}
}

# ------------------------------------------------------------------------------
# to prevent uninitialized warnings in HL7d:
sub fill_undefs {
    my ($self, $obj, @range) = @_; # p @range;
	my $NULL = $self->_get_null_field(); # p $NULL;
    ( defined $obj->getField($_) ) || $obj->setField($_, $NULL) for @range;
}

# ------------------------------------------------------------------------------
sub send_message {
	my $self = shift;

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

	# send HL7 message and capture acknowledgement:
	my $connection = $self->hl7_socket;
	my $response = $connection->send($msg); # warn Dumper $response;

    my %response_code = (
        AA => 'Application Accept', # hl7d
        CA => 'Commit Accept', # Ensemble
        AE => 'Application Error', # hl7d
        CE => 'Commit Error', # Ensemble
        AR => 'Application Reject', # hl7d
        CR => 'Commit Reject', # Ensemble
    );

	my $rtn_str; # set if response:
	if ($response) { # warn Dumper $response;
		# get MSA segment - use getSegmentsByName() in list mode (n = 1):
        my ($msa) = $response->getSegmentsByName('MSA'); # warn Dumper $msa;
        # retrieve response code & message ID from MSA segment
        my $msa_code = $msa->getFields(1, 1); # warn $msa_code;
		my $msg_id   = $msa->getFields(1, 2); # warn $msg_id;

        if ( $msa_code =~ /[AC]A/ ) { # success (AA or CA)
            $rtn_str = sprintf '%s [%s]', $response_code{$msa_code}, $msg_id;
        }
        else { # if response code is not success, set $rtn_val to error:
            # retrieve err msg from MSA segment field 3 (AE/CE & AR/CR only):
            my $err = $msa->getFields(1, 3); # warn $err;
            $rtn_str = sprintf '%s %s [%s: %s]',
				$response_code{$msa_code}, $msa_code, $msg_id, $err;
        }
    }
    return $rtn_str || 'No response from HL7d';
}

# ------------------------------------------------------------------------------
sub specimen_summary {
	my $self = shift;

	local $_ = shift; # specimen string

	my @title;

	push @title, 'peripheral blood' 	if /PB|CMP/; # CMP excluded
	push @title, 'chimerism' 			if /CHI/; # currently excluding chimerism screen
	push @title, 'bone marrow aspirate' if /BMA$|BMA\,/; # BMA[^T] doesn't work
	push @title, 'bone marrow biopsy' 	if /BMAT|T[B|S][L|P]/;
	push @title, 'tissue biopsy' 		if /[DGLRX]([BS]L|A|F|U)/; # modified to exclude 'WGS'
	push @title, 'effusion' 			if /EF/;
	push @title, 'CSF' 					if /CF/;
	push @title, 'slide' 				if /HS/;
	push @title, 'serum' 				if /SE/;
	push @title, 'urine' 				if /URI/;

#	my $title = @title > 1 ? join (' & ' => join (', ' => @title[ 0 .. @title - 2 ]), $title[-1]) : $title[0];
	my $title = join '&', @title; # print Dumper ($title, length $title) if length $title > 40;
	$title ||= $_; # so var not empty if specimen doesn't match in regex's

	return ( length $title < 41 )
        ? $title
        : 'multiple blood, marrow, tissue specimens';
}

sub get_lab_number {
	my ($self, $vars) = @_; # p $vars;
	return join '/', $vars->{request_number}, $vars->{year} - 2000;
}

sub _stringify_datetimes { # convert dates to required format:
    my $data = shift; # p $data;
    map { $data->{$_} =~ s/\D//g } # eg 2019-05-02T10:22:44 -> 20190502102244
        grep { $data->{$_} =~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}/ }
            grep defined $data->{$_}, keys %$data;
    return $data;
}

sub _get_null_field {
	my $self = shift;

	return $self->settings->{use_hl7_null}
        ? $Net::HL7::NULL # to prevent uninitialized warnings in HL7d
        : undef; # warn $NULL;
}

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 = ( undef, undef, $str ); # don't indent
	my $formatted = LIMS::Local::Utils::text_wrap($cols, \@args); # warn $formatted;
	return $formatted;
}

1;