Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m
r613 r623 1 HLTPCK2B ;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 ; 8 MS ;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 15 MSA ;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 ; 51 LLP ;Get logical link pointer 52 S ARY("LL")=$P($G(HLN(770)),"^",7) 53 ; 54 FAC ;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) 65 RF ;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 ; 121 SF ;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 ; 180 PID ;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 ; 189 SEC ;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 1 HLTPCK2B ;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 ; 8 MS ;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 15 MSA ;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 ; 46 LLP ;Get logical link pointer 47 S ARY("LL")=$P($G(HLN(770)),"^",7) 48 ; 49 FAC ;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) 60 RF ;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 ; 116 SF ;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 ; 175 PID ;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 ; 184 SEC ;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 TracChangeset
for help on using the changeset viewer.
