• Files
• Commits
• Log
• Graph
• Stats

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 settings   => ( is => 'ro', isa => HashReference,    required => 1 );
has $_ => ( is => 'ro', isa => String, required => 1 )
	for qw(sending_application sending_facility receiving_system receiving_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, $counter) = @_;

	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, 'ORU^R01');
	{ # MSH field 10 message control ID
		my $id = sprintf 'hmds_%s.%03d', $now->strftime('%Y%m%d'), $counter;
		$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');

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

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

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

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

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

	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 $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~$nhs_number^$NULL^$NULL^NHS"
			: "$unit_number^$NULL^$NULL^MRN";
		$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, $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});

	$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");
	# PV1 field 8 Referring Doctor National Code^Name
	$seg->setField(8, "$referrer_code^$referrer_name");

	# avoid uninitialized warnings in HL7::Segment using hl7d:
    $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, $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);

	# 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, $vars) = @_;

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

	my $organisation_code	= $vars->{organisation_code};
	my $referrer_code 		= $vars->{referrer_code};
	my $request_date		= $vars->{created_at};
	my $report_date			= $vars->{report_date};
	my $auth_date			= $vars->{auth_date};
	my $report_by			= $vars->{report_by};
	my $auth_by				= $vars->{auth_by};
	my $referrer			= $vars->{referrer_name};
	my $specimen 			= $vars->{sample_code};

	my $request_number = _get_request_number($vars);
	my $NULL = $self->_get_null_field();

	# convert dates to required 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 Filler Order Number (use sample number)
	$seg->setField(3, $request_number);
	# OBR field 4 Universal Service Identifier (identifierST^text^nameofcodingsystem)
	$seg->setField(4, 'DSR^HMDS Report^LC');
	# OBR field 6 collection date/time in format ccyyMMddHHmm, does not exist
	# OBR field 7 Observation date/time
	$seg->setField(7, $request_date);
	# OBR field 14 Recieve date/time in format ccyyMMddHHmm (time sample requested)
	$seg->setField(14, $request_date);
	# 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 in format ccyyMMddHHmm
	$seg->setField(22, $auth_date);
	# OBR field 24 speciality code (General Pathology)
	$seg->setField(24, '820');
	# OBR field 25 status : final report
 	$seg->setField(25, 'F');
	# OBR field 32 Principal Result Interpreter (reporter)
	$seg->setField(32, $report_by);
	# OBR field 33 Assistant Result Interpreter (authoriser)
	$seg->setField(33, $auth_by);

	# 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, $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"); # p $seg;

	$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); # 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 => 'Application Accept', # Ensemble
        AE => 'Application Error', # hl7d
        CE => 'Application Error', # Ensemble
        AR => 'Application Reject', # hl7d
        CR => 'Application Reject', # Ensemble
    );

    # set default, in case eg server timeout:
	my $rtn_str = 'No response from HL7d';

	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;
		# override default rtn val:
        $rtn_str = sprintf '%s [%s]', $response_code{$msa_code}, $msg_id;

        # if response code is not success (AA or CA), set new $rtn_val with error:
        unless ( $msa_code =~ /[AC]A/ ) {
            # 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]',
				$response_code{$msa_code}, $msg_id, $err;
        }
    }

    return $rtn_str;
}

# ------------------------------------------------------------------------------
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][BL|F|SL|U|A]/;
	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_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;
}

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

1;