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