source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2A.m@ 1724

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1HLTPCK2A ;SF/RSD - Message Header Validation (Con't) ;09/13/2006
2 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,66,108,120,133**;Oct 13, 1995;Build 13
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 S ERR=""
5 S HLPARAM=$$PARAM^HLCS2,HLDOM=$P(HLPARAM,U,2),HLINSTN=$P(HLPARAM,U,6)
6MT ;Validate message type
7 I (ARY("MTN")="") S:(ERR="") ERR="Invalid Message Type" Q
8 S ARY("MTP")=0
9 S:(ARY("MTN")'="") ARY("MTP")=+$O(^HL(771.2,"B",ARY("MTN"),0))
10 I ('ARY("MTP")) S:(ERR="") ERR="Invalid Message Type" Q
11 ;
12AT ;Determine if message is an acknowledgement type
13 I (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG,TBR"[ARY("MTN"))&($G(MSA)="")) S:(ERR="") ERR="MSA Segment Missing" Q
14 ;commit ack, quit
15 I $E($G(MSA))="C" D Q
16 . ;find original msg.
17 . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0
18 . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID " Q
19 . F S ARY("MTIENS")=+$O(^HLMA("C",ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O")
20 . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""C"" x-ref" Q
21 . Q
22AAT ;Validate accept ack type and application ack type
23 I ($G(ARY("ACAT"))'="") I ("AL,NE,ER,SU"'[ARY("ACAT")) S:(ERR="") ERR="Invalid accept ack type" Q
24 I ($G(ARY("APAT"))'="") I ("AL,NE,ER,SU"'[ARY("APAT")) S:(ERR="") ERR="Invalid application ack type" Q
25 ;
26 ;
27RA ;Validate receiving application
28 I (ARY("RAN")']"") S:(ERR="") ERR="Invalid Receiving Application" Q
29 S ARY("RAP")=0
30 S:ARY("RAN")]"" ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
31 I 'ARY("RAP"),ARY("RAN")'="" D
32 .S X=$$UPPER^HLFNC(ARY("RAN"))
33 .S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
34 ;
35 ; patch HL*1.6*120 start
36 I ($L(ARY("RAN"),ECH(1))>1) D
37 . S ARY("RAN-SUB1")=$P(ARY("RAN"),ECH(1))
38 . S ARY("RAN-SUB2")=$P(ARY("RAN"),ECH(1),2)
39 . S ARY("RAN-SUB3")=$P(ARY("RAN"),ECH(1),3)
40 . I 'ARY("RAP"),ARY("RAN-SUB1")]"" D
41 .. S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-SUB1"),1,30),0))
42 . I ARY("RAN-SUB1")[ECH(3) D
43 .. S ARY("RAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB1"))
44 . I ARY("RAN-SUB2")[ECH(3) D
45 .. S ARY("RAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB2"))
46 . I ARY("RAN-SUB3")[ECH(3) D
47 .. S ARY("RAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("RAN-SUB3"))
48 . I 'ARY("RAP"),$G(ARY("RAN-SUB1-DEESCAPE"))]"" D
49 .. S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-SUB1-DEESCAPE"),1,30),0))
50 I ARY("RAN")[ECH(3) D
51 . S ARY("RAN-DEESCAPE")=$$DEESCAPE(ARY("RAN"))
52 I 'ARY("RAP"),$G(ARY("RAN-DEESCAPE"))]"" D
53 . S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN-DEESCAPE"),1,30),0))
54 ; patch HL*1.6*120 end
55 ;
56 I ('ARY("RAP")) S:(ERR="") ERR="Invalid Receiving Application" Q
57 S X2=$G(^HL(771,ARY("RAP"),0))
58 I (X2="") S:(ERR="") ERR="Invalid Receiving Application" Q
59 I ($P(X2,"^",2)'="a") S:(ERR="") ERR="Receiving Application is Inactive" Q
60 ;
61SA ;Validate sending application
62 I (ARY("SAN")']"") S:(ERR="") ERR="Invalid Sending Application" Q
63 S ARY("SAP")=0
64 S:(ARY("SAN")]"") ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
65 I (('ARY("SAP"))&(ARY("SAN")'="")) D
66 .S X=$$UPPER^HLFNC(ARY("SAN"))
67 .S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
68 ;
69 ; patch HL*1.6*120 start
70 I ($L(ARY("SAN"),ECH(1))>1) D
71 . S ARY("SAN-SUB1")=$P(ARY("SAN"),ECH(1))
72 . S ARY("SAN-SUB2")=$P(ARY("SAN"),ECH(1),2)
73 . S ARY("SAN-SUB3")=$P(ARY("SAN"),ECH(1),3)
74 . I 'ARY("SAP"),ARY("SAN-SUB1")]"" D
75 .. S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-SUB1"),1,30),0))
76 . I ARY("SAN-SUB1")[ECH(3) D
77 .. S ARY("SAN-SUB1-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB1"))
78 . I ARY("SAN-SUB2")[ECH(3) D
79 .. S ARY("SAN-SUB2-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB2"))
80 . I ARY("SAN-SUB3")[ECH(3) D
81 .. S ARY("SAN-SUB3-DEESCAPE")=$$DEESCAPE(ARY("SAN-SUB3"))
82 . I 'ARY("SAP"),$G(ARY("SAN-SUB1-DEESCAPE"))]"" D
83 .. S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-SUB1-DEESCAPE"),1,30),0))
84 I ARY("SAN")[ECH(3) D
85 . S ARY("SAN-DEESCAPE")=$$DEESCAPE(ARY("SAN"))
86 I 'ARY("SAP"),$G(ARY("SAN-DEESCAPE"))]"" D
87 . S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN-DEESCAPE"),1,30),0))
88 ; patch HL*1.6*120 end
89 ;
90 I ('ARY("SAP")) S:(ERR="") ERR="Invalid Sending Application" Q
91 ;
92VN ;Validate version number
93 I (ARY("VER")="") S:(ERR="") ERR="Missing HL7 Version" Q
94 S X=0
95 S:(ARY("VER")'="") X=+$O(^HL(771.5,"B",ARY("VER"),0))
96 S ARY("VEP")=X
97 I ('X) S:(ERR="") ERR="Invalid HL7 Version" Q
98 ;I (X'=$P($G(HLN(770)),"^",10)) S:(ERR="") ERR="Invalid HL7 Version for Receiving Application" Q
99 ;
100ET ;Event Type Checks
101 ;
102 ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D
103 ;. ;N Z,ZEP,ZP
104 ;. ;S Z=0 I $P(MSA,FS,2)]"" S Z=+$O(^HLMA("C",$P(MSA,FS,2),0))
105 ;. ;I '$G(^HLMA(Z,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
106 ;. ;S ZEP=$P(^HLMA(Z,0),U,8)
107 ;. ;I 'ZEP S:(ERR="") ERR="Event Protocol pointer (field #773,8) missing" Q
108 ;. ;S ZP=$G(^ORD(101,ZEP,770)),ARY("ETN")=$P($G(^HL(779.001,+$P(ZP,U,4),0)),U)
109 ;
110 ;Validate event type
111 I (ARY("ETN")=""),ARY("VER")>2.1,$G(MSA)="" S ERR="Event Type Required" Q
112 S ARY("ETP")=0
113 S:(ARY("ETN")'="") ARY("ETP")=+$O(^HL(779.001,"B",ARY("ETN"),0))
114 I $G(MSA)="",ARY("VER")>2.1,('ARY("ETP")) S ERR="Invalid Event Type" Q
115 ;
116 D ^HLTPCK2B
117 Q
118DEESCAPE(INPUT) ;
119 ; patch HL*1.6*120 - de-escape delimiters
120 ; (assuming "\" is the escape character):
121 ; - field separator (de-escape from \F\)
122 ; - component separator (de-escape from \S\)
123 ; - repetition separator (de-escape from \R\)
124 ; - escape character (de-escape from \E\)
125 ; - subcomponent separator (de-escape from \T\)
126 ; \F\ will be de-escaped only if the length of FS is 1.
127 ;
128 ; input:
129 ; INPUT - input string to be de-escaped
130 ; FS - field separator
131 ; ECH - encoding characters
132 ;
133 ; output: de-escaped string
134 ;
135 N HLDATA,HLESCAPE,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
136 S HLDATA=$G(INPUT)
137 Q:HLDATA']"" HLDATA
138 ;
139 ; patch HL*1.6*133
140 Q:$L($G(ECH))<3 HLDATA
141 ;
142 S ECH(1)=$E(ECH,1)
143 S ECH(2)=$E(ECH,2)
144 S ECH(3)=$E(ECH,3)
145 S ECH(4)=$E(ECH,4)
146 ;
147 S HLEN=$L(HLDATA)
148 S HLOUT=""
149 F HLI=1:1:HLEN D
150 . S HLCHAR=$E(HLDATA,HLI)
151 . I HLCHAR=ECH(3) D
152 . S HLCHAR23=$E(HLDATA,HLI+1,HLI+2)
153 . I $L($G(FS))=1,(HLCHAR23=("F"_ECH(3))) D Q
154 .. S HLOUT=HLOUT_FS
155 .. S HLI=HLI+2
156 . I HLCHAR23=("S"_ECH(3)) D Q
157 .. S HLOUT=HLOUT_ECH(1)
158 .. S HLI=HLI+2
159 . I HLCHAR23=("R"_ECH(3)) D Q
160 .. S HLOUT=HLOUT_ECH(2)
161 .. S HLI=HLI+2
162 . I HLCHAR23=("E"_ECH(3)) D Q
163 .. S HLOUT=HLOUT_ECH(3)
164 .. S HLI=HLI+2
165 . I $L($G(ECH))>3,(HLCHAR23=("T"_ECH(3))) D Q
166 .. S HLOUT=HLOUT_ECH(4)
167 .. S HLI=HLI+2
168 . S HLOUT=HLOUT_HLCHAR
169 ;
170 Q HLOUT
Note: See TracBrowser for help on using the repository browser.