source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m@ 1438

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

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