source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m@ 1470

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;10/04/2007 16:00
2 ;;1.6;HEALTH LEVEL SEVEN;**120,133,122**;Oct 13, 1995;Build 14
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; splitted from HLTPCK2A
6 ; to be called from HLTPCK2A
7 ;
8MS ;Check for Message Structure Code
9 I $G(ARY("MTN_ETN"))'="" D
10 . S ARY("MTP_ETP")=0
11 . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0))
12 . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q
13 ;
14 ;Get server and client Protocols
15MSA ;if ack, then get information and quit, we don't need to respond
16 I $G(MSA)]"" D Q
17 . ;Message is an acknowledgement, find original message
18 . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0
19 . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID" Q
20 . F S ARY("MTIENS")=+$O(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O")
21 . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref" Q
22 . ;get subscriber protocol and ack. to (show if this is an ack to an ack)
23 . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10)
24 . ;if no subscriber protocol then response msg. is invalid
25 . ;
26 . ; patch HL*1.6*122 start
27 . ; comment out the following code: for patch 109- dynamic addressing
28 . ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
29 . ;get message text ien in file 772 and server protocol, 'EID'
30 . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10)
31 . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
32 . ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
33 . I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
34 . ; patch HL*1.6*122 end
35 ;
36 ;Find Server Protocol - based on sending application, message type,
37 ;event type and version ID
38 I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
39 ;
40 ;Find Server Protocol - based on sending application, message type,
41 ;and version ID
42 I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
43 ;
44 I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
45 ;Find Client Protocol - in ITEM multiple of Server Protocol
46 S ARY("EIDS")=0
47 F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:'ARY("EIDS")!($P($G(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP"))
48 I 'ARY("EIDS") S ERR="Invalid Receiving Application for this Event" Q
49 D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
50 ;
51LLP ;Get logical link pointer
52 S ARY("LL")=$P($G(HLN(770)),"^",7)
53 ;
54FAC ;Get sending/rec facility, validate if necessary
55 ;
56 S HLCS=$E(ECH,1) ;Get component separator
57 S ARY("RAF")=$$P^HLTPCK2(.HDR,6) ;Receiving Facility
58 S ARY("SAF")=$$P^HLTPCK2(.HDR,4) ;Sending Facility
59 ;Get sending/receiving facility from Application Parameter file(771)
60 S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3)
61 S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3)
62 ;Sending/Receiving facility required?
63 S X=$G(^ORD(101,ARY("EIDS"),773))
64 S HLSFREQ=+X,HLRFREQ=+$P(X,U,2)
65RF ;Validate Receiving Facility
66 I HLRFREQ D
67 .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility"
68 .I HL771RF]"" D Q
69 ..;Facility data in 771 overrides data in site paramter file
70 ..Q
71 .;Check against local default value (site parameters)
72 .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
73 .;
74 .; patch HL*1.6*120 start
75 .; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D Q
76 . I $P(ARY("RAF"),HLCS,3)="DNS" D Q
77 .. N ERROR,HLDOMP1,HLDOMP2
78 .. ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
79 .. S HLDOMP1=$P(ARY("RAF"),HLCS,2)
80 .. ;
81 .. ; assume the format is <domain>:<port #>
82 .. I HLDOMP1[":" S ARY("RAF-PORT")=$P(HLDOMP1,":",2)
83 .. S HLDOMP1=$P(HLDOMP1,":")
84 .. S ARY("RAF-DOMAIN")=HLDOMP1
85 .. ;
86 .. ; if first piece of domain is "HL7." or "MPI.", remove it
87 .. I ($E(HLDOMP1,1,4)="HL7.")!($E(HLDOMP1,1,4)="MPI.") D
88 ... S HLDOMP1=$P(HLDOMP1,".",2,99)
89 .. S HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR")
90 .. S HLDOMP2=HLDOM,HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR")
91 .. I HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2) Q
92 .. ;
93 .. ; check DNS domain and ip address
94 .. ;initialize variable, HLDOMP("FLAG")
95 .. S HLDOMP("FLAG")=0
96 .. I ARY("RAF-DOMAIN")]"" D
97 ... ;
98 ... ; match DNS domain
99 ... I $D(^HLCS(870,"DNS",ARY("RAF-DOMAIN"))) D Q
100 .... S HLDOMP("FLAG")=1
101 .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0))
102 ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")))) D Q
103 .... S HLDOMP("FLAG")=1
104 .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0))
105 ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")))) D Q
106 .... S HLDOMP("FLAG")=1
107 .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0))
108 ... ;
109 ... ; match ip address
110 ... I $D(^HLCS(870,"IP",ARY("RAF-DOMAIN"))) D Q
111 .... S HLDOMP("FLAG")=1
112 .... S ARY("RAF-LL")=+$O(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0))
113 .. Q:HLDOMP("FLAG")=1
114 .. I $P(ARY("RAF"),HLCS)=HLINSTN Q
115 .. ;
116 .. S:ERR="" ERR="Receiving Facility mismatch."
117 . I $P(ARY("RAF"),HLCS)=HLINSTN Q
118 . S:ERR="" ERR="Receiving Facility mismatch."
119 ; patch HL*1.6*120 end
120 ;
121SF ;Validate Sending Facility
122 I HLSFREQ D
123 .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility"
124 .I HL771SF]"" D Q
125 ..;Check for facility data in 771
126 ..Q
127 .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
128 .;If so, use this instead of Protocol definition for return path
129 .;
130 .; patch HL*1.6*120 start
131 . N HLDOMP
132 . ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
133 . S HLDOMP=$P(ARY("SAF"),HLCS,2)
134 . ;
135 . ; assume the format is <domain>:<port #>
136 . I HLDOMP[":" S ARY("SAF-PORT")=$P(HLDOMP,":",2)
137 . S HLDOMP=$P(HLDOMP,":")
138 . S ARY("SAF-DOMAIN")=HLDOMP
139 . ;
140 . ; if first piece of domain is "HL7." or "MPI.", remove it
141 . I ($E(HLDOMP,1,4)="HL7.")!($E(HLDOMP,1,4)="MPI.") D
142 .. S HLDOMP=$P(HLDOMP,".",2,99)
143 . S HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR")
144 .;Note: This expects a unique domain in domain file. Multiple entries will fail
145 . ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility"
146 . ;
147 . ; check DNS domain and ip address
148 . I 'HLDOMP D
149 .. ;
150 .. ;initialize variable, HLDOMP("FLAG")
151 .. S HLDOMP("FLAG")=0
152 .. I ARY("SAF-DOMAIN")]"" D
153 ... ;
154 ... ; match DNS domain
155 ... I $D(^HLCS(870,"DNS",ARY("SAF-DOMAIN"))) D Q
156 .... S HLDOMP("FLAG")=1
157 .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0))
158 ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")))) D Q
159 .... S HLDOMP("FLAG")=1
160 .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0))
161 ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")))) D Q
162 .... S HLDOMP("FLAG")=1
163 .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0))
164 ... ;
165 ... ; match ip address
166 ... I $D(^HLCS(870,"IP",ARY("SAF-DOMAIN"))) D Q
167 .... S HLDOMP("FLAG")=1
168 .... S ARY("SAF-LL")=+$O(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0))
169 .. Q:HLDOMP("FLAG")=1
170 .. ; quit if 1st component defined
171 .. S ARY("SAF-COMPONENT1")=$P(ARY("SAF"),HLCS,1)
172 .. Q:ARY("SAF-COMPONENT1")]""
173 .. S:ERR="" ERR="Receiving Facility mismatch."
174 . ; patch HL*1.6*120 end
175 . ;
176 .Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app
177 .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
178 .I $G(HLNK) S ARY("LL")=HLNK
179 ;
180PID ;Validate processing ID
181 I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID"
182 S HLPID=$P(HLPARAM,U,3) ;site param
183 S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
184 ;If message is 'debug' then event driver must be 'debug.'
185 ;If message is 'test' or 'production', then site param must match
186 I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver"
187 I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters"
188 ;
189SEC ;Validate security field - access code and electronic signature
190 I ($P($G(HLN(773)),"^",3)) D
191 .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH))
192 .S X=$$UPPER^HLFNC(X)
193 .D ^XUSHSH
194 .I X="",(MSA="") S:(ERR="") ERR="Invalid access code" Q
195 .S ARY("DUZ")=0
196 .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0))
197 .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q
198 .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q
199 .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH),3) I (X'="") D
200 ..S X1=$G(^VA(200,ARY("DUZ"),20))
201 ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q
202 ..S X=$$UPPER^HLFNC(X)
203 ..D HASH^XUSHSHP
204 ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q
205 ..S ARY("ESIG")=$P(X1,"^",2)
206 I $D(ARY) M HLREC=ARY
207 Q
Note: See TracBrowser for help on using the repository browser.