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][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_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;
