source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK1A.m@ 1281

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

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1HLTPCK1A ;SAW/AISC-Message Header Validation Routine for HL7 (Con't) ;03/24/2004 15:12
2 ;;1.6;HEALTH LEVEL SEVEN;**2,25,34,57,59,108**;Oct 13, 1995
3 S ERR=""
4SP ;Get local site parameters
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 ;
15AAT ;Validate accept ack type and application ack type
16 I ($G(ARY("ACAT"))'="") I ("AL,NE,ER,SU"'[ARY("ACAT")) S:(ERR="") ERR="Invalid accept ack type" Q
17 I ($G(ARY("APAT"))'="") I ("AL,NE,ER,SU"'[ARY("APAT")) S:(ERR="") ERR="Invalid application ack type" Q
18 ;
19RA ;Validate receiving application
20 S ARY("RAN")=$P(HDR,FS,5)
21 I (ARY("RAN")="") S:(ERR="") ERR="Invalid Receiving Application" Q
22 S ARY("RAP")=0
23 ;
24 ; patch HL*1.6*108 start
25 ;S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
26 S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
27 I (('ARY("RAP"))&(ARY("RAN")'="")) D
28 .S X=$$UPPER^HLFNC(ARY("RAN"))
29 .;S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0))
30 .S ARY("RAP")=+$O(^HL(771,"B",$E(ARY("RAN"),1,30),0))
31 ; patch HL*1.6*108 end
32 ;
33 I ('ARY("RAP")) S:(ERR="") ERR="Invalid Receiving Application" Q
34 S X2=$G(^HL(771,ARY("RAP"),0))
35 I (X2="") S:(ERR="") ERR="Invalid Receiving Application" Q
36 I ($P(X2,"^",2)'="a") S:(ERR="") ERR="Receiving Application is Inactive" Q
37 ;
38SA ;Validate sending application
39 S ARY("SAN")=$P(HDR,FS,3)
40 I (ARY("SAN")="") S:(ERR="") ERR="Invalid Sending Application" Q
41 S ARY("SAP")=0
42 ;
43 ; patch HL*1.6*108 start
44 ;S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
45 S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
46 I (('ARY("SAP"))&(ARY("SAN")'="")) D
47 .S X=$$UPPER^HLFNC(ARY("SAN"))
48 .;S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0))
49 .S ARY("SAP")=+$O(^HL(771,"B",$E(ARY("SAN"),1,30),0))
50 ; patch HL*1.6*108 end
51 ;
52 I ('ARY("SAP")) S:(ERR="") ERR="Invalid Sending Application" Q
53 ;
54VN ;Validate version number
55 I (ARY("VER")="") S:(ERR="") ERR="Missing HL7 Version" Q
56 S X=0
57 S:(ARY("VER")'="") X=+$O(^HL(771.5,"B",ARY("VER"),0))
58 S ARY("VEP")=X
59 I ('X) S:(ERR="") ERR="Invalid HL7 Version" Q
60 ;
61ET ; Check for Event Type if version 2.2 or above
62 ; if response use message id/original message to resolve event type
63 ;I ARY("ETN")="",ARY("VER")>2.1,$G(MSA)'="" D Q:ERR]""
64 ;. ;N HLZMID,HLZEP,HLZ770
65 ;. ;S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0))
66 ;. ;I HLZMID D
67 ;.. ;I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q
68 ;.. ;S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10)
69 ;.. ;I HLZEP'>0 S:(ERR="") ERR="Event Protocol pointer (field #772,10) missing" Q
70 ;.. ;S HLZ770=$G(^ORD(101,HLZEP,770))
71 ;.. ;S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4),0)),U)
72 ;. ;K HLZMID,HLZEP,HLZ770
73 ;
74 I (ARY("ETN")=""),ARY("VER")>2.1,$G(MSA)="" S:(ERR="") ERR="Event Type REQUIRED" Q
75 S ARY("ETP")=0
76 I $G(MSA)="",(ARY("ETN")'="") S ARY("ETP")=+$O(^HL(779.001,"B",ARY("ETN"),0)) I ('ARY("ETP")) S:(ERR="") ERR="Invalid Event Type" Q
77 ;
78MS ;Check for Message Structure Code
79 I $G(ARY("MTN_ETN"))'="" D
80 . S ARY("MTP_ETP")=0
81 . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0))
82 . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q
83 ;
84MSA ;Get receiving application data from Protocol file
85 ;I (ARY("SAP")) D Q:ERR]""
86 I $D(MSA) D Q
87 .;Message is an acknowledgement - deliver to Server Protocol that
88 .; message came from
89 .I '$G(ARY("SAP")) S ERR="Missing Sending Application" Q
90 .S ARY("MTIENS")=0
91 .F S ARY("MTIENS")=+$O(^HL(772,"AH",ARY("SAP"),$P(MSA,FS,2),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HL(772,+ARY("MTIENS"),0)),U,4)="O")
92 .S X=$G(^HL(772,+ARY("MTIENS"),0))
93 .S ARY("EIDS")=$P(X,"^",10)
94 .I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment" Q
95 .S ARY("MTIEN")=+$P(X,"^",8)
96 .S ARY("ACK")=$P(X,"^",7)
97 .S X=$G(^HL(772,+$P(X,"^",8),0))
98 .S ARY("EID")=$P(X,"^",10)
99 .I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
100 .D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
101 .;Get Logical Link info if defined on subscriber
102 .S ARY("LL")=$P($G(HLN(770)),"^",7)
103 ;
104 I ARY("MTP") D
105 .;Find Server Protocol - based on sending application, message type,
106 .;event type and version ID
107 .I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0))
108 .;
109 .;Find Server Protocol - based on sending application, message type,
110 .;and version ID
111 .I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0))
112 .;
113 .I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
114 .;Find Client Protocol - in ITEM multiple of Server Protocol
115 .S ARY("EIDS")=0
116 .F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:('ARY("EIDS")) D Q:$G(X1)
117 ..S (X,X1)=0
118 ..S X=$G(^ORD(101,ARY("EIDS"),770))
119 ..I $P(X,U,2)=ARY("RAP") S X1=1
120 .I 'ARY("EIDS") S:(ERR="") ERR="Invalid Receiving Application for this Event" Q
121 .D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
122 ;
123LLP ;Get logical link pointer
124 S ARY("LL")=$P($G(HLN(770)),"^",7)
125 ;
126FAC ;Get sending/rec facility, validate if necessary
127 ;
128 S HLCS=$E(ECH,1) ;Get component separator
129 S ARY("RAF")=$P(HDR,FS,6) ;Receiving Facility
130 S ARY("SAF")=$P(HDR,FS,4) ;Sending Facility
131 ;Get sending/receiving facility from Application Parameter file(771)
132 S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3)
133 S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3)
134 ;Sending/Receiving facility required?
135 S X=$G(^ORD(101,ARY("EIDS"),773))
136 S HLSFREQ=+X,HLRFREQ=+$P(X,U,2)
137RF ;Validate Receiving Facility
138 I HLRFREQ D
139 .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility" Q
140 .I HL771RF]"" D Q
141 ..;Facility data in 771 overrides data in site paramter file
142 ..;For backward compatibility, don't validate
143 ..Q
144 ..Q:HL771RF=ARY("RAF")
145 ..S:ERR="" ERR="Receiving Facility/App Parameter mismatch."
146 .;Check against local default value (site parameters)
147 .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS")
148 .S:ERR="" ERR="Receiving Facility mismatch."
149SF ;Validate Sending Facility
150 I HLSFREQ D
151 .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility" Q
152 .I HL771SF]"" D Q
153 ..;Check for facility data in 771
154 ..Q
155 ..Q:HL771SF=ARY("SAF")
156 ..S:ERR="" ERR="Sending Facility/App Parameter mismatch."
157 .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK
158 .;If so, use this instead of Protocol definition for return path
159 .S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$O(^DIC(4.2,"B",HLDOMP,0))
160 .I 'HLDOMP S:ERR="" ERR="Unrecognized domain in sending facility"
161 .Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app
162 .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0))
163 .I HLNK S ARY("LL")=HLNK
164 ;
165PID ;Validate processing ID
166 I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID" Q
167 S HLPID=$P(HLPARAM,U,3) ;site param
168 S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver
169 ;I X=""&($G(HLPID))="" S:ERR="" ERR="Cannot validate PROCESSING ID"
170 ;If message is 'debug' then event driver must be 'debug.'
171 ;If message is 'test' or 'production', then site param must match
172 I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver"
173 I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters"
174 ;
175SEC ;Validate security field - access code and electronic signature
176 I ($P($G(HLN(773)),"^",3)) D
177 .S X=$P($P(HDR,FS,8),$E(ECH))
178 .S X=$$UPPER^HLFNC(X)
179 .D ^XUSHSH
180 .I ((X="")&('$D(MSA))) S:(ERR="") ERR="Invalid access code" Q
181 .S ARY("DUZ")=0
182 .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0))
183 .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q
184 .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q
185 .S X=$P($P(HDR,FS,8),$E(ECH),3) I (X'="") D
186 ..S X1=$G(^VA(200,ARY("DUZ"),20))
187 ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q
188 ..S X=$$UPPER^HLFNC(X)
189 ..D HASH^XUSHSHP
190 ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q
191 ..S ARY("ESIG")=$P(X1,"^",2)
192 I $D(ARY) M HLREC=ARY
193 Q
Note: See TracBrowser for help on using the repository browser.