File Coverage

lib/Net/HL7/Message.pm

Criterion	Covered	Total	%
statement	150	156	96.1
branch	47	54	87.0
condition	8	9	88.8
subroutine	19	20	95.0
pod	12	12	100.0
total	236	251	94.0

################################################################################
#
# File      : Message.pm
# Author    : Duco Dokter
# Created   : Mon Nov 11 17:37:11 2002
# Version   : $Id: Message.pm,v 1.21 2015/01/29 15:30:11 wyldebeast Exp $
# Copyright : D.A.Dokter, Wyldebeast & Wunderliebe
#
################################################################################

package Net::HL7::Message;

use 5.004;
use strict;
use warnings;
use Net::HL7::Segment;
use Net::HL7;

=pod

=head1 NAME

Net::HL7::Message

=head1 SYNOPSIS

my $request = new Net::HL7::Request();
my $conn = new Net::HL7::Connection('localhost', 8089);

my $msh = new Net::HL7::Segments::MSH();

my $seg1 = new Net::HL7::Segment("PID");

$seg1->setField(1, "foo");

$request->addSegment($msh);
$request->addSegment($seg1);

my $response = $conn->send($request);


=head1 DESCRIPTION

In general one needn't create an instance of the Net::HL7::Message
class directly, but use the L
class. When adding segments, note that the segment index starts at 0,
so to get the first segment, segment, do
C<$msg-EgetSegmentByIndex(0)>.

The segment separator defaults to \015. To change this, set the
variable $Net::HL7::SEGMENT_SEPARATOR.


=head1 METHODS

=over 4

=item B<$msg = new Net::HL7::Message([$msg])>

The constructor takes an optional string argument that is a string
representation of a HL7 message. If the string representation is not a
valid HL7 message. according to the specifications, undef is returned
instead of a new instance. This means that segments should be
separated within the message with the segment separator (defaults to
\015) or a newline, and segments should be syntactically correct.
When using the string argument constructor, make sure that you have
escaped any characters that would have special meaning in Perl. For
instance (using a different subcomponent separator):

    C<$msg = new Net::HL7::Message("MSH*^~\\@*1\rPID***x^x@y@z^z\r");>

would actually mean

    C<$msg = new Net::HL7::Message("MSH*^~\\@*1\rPID***x^x^z\r");>

since '@y@z' would be interpreted as two empty arrays, so do:

    C<$msg = new Net::HL7::Message("MSH*^~\\@*1\rPID***x^x\@y\@z^z\r");>

instead.

The control characters and field separator will take the values from
the MSH segment, if set. Otherwise defaults will be used. Changing the
MSH fields specifying the field separator and control characters after
the MSH has been added to the message will result in setting these
values for the message.

If the message couldn't be created, for example due to a erroneous HL7
message string, undef is returned.

=cut

sub new {

    my $class = shift;
    bless my $self = {}, $class;

    $self->_init(@_) || return undef;

    return $self;
}


