Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.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/HLTP3.m
r613 r623 1 HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;03/17/2008 11:26 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122,140**;Oct 13, 1995;Build 5 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 Q 6 NEW(X) ;process new msg. ien in 773^ien in 772 7 ;HLMTIENS=ien in #773; HLMTIEN=ien in #772 8 ;HLHDRO=original header; HLHDR=response header 9 ;set error trap 10 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" 11 N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT 12 S HLRESLT="" 13 D INIT^HLTP3A 14 ;error with header, return commit/app reject 15 I $G(HLRESLT) D Q 16 . ;set status & unlock record 17 . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT 18 . ;quit if no commit or app ack 19 . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q 20 . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR") 21 . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4 22 . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP) 23 . ;write ack back 24 . S X=$$WRITE^HLCSTCP2(HLTCP) 25 . ;update counter to sent 26 . D LLCNT^HLCSTCP(HLDP,4) 27 . ;update status of ack 28 . D STATUS^HLTF0(HLTCP,3,,,1) 29 ; 30 ;check for duplicate msg., use rec. app and msg. id x-ref 31 ; patch HL*1.6*120 32 I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) 33 . ;HLASTMSG=last ien received during this connection 34 . ;if no duplicate, save msg. ien and quit 35 . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q 36 . N MSH,OIENS 37 . S (OIENS,Y)=X D S Y=HLMTIENS D 38 .. ;combine MSH into single string 39 .. S MSH(Y)="",I=0 F S I=$O(^HLMA(Y,"MSH",I)) Q:'I S MSH(Y)=MSH(Y)_$G(^(I,0)) 40 .; patch 117 & 125, check if identical 41 .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q 42 .; 43 . ;msg is duplicate, set status 44 . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT 45 . ;msg was resent, ignore it. 46 . I HLASTMSG=HLMTIENS K HLMTIENS Q 47 . ;find original response and send back 48 . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS)) 49 ; 50 ;Quit if this is ack to ack 51 I $G(HL("ACK")) D Q 52 . ;Update status of original ack message 53 . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1) 54 . ;unlock record 55 . D EXIT 56 ; 57 ;enhance ack., send commit, quit if not an ack, msg will be processed by filer 58 I $G(HL("ACAT"))="AL" D Q:'$G(HL("MTIENS")) 59 . ;msg is a resend, HLASTRSP=ien of original response 60 .I $G(HLASTRSP) D 61 ..S HLTCP=HLASTRSP 62 ..D LLCNT^HLCSTCP(HLDP,3) 63 . E D Q:'$G(HLTCP) 64 ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4 65 . S X=$$WRITE^HLCSTCP2(HLTCP) 66 . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP) 67 . S HLTCP="" 68 . ;if not an ack, set status to awaiting processing **109** and put on in queue 69 . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 70 ; 71 ;enhance ack., no commit & no app ack 72 I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D Q 73 . ;set status to awaiting processing, **109** and put on in queue 74 . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 75 ; 76 ; patch HL*1.6*120 start 77 ;resending old response, msg is a resend 78 ; do not re-send duplicate when $G(HL("ACAT"))="AL" 79 I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK 80 ; quit if duplicate 81 Q:$G(HLASTRSP) 82 ; patch HL*1.6*120 end 83 ; 84 CONT ;continue processing an enhance ack msg. called from DEFACK 85 ;Set special HL variables for processing rtn 86 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" 87 ; 88 ; message is an acknowledgement, HLMSA=ack code^id^text 89 I ($G(HLMSA)]"") D Q 90 . ;X=1 if ack ok, 0=reject of error 91 . S X=$E(HLMSA,2)="A" 92 . ;Update status of original message and remove it from the queue 93 . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1) 94 . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS")) 95 . D 96 .. N HLTCP ;variable to update status in file #772. 97 ..; 98 ..;**108** 99 .. N TEMP 100 .. S TEMP=HLMTIENS 101 .. N HLMTIENS 102 .. S HLMTIENS=TEMP 103 ..;**END 108** 104 ..; 105 .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL) 106 . ;update status of incoming & unlock 107 . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT 108 ; 109 ;get entry action, exit action and processing routine 110 K HLHDR,HLLD0,HLLD1,HLMSA 111 I HL("EIDS")="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN** 112 D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN) 113 S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)),HLPROU=$G(HLN(771)) 114 ;quit if no processing routine,update status and quit 115 I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q 116 ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref 117 N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101," 118 ;Execute entry action of client protocol 119 X:HLENROU]"" HLENROU K HLENROU,HLDONE1 120 ; 121 ;Execute processing routine 122 X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR 123 ;update status of incoming to complete & unlock 124 D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT 125 ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK 126 ACK I $G(HLTCPO),$G(HLTCP) D Q 127 . D LLCNT^HLCSTCP(HLDP,3) 128 . ;write ack back over open tcp link 129 . S X=$$WRITE^HLCSTCP2(HLTCP) 130 . ;update status of ack to complete 131 . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1) 132 . D LLCNT^HLCSTCP(HLDP,4) 133 Q 134 ; 135 DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN 136 ;HLDP=logical link, X=ien in file 773 137 ; 138 ; patch HL*1.6*120 start 139 ; clean non-Kernel variables 140 D 141 . ; protect variables defined in STARTIN^HLCSIN 142 . N HLFLG,HLEXIT,HLPTRFLR 143 . ; protect variables defined in DEFACK^HLCSIN 144 . N HLXX,HLD0,HLPCT 145 . ; protect input parameters of this sub-routine 146 . N HLDP,X 147 . D KILL^XUSCLEAN 148 ; patch HL*1.6*120 end 149 ; 150 ;set error trap 151 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" 152 N HLERR ;patch HL*1.6*109 153 Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0)) 154 Q:'$D(^HLMA("AC","I",HLDP,X)) 155 ; 156 N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1 157 S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")="""""" 158 S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14) 159 S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15) 160 S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U) 161 S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U) 162 S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U) 163 S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10) 164 M HLHDRO=^HLMA(HLMTIENS,"MSH") 165 ; if no header quit 166 Q:'$O(HLHDRO(0)) 167 ; 168 S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7) 169 ; 170 ; quit if ien of #772 is not defined 171 Q:'HLMTIEN 172 ; quit if field separator is not defined 173 Q:HL("FS")="" 174 ; 175 S X=$$P^HLTPCK2(.HLHDRO,1) 176 ; 177 ; patch HL*1.6*120 start 178 I X="MSH" D 179 . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17) 180 . ; 181 . ; 2nd component is Processing mode 182 . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2) 183 . ; first component is Processing id 184 . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1)) 185 ; 186 I X'="MSH" D 187 . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4) 188 . ; 189 . ; original code incorrectly treats repetition separator as 190 . ; subcomponent separator 191 . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D 192 .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2) 193 . ; if subcomponent separator is correctly applied 194 . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D 195 .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4) 196 . ; 197 . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D 198 .. ; 2nd sub-component is Processing mode 199 .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2) 200 .. ; first sub-component is Processing id 201 .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT")) 202 . ; patch HL*1.6*120 end 203 . ; 204 . Q:$$P^HLTPCK2(.HLHDRO,10)="" 205 . ;HLMSA=ack code^id^text 206 . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2) 207 ; 208 ; quit if this is a commit ack 209 I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q 210 ; 211 ;** HL*1.6*117 ** 212 K HLL("SET FOR APP ACK"),HLL("LINKS") 213 ; 214 D CONT 215 Q 216 ; 217 MSA(Y) ;Y=ien in 772, returns MSA segment 218 ;ack code^msg being ack id^text 219 ; patch HL*1.6*122 220 ; for HL7 v2.5 and beyond with MSA as 3rd segment 221 N X,SUBIEN,DATA,DONE 222 S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") 223 Q:X]"" X 224 ; 225 S DONE=0 226 S SUBIEN=1 227 F S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN D Q:DONE 228 . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D 229 .. S DONE=1 230 .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN 231 .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") 232 ; patch HL*1.6*122 end 233 ; 234 Q X 235 ; 236 ERROR ;error trap 237 D ^%ZTER 238 I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT 239 ; release locks created by inbound filer 240 ; patch HL*1.6*140 241 ; L -^HLMA("AC","I",+$G(HLXX)) 242 L -^HLMA("IN-FILER","AC","I",+$G(HLXX)) 243 G UNWIND^%ZTER 244 ; 245 ; 246 EXIT ;unlock 247 I $G(HLMTIENS) L -^HLMA(HLMTIENS) 248 Q 249 ; 250 ONAC(IEN773) ; 251 ;Returns 1 if the message is on the "AC","I" xref 252 ;Returns 0 otherwise 253 ; 254 N LINK 255 S LINK=$P($G(^HLMA(IEN773,0)),"^",17) 256 Q:'LINK 0 257 Q $D(^HLMA("AC","I",LINK,IEN773)) 1 HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 Q 6 NEW(X) ;process new msg. ien in 773^msg. ien in 772 7 ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text 8 ;HLHDRO=original header; HLHDR=response header 9 ;set error trap 10 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" 11 N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT 12 S HLRESLT="" 13 D INIT^HLTP3A 14 ;error with header, return commit/app reject 15 I $G(HLRESLT) D Q 16 . ;set status & unlock record 17 . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT 18 . ;quit if no commit or app ack 19 . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q 20 . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR") 21 . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4 22 . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP) 23 . ;write ack back over connection 24 . S X=$$WRITE^HLCSTCP2(HLTCP) 25 . ;update counter to sent 26 . D LLCNT^HLCSTCP(HLDP,4) 27 . ;update status of ack to complete 28 . D STATUS^HLTF0(HLTCP,3,,,1) 29 ; 30 ;check for duplicate msg., use rec. app and msg. id x-ref 31 ; patch HL*1.6*120 32 ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) 33 I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) 34 . ;HLASTMSG=last ien received during this connection 35 . ;if no duplicate, save msg. ien and quit 36 . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q 37 . N MSH,OIENS 38 . S (OIENS,Y)=X D S Y=HLMTIENS D 39 .. ;combine MSH into single string 40 .. S MSH(Y)="",I=0 F S I=$O(^HLMA(Y,"MSH",I)) Q:'I S MSH(Y)=MSH(Y)_$G(^(I,0)) 41 .; patch 117 & 125, check if identical 42 .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q 43 .; 44 . ;msg is duplicate, set status as duplicate 45 . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT 46 . ;msg was resent during this connection, ignore it. 47 . I HLASTMSG=HLMTIENS K HLMTIENS Q 48 . ;find original response and send back 49 . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS)) 50 ; 51 ;Quit if this is acknowledgment to acknowledgement message 52 I $G(HL("ACK")) D Q 53 . ;Update status of original acknowledgment message to successfully 54 . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1) 55 . ;unlock record 56 . D EXIT 57 ; 58 ;enhance ack., send commit, quit if not an ack, msg will be processed by filer 59 I $G(HL("ACAT"))="AL" D Q:'$G(HL("MTIENS")) 60 . ;msg is a resend, HLASTRSP=ien of original response 61 .I $G(HLASTRSP) D 62 ..S HLTCP=HLASTRSP 63 ..D LLCNT^HLCSTCP(HLDP,3) 64 . E D Q:'$G(HLTCP) 65 ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4 66 . S X=$$WRITE^HLCSTCP2(HLTCP) 67 . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP) 68 . S HLTCP="" 69 . ;if not an ack, set status to awaiting processing **109** and put on in queue 70 . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 71 ; 72 ;enhance ack., no commit & no app ack 73 I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D Q 74 . ;set status to awaiting processing, **109** and put on in queue 75 . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 76 ; 77 ; patch HL*1.6*120 start 78 ;resending old response, msg is a resend 79 ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK 80 ; do not re-send duplicate message when $G(HL("ACAT"))="AL" 81 I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK 82 ; quit if duplicate 83 Q:$G(HLASTRSP) 84 ; patch HL*1.6*120 end 85 ; 86 CONT ;continue processing an enhance ack msg. called from DEFACK 87 ;Set special HL variables for processing rtn 88 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" 89 ; 90 ; message is an acknowledgement, HLMSA=ack code^id^text 91 I ($G(HLMSA)]"") D Q 92 . ;X=1 if ack ok, 0=reject of error 93 . S X=$E(HLMSA,2)="A" 94 . ;Update status of original subscriber message and remove it from the out-going queue 95 . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1) 96 . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS")) 97 . D 98 .. N HLTCP ;New variable to update status in file #772. 99 ..; 100 ..;**108** 101 .. N TEMP 102 .. S TEMP=HLMTIENS 103 .. N HLMTIENS 104 .. S HLMTIENS=TEMP 105 ..;**END 108** 106 ..; 107 .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL) 108 . ;update status of incoming to complete & unlock 109 . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT 110 ; 111 ;get entry action, exit action and processing routine 112 K HLHDR,HLLD0,HLLD1,HLMSA 113 I HL("EIDS")="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN** 114 D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN) 115 S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)),HLPROU=$G(HLN(771)) 116 ;quit if no processing routine,update status and quit 117 I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q 118 ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref 119 N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101," 120 ;Execute entry action of client protocol 121 X:HLENROU]"" HLENROU K HLENROU,HLDONE1 122 ; 123 ;Execute processing routine 124 X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR 125 ;update status of incoming to complete & unlock 126 D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT 127 ;HLTCPO=link open, HLTCP=ien of acknowledgment msg. from GENACK 128 ACK I $G(HLTCPO),$G(HLTCP) D Q 129 . D LLCNT^HLCSTCP(HLDP,3) 130 . ;write ack back over open tcp link 131 . S X=$$WRITE^HLCSTCP2(HLTCP) 132 . ;update status of ack to complete 133 . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1) 134 . D LLCNT^HLCSTCP(HLDP,4) 135 Q 136 ; 137 DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN 138 ;HLDP=logical link, X=ien in file 773 139 ; 140 ; patch HL*1.6*120 start 141 ; clean variables except Kernel related variables 142 D 143 . ; protect variables defined in STARTIN^HLCSIN 144 . N HLFLG,HLEXIT,HLPTRFLR 145 . ; protect variables defined in DEFACK^HLCSIN 146 . N HLXX,HLD0,HLPCT 147 . ; protect input parameters of this sub-routine 148 . N HLDP,X 149 . D KILL^XUSCLEAN 150 ; patch HL*1.6*120 end 151 ; 152 ;set error trap 153 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" 154 N HLERR ;patch HL*1.6*109 155 Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0)) 156 ;**109 START** 157 Q:'$D(^HLMA("AC","I",HLDP,X)) 158 ;**109 END** 159 ; 160 N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1 161 ;setup variables 162 S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")="""""" 163 S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14) 164 S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15) 165 S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U) 166 S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U) 167 S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U) 168 S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10) 169 M HLHDRO=^HLMA(HLMTIENS,"MSH") 170 ; if no header quit 171 ;**109** 172 ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q 173 Q:'$O(HLHDRO(0)) 174 ; 175 S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7) 176 ; 177 ; patch HL*1.6*109 start 178 ; quit if ien of #772 is not defined 179 Q:'HLMTIEN 180 ; quit if field separator is not defined 181 Q:HL("FS")="" 182 ; patch HL*1.6*109 end 183 ; 184 S X=$$P^HLTPCK2(.HLHDRO,1) 185 ; 186 ; patch HL*1.6*120 start 187 I X="MSH" D 188 . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17) 189 . ; 190 . ; 2nd component is Processing mode 191 . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2) 192 . ; first component is Processing id 193 . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1)) 194 ; 195 I X'="MSH" D 196 . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4) 197 . ; 198 . ; original implementation incorrectly treats repetition separator as 199 . ; subcomponent separator 200 . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D 201 .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2) 202 . ; if subcomponent separator is correctly applied 203 . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D 204 .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4) 205 . ; 206 . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D 207 .. ; 2nd sub-component is Processing mode 208 .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2) 209 .. ; first sub-component is Processing id 210 .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT")) 211 . ; patch HL*1.6*120 end 212 . ; 213 . Q:$$P^HLTPCK2(.HLHDRO,10)="" 214 . ;HLMSA=ack code^id^text 215 . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2) 216 ; 217 ; HL*1.6*108 218 ; quit if this is a commit ack 219 I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q 220 ; ** 221 ; 222 ;** HL*1.6*117 ** 223 K HLL("SET FOR APP ACK"),HLL("LINKS") 224 ;** END HL*1.6*117 ** 225 ; 226 D CONT 227 Q 228 ; 229 MSA(Y) ;Y=ien in 772, returns MSA segment 230 ;ack code^msg being ack id^text 231 N X 232 S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") 233 Q X 234 ; 235 ERROR ;error trap 236 D ^%ZTER 237 I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT 238 ;*109* release all locks created by inbound filer 239 L -^HLMA("AC","I",+$G(HLXX)) 240 G UNWIND^%ZTER 241 ; 242 ; 243 EXIT ;unlock 244 I $G(HLMTIENS) L -^HLMA(HLMTIENS) 245 Q 246 ; 247 ONAC(IEN773) ; 248 ;Returns 1 if the message is on the "AC","I" xref 249 ;Returns 0 otherwise 250 ; 251 N LINK 252 S LINK=$P($G(^HLMA(IEN773,0)),"^",17) 253 Q:'LINK 0 254 Q $D(^HLMA("AC","I",LINK,IEN773))
Note:
See TracChangeset
for help on using the changeset viewer.
