HLTPCK1 ;AISC/SAW-Header Validation Routine (non-TCP link) ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**8,36,59,120,133**;Oct 13, 1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
CHK(HDR,ARY,MSA) ;Validate Data in Header Segment (MSH, BHS or FHS) of
;an HL7 Message through non-TCP link
;
;This entry point is a subroutine call with parameter passing that
;will return an array (ARY()) consisting of values extracted from
;the message header segment subscripted by the mnemonics for each of
;the message header fields and components
;If an error is encountered during validation, the array parameter
;(ARY) will be set equal to two pieces, error #^error text
;
;Required input parameters:
; HDR = Message header segment
;
; ARY = The array in which the message header values will be
; returned
; Note: The ARY parameter must be passed by reference
;
;Optional input parameter:
; MSA = A variable which contains the message acknowledgement values:
; acknowledgement code^message control ID^text message
;
;Check for required parameters
N ERR S ERR=""
I $G(HDR)']"" S ERR="7^"_$G(^HL(771.7,7,0))_" at CHK^HLTPCK1 entry point" G EXIT
N ECH,HLN,FS,X,X1,X2
S ARY="",ARY("Q")=""""""
;
;Validate field separator and encoding characters
S (ARY("FS"),FS)=$E(HDR,4)
I FS']"" S ERR="Field Separator Missing" G EXIT
I FS?.C S ERR="Invalid Field Separator" G EXIT
S (ARY("ECH"),ECH)=$P(HDR,FS,2)
I ECH']"" S ERR="Encoding Characters Missing" G EXIT
I ECH?.C S ERR="Invalid Encoding Characters" G EXIT
;
; patch HL*1.6*120 start
; patch HL*1.6*133
; escape and sub-component characters are optional
; I $L(ECH)'=4 S ERR="Invalid Encoding Characters" G EXIT
I $L(ECH)<1 S ERR="Invalid Encoding Characters" G EXIT
S ECH(1)=$E(ECH)
S ECH(2)=$E(ECH,2)
S ECH(3)=$E(ECH,3)
S ECH(4)=$E(ECH,4)
S ARY("HDR")=HDR
S ARY("HDR-1")=$E(HDR,1,3)
;
;Validate Message Header Type
; I "FHS,BHS,MSH"'[$E(HDR,1,3) S ERR="Invalid Message Header Segment" G EXIT
I "FHS,BHS,MSH"'[ARY("HDR-1") S ERR="Invalid Message Header" G EXIT
;
;Extract data from message header segment
; I $E(HDR,1,3)="BHS"!($E(HDR,1,3)="FHS") D
I ARY("HDR-1")="BHS"!(ARY("HDR-1")="FHS") D
. ;S ARY("DTM")=$P(HDR,FS,7),ARY("MID")=$P(HDR,FS,11),X=$P(HDR,FS,9),ARY("PID")=$P(X,$E(ECH),2),ARY("MTN")=$P($P(X,$E(ECH),3),$E(ECH,2)),ARY("ETN")=$P($P(X,$E(ECH),3),$E(ECH,2),2),ARY("VER")=$P(X,$E(ECH),4)
. S ARY("DTM")=$P(HDR,FS,7)
. S ARY("MID")=$P(HDR,FS,11)
. S ARY("PID")=""
. S ARY("MTN")=""
. S ARY("ETN")=""
. S ARY("VER")=""
. ;
. ; BHS-9, Batch name/ID/type:
. ; 2nd component: Processing id <sub> Processing mode
. ; 3rd component: message type <sub> event type
. ; 4th component: version
. S X=$P(HDR,FS,9)
. I X]"" D
.. S ARY("HDR-9")=X
.. ; original implementation incorrectly treats repetition separator as
.. ; subcomponent separator
.. S ECH("SUB-COMPONENT")=ECH(2)
.. ; if subcomponent separator is correctly applied
.. ; patch HL*1.6*133
.. ; I X[ECH(4) S ECH("SUB-COMPONENT")=ECH(4)
.. I ECH(4)]"",X[ECH(4) S ECH("SUB-COMPONENT")=ECH(4)
.. ;
.. S ARY("PID")=$P(X,ECH(1),2)
.. ; patch HL*1.6*133
.. ; I ARY("PID")[ECH("SUB-COMPONENT") D
.. I ECH("SUB-COMPONENT")]"",ARY("PID")[ECH("SUB-COMPONENT") D
... ; 2nd sub-component is Processing mode
... S ARY("PMOD")=$P(ARY("PID"),ECH("SUB-COMPONENT"),2)
... ; first sub-component is Processing id
... S ARY("PID")=$P(ARY("PID"),ECH("SUB-COMPONENT"))
.. ;
.. S ARY("MTN")=$P(X,ECH(1),3)
.. ; 2nd sub-component is event type
.. ;
.. ; patch HL*1.6*133 start
.. ; S ARY("ETN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"),2)
.. I ECH("SUB-COMPONENT")]"" D
... S ARY("ETN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"),2)
.. ; 1st sub-component is message type
.. ; S ARY("MTN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"))
.. I ECH("SUB-COMPONENT")]"" D
... S ARY("MTN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"))
.. ; patch HL*1.6*133 end
.. ;
.. S ARY("VER")=$P(X,ECH(1),4)
. ;
. ; BHS-10, batch comment
. ; S:$P(HDR,FS,10)]"" MSA=$P($P(HDR,FS,10),$E(ECH),1),$P(MSA,FS,2)=$P(HDR,FS,12),$P(MSA,FS,3)=$P($P(HDR,FS,10),$E(ECH),2)
. ; first component: MSA-1, acknowledgment code
. ; 2nd component: MSA-3, text message
. ;
. S X=$P(HDR,FS,10)
. I X]"" D
.. S ARY("HDR-10")=X
.. ; MSA-1, acknowledgment code: AA,AE,AR,CA,CE,CR
.. S MSA=$P(X,ECH(1),1)
.. ; MSA-2 and BHS-12, reference batch control id
.. S $P(MSA,FS,2)=$P(HDR,FS,12)
.. ; MSA-3, text message
.. S $P(MSA,FS,3)=$P(X,ECH(1),2)
. ; Reference Batch Control ID
. S:$P(HDR,FS,12)]"" ARY("HDR-12")=$P(HDR,FS,12)
;
; I $E(HDR,1,3)="MSH" D
I ARY("HDR-1")="MSH" D
. ;S ARY("DTM")=$P(HDR,FS,7),ARY("MID")=$P(HDR,FS,10),ARY("PID")=$P(HDR,FS,11),ARY("MTN")=$P($P(HDR,FS,9),$E(ECH)),ARY("ETN")=$P($P(HDR,FS,9),$E(ECH),2),ARY("VER")=$P(HDR,FS,12)
. S ARY("DTM")=$P(HDR,FS,7)
. S ARY("MID")=$P(HDR,FS,10)
. S ARY("PID")=$P(HDR,FS,11)
. S ARY("MTN")=$P($P(HDR,FS,9),ECH(1))
. S ARY("ETN")=$P($P(HDR,FS,9),ECH(1),2)
. S ARY("VER")=$P(HDR,FS,12)
. ;
. ; 2nd sub-component is Processing mode
. I ARY("PID")[ECH(1) D
.. S ARY("PMOD")=$P(ARY("PID"),ECH(1),2)
.. ; first sub-component is Processing id
.. S ARY("PID")=$P(ARY("PID"),ECH(1))
. ;
. ; S:$P($P(HDR,FS,9),$E(ECH),3)]"" ARY("MTN_ETN")=$P($P(HDR,FS,9),$E(ECH),3)
.I $P($P(HDR,FS,9),ECH(1),3)]"" D
.. S ARY("MTN_ETN")=$P($P(HDR,FS,9),ECH(1),3)
. ;
. ; fields 13 and 14
. S:$P(HDR,FS,13)]"" ARY("MSH-13")=$P(HDR,FS,13)
. S:$P(HDR,FS,14)]"" ARY("MSH-14")=$P(HDR,FS,14)
. ;
. ; S:$P(HDR,FS,15)]"" ARY("ACAT")=$P(HDR,FS,15) S:$P(HDR,FS,16)]"" ARY("APAT")=$P(HDR,FS,16) S:$P(HDR,FS,17)]"" ARY("CC")=$P(HDR,FS,17)
. S:$P(HDR,FS,15)]"" ARY("ACAT")=$P(HDR,FS,15)
. S:$P(HDR,FS,16)]"" ARY("APAT")=$P(HDR,FS,16)
. S:$P(HDR,FS,17)]"" ARY("CC")=$P(HDR,FS,17)
. ;
. ; fields 18,19,20 and 21
. S:$P(HDR,FS,18)]"" ARY("MSH-18")=$P(HDR,FS,18)
. S:$P(HDR,FS,19)]"" ARY("MSH-19")=$P(HDR,FS,19)
. S:$P(HDR,FS,20)]"" ARY("MSH-20")=$P(HDR,FS,20)
. S:$P(HDR,FS,21)]"" ARY("MSH-21")=$P(HDR,FS,21)
K:$G(MSA)']"" MSA
;
S ARY("RAF")=$P(HDR,FS,6) ; receiving facility
S ARY("SAF")=$P(HDR,FS,4) ; sending facility
;
;Invoke continuation routine to perform remaining validation checks
D ^HLTPCK1A
;
EXIT ;
; the maximum length of field #772,22 (Error Message) is 200
I ERR]"" D
. S ERR=$E(ERR,1,200)
. S ARY=$S('ERR:"13^"_ERR,1:ERR)
; patch HL*1.6*120 end
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTPCK1 6565 printed Oct 16, 2024@18:00:52 Page 2
HLTPCK1 ;AISC/SAW-Header Validation Routine (non-TCP link) ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**8,36,59,120,133**;Oct 13, 1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
CHK(HDR,ARY,MSA) ;Validate Data in Header Segment (MSH, BHS or FHS) of
+1 ;an HL7 Message through non-TCP link
+2 ;
+3 ;This entry point is a subroutine call with parameter passing that
+4 ;will return an array (ARY()) consisting of values extracted from
+5 ;the message header segment subscripted by the mnemonics for each of
+6 ;the message header fields and components
+7 ;If an error is encountered during validation, the array parameter
+8 ;(ARY) will be set equal to two pieces, error #^error text
+9 ;
+10 ;Required input parameters:
+11 ; HDR = Message header segment
+12 ;
+13 ; ARY = The array in which the message header values will be
+14 ; returned
+15 ; Note: The ARY parameter must be passed by reference
+16 ;
+17 ;Optional input parameter:
+18 ; MSA = A variable which contains the message acknowledgement values:
+19 ; acknowledgement code^message control ID^text message
+20 ;
+21 ;Check for required parameters
+22 NEW ERR
SET ERR=""
+23 IF $GET(HDR)']""
SET ERR="7^"_$GET(^HL(771.7,7,0))_" at CHK^HLTPCK1 entry point"
GOTO EXIT
+24 NEW ECH,HLN,FS,X,X1,X2
+25 SET ARY=""
SET ARY("Q")=""""""
+26 ;
+27 ;Validate field separator and encoding characters
+28 SET (ARY("FS"),FS)=$EXTRACT(HDR,4)
+29 IF FS']""
SET ERR="Field Separator Missing"
GOTO EXIT
+30 IF FS?.C
SET ERR="Invalid Field Separator"
GOTO EXIT
+31 SET (ARY("ECH"),ECH)=$PIECE(HDR,FS,2)
+32 IF ECH']""
SET ERR="Encoding Characters Missing"
GOTO EXIT
+33 IF ECH?.C
SET ERR="Invalid Encoding Characters"
GOTO EXIT
+34 ;
+35 ; patch HL*1.6*120 start
+36 ; patch HL*1.6*133
+37 ; escape and sub-component characters are optional
+38 ; I $L(ECH)'=4 S ERR="Invalid Encoding Characters" G EXIT
+39 IF $LENGTH(ECH)<1
SET ERR="Invalid Encoding Characters"
GOTO EXIT
+40 SET ECH(1)=$EXTRACT(ECH)
+41 SET ECH(2)=$EXTRACT(ECH,2)
+42 SET ECH(3)=$EXTRACT(ECH,3)
+43 SET ECH(4)=$EXTRACT(ECH,4)
+44 SET ARY("HDR")=HDR
+45 SET ARY("HDR-1")=$EXTRACT(HDR,1,3)
+46 ;
+47 ;Validate Message Header Type
+48 ; I "FHS,BHS,MSH"'[$E(HDR,1,3) S ERR="Invalid Message Header Segment" G EXIT
+49 IF "FHS,BHS,MSH"'[ARY("HDR-1")
SET ERR="Invalid Message Header"
GOTO EXIT
+50 ;
+51 ;Extract data from message header segment
+52 ; I $E(HDR,1,3)="BHS"!($E(HDR,1,3)="FHS") D
+53 IF ARY("HDR-1")="BHS"!(ARY("HDR-1")="FHS")
Begin DoDot:1
+54 ;S ARY("DTM")=$P(HDR,FS,7),ARY("MID")=$P(HDR,FS,11),X=$P(HDR,FS,9),ARY("PID")=$P(X,$E(ECH),2),ARY("MTN")=$P($P(X,$E(ECH),3),$E(ECH,2)),ARY("ETN")=$P($P(X,$E(ECH),3),$E(ECH,2),2),ARY("VER")=$P(X,$E(ECH),4)
+55 SET ARY("DTM")=$PIECE(HDR,FS,7)
+56 SET ARY("MID")=$PIECE(HDR,FS,11)
+57 SET ARY("PID")=""
+58 SET ARY("MTN")=""
+59 SET ARY("ETN")=""
+60 SET ARY("VER")=""
+61 ;
+62 ; BHS-9, Batch name/ID/type:
+63 ; 2nd component: Processing id <sub> Processing mode
+64 ; 3rd component: message type <sub> event type
+65 ; 4th component: version
+66 SET X=$PIECE(HDR,FS,9)
+67 IF X]""
Begin DoDot:2
+68 SET ARY("HDR-9")=X
+69 ; original implementation incorrectly treats repetition separator as
+70 ; subcomponent separator
+71 SET ECH("SUB-COMPONENT")=ECH(2)
+72 ; if subcomponent separator is correctly applied
+73 ; patch HL*1.6*133
+74 ; I X[ECH(4) S ECH("SUB-COMPONENT")=ECH(4)
+75 IF ECH(4)]""
IF X[ECH(4)
SET ECH("SUB-COMPONENT")=ECH(4)
+76 ;
+77 SET ARY("PID")=$PIECE(X,ECH(1),2)
+78 ; patch HL*1.6*133
+79 ; I ARY("PID")[ECH("SUB-COMPONENT") D
+80 IF ECH("SUB-COMPONENT")]""
IF ARY("PID")[ECH("SUB-COMPONENT")
Begin DoDot:3
+81 ; 2nd sub-component is Processing mode
+82 SET ARY("PMOD")=$PIECE(ARY("PID"),ECH("SUB-COMPONENT"),2)
+83 ; first sub-component is Processing id
+84 SET ARY("PID")=$PIECE(ARY("PID"),ECH("SUB-COMPONENT"))
End DoDot:3
+85 ;
+86 SET ARY("MTN")=$PIECE(X,ECH(1),3)
+87 ; 2nd sub-component is event type
+88 ;
+89 ; patch HL*1.6*133 start
+90 ; S ARY("ETN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"),2)
+91 IF ECH("SUB-COMPONENT")]""
Begin DoDot:3
+92 SET ARY("ETN")=$PIECE(ARY("MTN"),ECH("SUB-COMPONENT"),2)
End DoDot:3
+93 ; 1st sub-component is message type
+94 ; S ARY("MTN")=$P(ARY("MTN"),ECH("SUB-COMPONENT"))
+95 IF ECH("SUB-COMPONENT")]""
Begin DoDot:3
+96 SET ARY("MTN")=$PIECE(ARY("MTN"),ECH("SUB-COMPONENT"))
End DoDot:3
+97 ; patch HL*1.6*133 end
+98 ;
+99 SET ARY("VER")=$PIECE(X,ECH(1),4)
End DoDot:2
+100 ;
+101 ; BHS-10, batch comment
+102 ; S:$P(HDR,FS,10)]"" MSA=$P($P(HDR,FS,10),$E(ECH),1),$P(MSA,FS,2)=$P(HDR,FS,12),$P(MSA,FS,3)=$P($P(HDR,FS,10),$E(ECH),2)
+103 ; first component: MSA-1, acknowledgment code
+104 ; 2nd component: MSA-3, text message
+105 ;
+106 SET X=$PIECE(HDR,FS,10)
+107 IF X]""
Begin DoDot:2
+108 SET ARY("HDR-10")=X
+109 ; MSA-1, acknowledgment code: AA,AE,AR,CA,CE,CR
+110 SET MSA=$PIECE(X,ECH(1),1)
+111 ; MSA-2 and BHS-12, reference batch control id
+112 SET $PIECE(MSA,FS,2)=$PIECE(HDR,FS,12)
+113 ; MSA-3, text message
+114 SET $PIECE(MSA,FS,3)=$PIECE(X,ECH(1),2)
End DoDot:2
+115 ; Reference Batch Control ID
+116 if $PIECE(HDR,FS,12)]""
SET ARY("HDR-12")=$PIECE(HDR,FS,12)
End DoDot:1
+117 ;
+118 ; I $E(HDR,1,3)="MSH" D
+119 IF ARY("HDR-1")="MSH"
Begin DoDot:1
+120 ;S ARY("DTM")=$P(HDR,FS,7),ARY("MID")=$P(HDR,FS,10),ARY("PID")=$P(HDR,FS,11),ARY("MTN")=$P($P(HDR,FS,9),$E(ECH)),ARY("ETN")=$P($P(HDR,FS,9),$E(ECH),2),ARY("VER")=$P(HDR,FS,12)
+121 SET ARY("DTM")=$PIECE(HDR,FS,7)
+122 SET ARY("MID")=$PIECE(HDR,FS,10)
+123 SET ARY("PID")=$PIECE(HDR,FS,11)
+124 SET ARY("MTN")=$PIECE($PIECE(HDR,FS,9),ECH(1))
+125 SET ARY("ETN")=$PIECE($PIECE(HDR,FS,9),ECH(1),2)
+126 SET ARY("VER")=$PIECE(HDR,FS,12)
+127 ;
+128 ; 2nd sub-component is Processing mode
+129 IF ARY("PID")[ECH(1)
Begin DoDot:2
+130 SET ARY("PMOD")=$PIECE(ARY("PID"),ECH(1),2)
+131 ; first sub-component is Processing id
+132 SET ARY("PID")=$PIECE(ARY("PID"),ECH(1))
End DoDot:2
+133 ;
+134 ; S:$P($P(HDR,FS,9),$E(ECH),3)]"" ARY("MTN_ETN")=$P($P(HDR,FS,9),$E(ECH),3)
+135 IF $PIECE($PIECE(HDR,FS,9),ECH(1),3)]""
Begin DoDot:2
+136 SET ARY("MTN_ETN")=$PIECE($PIECE(HDR,FS,9),ECH(1),3)
End DoDot:2
+137 ;
+138 ; fields 13 and 14
+139 if $PIECE(HDR,FS,13)]""
SET ARY("MSH-13")=$PIECE(HDR,FS,13)
+140 if $PIECE(HDR,FS,14)]""
SET ARY("MSH-14")=$PIECE(HDR,FS,14)
+141 ;
+142 ; S:$P(HDR,FS,15)]"" ARY("ACAT")=$P(HDR,FS,15) S:$P(HDR,FS,16)]"" ARY("APAT")=$P(HDR,FS,16) S:$P(HDR,FS,17)]"" ARY("CC")=$P(HDR,FS,17)
+143 if $PIECE(HDR,FS,15)]""
SET ARY("ACAT")=$PIECE(HDR,FS,15)
+144 if $PIECE(HDR,FS,16)]""
SET ARY("APAT")=$PIECE(HDR,FS,16)
+145 if $PIECE(HDR,FS,17)]""
SET ARY("CC")=$PIECE(HDR,FS,17)
+146 ;
+147 ; fields 18,19,20 and 21
+148 if $PIECE(HDR,FS,18)]""
SET ARY("MSH-18")=$PIECE(HDR,FS,18)
+149 if $PIECE(HDR,FS,19)]""
SET ARY("MSH-19")=$PIECE(HDR,FS,19)
+150 if $PIECE(HDR,FS,20)]""
SET ARY("MSH-20")=$PIECE(HDR,FS,20)
+151 if $PIECE(HDR,FS,21)]""
SET ARY("MSH-21")=$PIECE(HDR,FS,21)
End DoDot:1
+152 if $GET(MSA)']""
KILL MSA
+153 ;
+154 ; receiving facility
SET ARY("RAF")=$PIECE(HDR,FS,6)
+155 ; sending facility
SET ARY("SAF")=$PIECE(HDR,FS,4)
+156 ;
+157 ;Invoke continuation routine to perform remaining validation checks
+158 DO ^HLTPCK1A
+159 ;
EXIT ;
+1 ; the maximum length of field #772,22 (Error Message) is 200
+2 IF ERR]""
Begin DoDot:1
+3 SET ERR=$EXTRACT(ERR,1,200)
+4 SET ARY=$SELECT('ERR:"13^"_ERR,1:ERR)
End DoDot:1
+5 ; patch HL*1.6*120 end
+6 QUIT