sub _init {

    my ($self, $hl7str) = @_;

    # Array holding the segments
    #
    $self->{SEGMENTS} = [];

    # Control characters and other HL7 properties
    #
    $self->{SEGMENT_SEPARATOR}      = $Net::HL7::SEGMENT_SEPARATOR;
    $self->{FIELD_SEPARATOR}        = $Net::HL7::FIELD_SEPARATOR;
    $self->{COMPONENT_SEPARATOR}    = $Net::HL7::COMPONENT_SEPARATOR;
    $self->{SUBCOMPONENT_SEPARATOR} = $Net::HL7::SUBCOMPONENT_SEPARATOR;
    $self->{REPETITION_SEPARATOR}   = $Net::HL7::REPETITION_SEPARATOR;
    $self->{ESCAPE_CHARACTER}       = $Net::HL7::ESCAPE_CHARACTER;
    $self->{HL7_VERSION}            = $Net::HL7::HL7_VERSION;

    # If an HL7 string is given to the constructor, parse it.
    if ($hl7str) {

	my @segments = split("[\n\\" . $self->{SEGMENT_SEPARATOR} . "]", $hl7str);

	# the first segment should be the control segment
	#
	$segments[0] =~ /^([A-Z0-9]{3})(.)(.)(.)(.)(.)(.)/;

	my ($hdr, $fldSep, $compSep, $repSep, $esc, $subCompSep, $fldSepCtrl) =
	    ($1, $2, $3, $4, $5, $6, $7);

	# Check whether field separator is repeated after 4 control characters

	if ($fldSep ne $fldSepCtrl) {

	    return undef;
	}

	# Set field separator based on control segment
	$self->{FIELD_SEPARATOR}        = $fldSep;

	# Set other separators
	$self->{COMPONENT_SEPARATOR}    = $compSep;
	$self->{SUBCOMPONENT_SEPARATOR} = $subCompSep;
	$self->{ESCAPE_CHARACTER}       = $esc;
	$self->{REPETITION_SEPARATOR}   = $repSep;

	# Do all segments
	#
	for (my $i = 0; $i < @segments; $i++) {

	    my @fields = split('\\' . $self->{FIELD_SEPARATOR}, $segments[$i]);

	    my $name = shift(@fields);

	    # Now decompose fields if necessary, into refs to arrays
	    #
	    for (my $j = 0; $j < @fields; $j++) {

		# Skip control field
		if ($i == 0 && $j == 0) {

		    next;
		}

		my @comps = split('\\' . $self->{COMPONENT_SEPARATOR}, $fields[$j]);

		for (my $k = 0; $k < @comps; $k++) {

		    my @subComps = split('\\' . $self->{SUBCOMPONENT_SEPARATOR}, $comps[$k]);

		    # Make it a ref or just the value
		    if (@subComps <= 1) {
			$comps[$k] = $subComps[0];
		    }
		    else {
			$comps[$k] = \@subComps;
		    }

		}

		if (@comps <= 1) {
		    $fields[$j] = $comps[0];
		}
		else {
		    $fields[$j] = \@comps;
		}
	    }

	    my $seg;

	    # untaint
	    my $segClass = "";

	    if ($name =~ /^[A-Z][A-Z0-9]{2}$/) {
		$segClass = "Net::HL7::Segments::$name";
		$segClass =~ /^(.*)$/;
		$segClass = $1;
	    }

	    # Let's see whether it's a special segment
            #
	    if ( $segClass && eval("require $segClass;") ) {
		unshift(@fields, $self->{FIELD_SEPARATOR});
		$seg = eval{ "$segClass"->new(\@fields); };
	    }
	    else {
		$seg = new Net::HL7::Segment($name, \@fields);
	    }

	    $seg || return undef;

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

    return 1;
}


=pod

=item B

Add the segment. to the end of the message. The segment should be an
instance of L.

=cut

sub addSegment {

    my ($self, $segment) = @_;

    if (@{ $self->{SEGMENTS} } == 0) {
	$self->_resetCtrl($segment);
    }

    push( @{ $self->{SEGMENTS} }, $segment);
}


=pod

=item B

Insert the segment. The segment should be an instance of
L. If the index is not given,
nothing happens.

=cut

sub insertSegment {

    my ($self, $segment, $idx) = @_;

    (! defined $idx) && return;
    ($idx > @{ $self->{SEGMENTS} }) && return;

    if ($idx == 0) {

	$self->_resetCtrl($segment);
	unshift(@{ $self->{SEGMENTS} }, $segment);
    }
    elsif ($idx == @{ $self->{SEGMENTS} }) {

	push(@{ $self->{SEGMENTS} }, $segment);
    }
    else {
	@{ $self->{SEGMENTS} } =
	    (@{ $self->{SEGMENTS} }[0..$idx-1],
	     $segment,
	     @{ $self->{SEGMENTS} }[$idx..@{ $self->{SEGMENTS} } -1]
	     );
    }
}


=pod

=item B

Return the segment specified by $index. Segment count within the
message starts at 0.

=cut

sub getSegmentByIndex {

    my ($self, $index) = @_;

    return $self->{SEGMENTS}->[$index];
}


=pod

=item B

Return an array of all segments with the given name

=cut

sub getSegmentsByName {

    my ($self, $name) = @_;

    my @segments = ();

    foreach (@{ $self->{SEGMENTS} }) {
	($_->getName() eq $name) && push(@segments, $_);
    }

    return @segments;
}


=pod

=item B

Remove the segment indexed by $index. If it doesn't exist, nothing
happens, if it does, all segments after this one will be moved one
index up.

=cut

sub removeSegmentByIndex {

    my ($self, $index) = @_;

    ($index < @{ $self->{SEGMENTS} }) && splice( @{ $self->{SEGMENTS} }, $index, 1);
}


=pod

=item B

Set the segment on index. If index is out of range, or not provided,
do nothing. Setting MSH on index 0 will revalidate field separator,
control characters and hl7 version, based on MSH(1), MSH(2) and
MSH(12).

=cut

sub setSegment {

    my ($self, $segment, $idx) = @_;

    (! defined $idx) && return;
    ($idx > @{ $self->{SEGMENTS} }) && return;

    if ($segment->getName() eq "MSH" && $idx == 0) {

	$self->_resetCtrl($segment);
    }

    @{ $self->{SEGMENTS} }[$idx] = $segment;
}


# After change of MSH, reset control fields
#
sub _resetCtrl {

    my ($self, $segment) = @_;

    if ($segment->getField(1)) {
	$self->{FIELD_SEPARATOR} = $segment->getField(1);
    }

    if ($segment->getField(2) =~ /(.)(.)(.)(.)/) {

	$self->{COMPONENT_SEPARATOR}    = $1;
	$self->{REPETITION_SEPARATOR}   = $2;
	$self->{ESCAPE_CHARACTER}       = $3;
	$self->{SUBCOMPONENT_SEPARATOR} = $4;
    }

    if ($segment->getField(12)) {
	$self->{HL7_VERSION} = $segment->getField(12);
    }
}


=pod

=item B

Return an array containing all segments in the right order.

=cut

sub getSegments {

    my $self = shift;

    return @{ $self->{SEGMENTS} };
}


=pod

=item B

Return a string representation of this message. This can be used to
send the message over a socket to an HL7 server. To print to other
output, use the $pretty argument as some true value. This will not use
the default segment separator, but '\n' instead.

=cut

sub toString {

    my ($self, $pretty) = @_;
    my $msg = "";

    # Make sure MSH(1) and MSH(2) are ok, even if someone has changed
    # these values
    #
    my $msh = $self->{SEGMENTS}->[0];

    $self->_resetCtrl($msh);

    for (my $i = 0; $i < @{ $self->{SEGMENTS} }; $i++) {

        $msg .= $self->getSegmentAsString($i);

        $pretty ? ($msg .= "\n") : ($msg .= $self->{SEGMENT_SEPARATOR});
    }

    return $msg;
}


=pod

=item B

Get the string representation of the segment, in the context of this
message. That means the string representation will use the message's
separators.

=cut

sub getSegmentAsString {

    my ($self, $index) = @_;

    my $seg = $self->getSegmentByIndex($index);

    $seg || return undef;

    my $segStr = $seg->getName() . $self->{FIELD_SEPARATOR};

    my $start = $seg->getName() eq "MSH" ? 2 : 1;

    {
        no warnings;

        foreach ($start..$seg->size()) {

            $segStr .= $self->getSegmentFieldAsString($index, $_);
            $segStr .= $self->{FIELD_SEPARATOR};
        }
    }

    return $segStr;
}


=pod

=item B


=cut

sub getSegmentFieldAsString {

    my ($self, $segIndex, $fldIndex) = @_;

    my $seg = $self->getSegmentByIndex($segIndex);

    $seg || return undef;

    return $seg->getFieldAsString($fldIndex);
}


=pod

=item B

Remove the segment indexed by $name. If it doesn't exist, nothing
happens, if it does, all segments after this one will be moved one
index up.

=back

=cut

sub removeSegmentByName {

     my ($self, $name) = @_;
     my $i = 0;

     foreach (@{ $self->{SEGMENTS} }) {
         if ($_->getName() eq $name) {
             splice( @{ $self->{SEGMENTS} }, $i, 1);
         }
         else {
             $i++;
         }
     }
}


1;

=pod

=head1 AUTHOR

D.A.Dokter

=head1 LICENSE

Copyright (c) 2002 D.A.Dokter. All rights reserved.  This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.

=cut