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, 'Ensemble');
# MSH field 6 Receiving facility
$seg->setField(6, 'Ensemble');
# 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 $NULL = ( $self->settings->{hl7d_addr} eq '127.0.0.1' )
? $Net::HL7::NULL # to prevent uninitialized warnings in HL7d
: undef; # warn $NULL;
my $first_name = $vars->{first_name};
my $middle_name = $vars->{middle_name} || $NULL;
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):
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
$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 $request_date = $vars->{created_at};
my $auth_date = $vars->{updated_at};
my $referrer = $vars->{referrer_name};
my $specimen = $vars->{specimen};
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 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 Specimen Source
my @specimen = split ',', $specimen;
$seg->setField(15, join '&', @specimen;
}
{ # OBR field 16 Ordering Provider
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
$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');
# OBX field 4 UniversalServiceIdentifier (required)
$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;
