Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.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/HLCSTCP4.m
r613 r623 1 HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/16/08 14:20 2 ;;1.6;HEALTH LEVEL SEVEN;**109,122,140**;Oct 13,1995;Build 5 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 Q 6 ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA 7 ; 8 RDERR ; Error during read process, decrement counter 9 D LLCNT^HLCSTCP(HLDP,4,1) 10 ERROR ; Error trap 11 ; OPEN ERROR-retry. 12 ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry 13 ; 14 ;**109** 15 ;I $G(HLMSG) L -^HLMA(HLMSG) 16 ; 17 ; patch HL*1.6*122 start 18 N STOP 19 S STOP=0 20 I $G(HLDP) S STOP=$$STOP^HLCSTCP 21 ; patch HL*1.6*140 22 S $ETRAP="D HALT^ZU" ;RWF 23 S HLTCP("$ZA\8192#2")="" 24 I (^%ZOSF("OS")["OpenM") D 25 . S HLTCP("$ZA")=$ZA 26 . ; For TCP devices $ZA\8192#2: the device is currently in the 27 . ; Connected state talking to a remote host. 28 . S HLTCP("$ZA\8192#2")=$ZA\8192#2 29 ; 30 S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV 31 ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q 32 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D G:STOP H2^XUSCLEAN Q 33 . D CC^HLCSTCP2("Op-err") 34 . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" 35 . I STOP D Q 36 .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')") 37 . I 'STOP D UNWIND^%ZTER 38 ; patch HL*1.6*140 start 39 ; I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q 40 I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q 41 . ; S:$G(HLPRIO)="I" HLERROR="108^Write Error" 42 . I $G(HLPRIO)="I" D Q 43 .. S HLERROR="108^Write Error" 44 .. D CC^HLCSTCP2("Wr-err") 45 .. D UNWIND^%ZTER 46 . ; 47 . I STOP D Q 48 .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Wr-err')") 49 . E D Q 50 .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Wr-err") Q 51 .. E D Q 52 ... D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')") 53 ... D UNWIND^%ZTER 54 ; 55 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q 56 ; I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q 57 I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q 58 . ; S:$G(HLPRIO)="I" HLERROR="108^Read Error" 59 . I $G(HLPRIO)="I" D Q 60 .. S HLERROR="108^Read Error" 61 .. D CC^HLCSTCP2("Rd-err") 62 .. D UNWIND^%ZTER 63 . ; 64 . I STOP D Q 65 .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Rd-err')") 66 . E D Q 67 .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Rd-err") Q 68 .. E D Q 69 ... D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')") 70 ... D UNWIND^%ZTER 71 ; 72 ; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP 73 ; S:$G(HLPRIO)="I" HLERROR="9^Error" 74 D ^%ZTER 75 I $G(HLPRIO)="I" D Q 76 . S HLERROR="9^Error" 77 . D CC^HLCSTCP2("Error") 78 . D UNWIND^%ZTER 79 ; 80 I STOP D Q 81 . D CC^HLCSTCP2("Shutdown: (with 'Error')") 82 . D H2^XUSCLEAN 83 ; 84 D CC^HLCSTCP2("Error") 85 ; patch HL*1.6*122 end 86 D H2^XUSCLEAN 87 ; patch HL*1.6*140 end 88 Q 89 ; 90 PROXY ; set DUZ for application proxy user 91 ; 92 ; removed the execution: patch 122 TEST v2 93 Q 94 ; 95 ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY") 96 ;; S DUZ=HLDUZ 97 ;; D DUZ^XUP(DUZ) 98 ;; Q 99 ; 100 HLDUZ ; compare DUZ and set DUZ to application proxy user 101 ; 102 ; removed the execution: patch 122 TEST v2 103 Q 104 ; 105 ;; I '$G(HLDUZ) D PROXY 106 ; 107 HLDUZ2 ; compare DUZ and HLDUZ 108 I $G(DUZ)'=HLDUZ D 109 . S DUZ=HLDUZ 110 . D DUZ^XUP(DUZ) 111 Q 112 ; 113 CLEANVAR ; clean variables for server, called from HLCSTCP1 114 ; 115 ; clean variables except Kernel related variables 116 ; protect variables defined in HLCSTCP 117 N HLDP 118 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS 119 N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE 120 ; 121 ; protect variables defined in LISTEN^HLCSTCP 122 ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT 123 ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL 124 N HLLSTN 125 ; 126 ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP 127 N % 128 ; protect variables defined in this routine HLCSTCP1 129 N $ETRAP,$ESTACK 130 N HLMIEN,HLASTMSG 131 N HLTMBUF 132 N HLDUZ,DUZ 133 ; Kernel variables for single listener 134 N ZISOS,ZRULE 135 ; 136 D KILL^XUSCLEAN 137 Q 138 MIEN ; sets HLIND1=ien in 773^ien in 772 for message 139 N HLMID,X 140 I HLIND1 D 141 . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0 142 . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0 143 ;msg. id is 10th of MSH & 11th for BSH or FSH 144 S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X) 145 ;if HLIND1 is set, kill old message, use HLIND1 for new 146 ;message, it means we never got end block for 1st msg. 147 I HLIND1 D Q 148 . ;get pointer to 772, kill header 149 . ; 150 . ; patch HL*1.6*122: MPI-client/server 151 . F L +^HLMA(+HLIND1):10 Q:$T H 1 152 . K ^HLMA(+HLIND1,"MSH") 153 . L -^HLMA(+HLIND1) 154 . ; 155 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") 156 . S X=$$MAID^HLTF(+HLIND1,HLMID) 157 . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") 158 . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" 159 D TCP^HLTF(.HLMID,.X,.HLDT) 160 S HLBUFF("IEN773")=X 161 I 'X D Q 162 . ;error - record and reset array 163 . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server 164 . D CLEAN^HLCSTCP1 K HLLSTN 165 . ;error 100=LLP could not en-queue the message, reset array 166 . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30 167 ;HLIND1=ien in 773^ien in 772 168 S HLIND1=X_U_+$G(^HLMA(X,0)) 169 S HLBUFF("HLIND1")=HLIND1 170 ;save MSH into 773 171 D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") 172 Q 173 ; 174 PMSH(MSH,P) ;get piece P from MSH array (passed by ref.) 175 N FS,I,L,L1,L2,X,Y 176 S FS=$E(MSH(1,0),4),(L2,Y)=0,X="" 177 F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0)) 178 . S:L1=1 L=L+1 179 . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y)) 180 . S L2=Y,Y=L 181 Q X 182 ; 183 ERROR1 ; 184 ; moved from ERROR^HLCSTCP1 185 ; Error trap for disconnect error and return back to the read loop. 186 ; patch HL*1.6*122 start 187 ; patch HL*1.6*140 188 ; S $ETRAP="D HALT^ZU" ;RWF 189 S $ETRAP="H 1 D HALT^ZU" ;RWF 190 I (^%ZOSF("OS")["OpenM") D 191 . S HLTCP("$ZA")=$ZA 192 . ; For TCP devices $ZA\8192#2: the device is currently in the 193 . ; Connected state talking to a remote host. 194 . S HLTCP("$ZA\8192#2")=$ZA\8192#2 195 . I HLTCP("$ZA\8192#2")=0 D 196 .. ; decrement counter of multi-listener 197 .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP 198 .. ; process terminated 199 .. D H2^XUSCLEAN 200 ; patch HL*1.6*140 201 ;S $ETRAP="D UNWIND^%ZTER" ;RWF 202 ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q 203 I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q 204 . ; if it is not a multi-listener 205 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err") 206 . D UNWIND^%ZTER 207 I $$EC^%ZOSV["READ" D Q 208 . ; if it is not a multi-listener 209 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err") 210 . D UNWIND^%ZTER 211 ; 212 ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q 213 I $$EC^%ZOSV["WRITE" D Q 214 . ; if it is not a multi-listener 215 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err") 216 . D UNWIND^%ZTER 217 ; 218 ; for GT.M 219 I $ECODE["UREAD" D Q 220 . ; if it is not a multi-listener 221 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err") 222 . D UNWIND^%ZTER 223 ; 224 ; S HLCSOUT=1 D ^%ZTER,CC("Error") 225 S HLCSOUT=1 226 D ^%ZTER 227 ; if it is not a multi-listener 228 I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error") 229 ; patch HL*1.6*122 end 230 ; 231 D UNWIND^%ZTER 232 Q 233 ; 234 CLRMCNTR ; 235 ; clear the counter to set as "0 server" for multi-listener 236 ; HL*1.6*122 start 237 Q:'$G(HLDP) 238 Q:'$D(^HLCS(870,"E","M",HLDP)) 239 S $P(^HLCS(870,HLDP,0),"^",4)="MS" 240 S $P(^HLCS(870,HLDP,0),U,5)="0 server" 241 Q 242 ; 243 CREATUSR ; 244 ; patch HL*1.6*122 TEST v2: DUZ code removed 245 ; create application proxy users for listeners and incoming filer 246 ;; N HLTEMP 247 ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#") 248 Q 1 HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006 13:31 2 ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 Q 6 ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA 7 ; 8 RDERR ; Error during read process, decrement counter 9 D LLCNT^HLCSTCP(HLDP,4,1) 10 ERROR ; Error trap 11 ; OPEN ERROR-retry. 12 ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry 13 ; 14 ;**109** 15 ;I $G(HLMSG) L -^HLMA(HLMSG) 16 ; 17 S $ETRAP="D UNWIND^%ZTER" 18 ; patch HL*1.6*122 19 S HLTCPERR("$P")=$P 20 S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV 21 ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q 22 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q 23 . D CC^HLCSTCP2("Op-err") 24 . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" 25 . D UNWIND^%ZTER 26 I $$EC^%ZOSV["WRITE" D Q ;HL*1.6*77 modifications start here 27 . D CC^HLCSTCP2("Wr-err") 28 . S:$G(HLPRIO)="I" HLERROR="108^Write Error" 29 . D UNWIND^%ZTER ;HL*1.6*77 modifications end here 30 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q 31 I $$EC^%ZOSV["READ" D Q 32 . D CC^HLCSTCP2("Rd-err") 33 . S:$G(HLPRIO)="I" HLERROR="108^Read Error" 34 . D UNWIND^%ZTER 35 S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP 36 S:$G(HLPRIO)="I" HLERROR="9^Error" 37 D UNWIND^%ZTER 38 Q 39 ; 40 PROXY ; set DUZ for application proxy user 41 S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY") 42 S DUZ=HLDUZ 43 D DUZ^XUP(DUZ) 44 Q 45 ; 46 HLDUZ ; compare DUZ and set DUZ to application proxy user 47 I '$G(HLDUZ) D PROXY 48 I $G(DUZ)'=HLDUZ D 49 . S DUZ=HLDUZ 50 . D DUZ^XUP(DUZ) 51 Q 52 ; 53 CLEANVAR ; clean variables for server, called from HLCSTCP1 54 ; 55 ; clean variables except Kernel related variables 56 ; protect variables defined in HLCSTCP 57 N HLDP 58 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS 59 N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE 60 ; 61 ; protect variables defined in LISTEN^HLCSTCP 62 ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT 63 ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL 64 N HLLSTN 65 ; 66 ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP 67 N % 68 ; protect variables defined in this routine HLCSTCP1 69 N $ETRAP,$ESTACK 70 N HLMIEN,HLASTMSG 71 N HLTMBUF 72 N HLDUZ,DUZ 73 ; Kernel variables for single listener 74 N ZISOS,ZRULE 75 ; 76 D KILL^XUSCLEAN 77 Q 78 MIEN ; sets HLIND1=ien in 773^ien in 772 for message 79 N HLMID,X 80 I HLIND1 D 81 . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0 82 . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0 83 ;msg. id is 10th of MSH & 11th for BSH or FSH 84 S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X) 85 ;if HLIND1 is set, kill old message, use HLIND1 for new 86 ;message, it means we never got end block for 1st msg. 87 I HLIND1 D Q 88 . ;get pointer to 772, kill header 89 . K ^HLMA(+HLIND1,"MSH") 90 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") 91 . S X=$$MAID^HLTF(+HLIND1,HLMID) 92 . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") 93 . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" 94 D TCP^HLTF(.HLMID,.X,.HLDT) 95 S HLBUFF("IEN773")=X 96 I 'X D Q 97 . ;error - record and reset array 98 . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server 99 . D CLEAN^HLCSTCP1 K HLLSTN 100 . ;error 100=LLP Could not Enqueue the Message, reset array 101 . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30 102 ;HLIND1=ien in 773^ien in 772 103 S HLIND1=X_U_+$G(^HLMA(X,0)) 104 S HLBUFF("HLIND1")=HLIND1 105 ;save MSH into 773 106 D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") 107 Q 108 ; 109 PMSH(MSH,P) ;get piece P from MSH array (passed by ref.) 110 N FS,I,L,L1,L2,X,Y 111 S FS=$E(MSH(1,0),4),(L2,Y)=0,X="" 112 F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0)) 113 . S:L1=1 L=L+1 114 . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y)) 115 . S L2=Y,Y=L 116 Q X 117 ;
Note:
See TracChangeset
for help on using the changeset viewer.
