source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

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