HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/03/2011 13:29
;;1.6;HEALTH LEVEL SEVEN;**109,122,140,157,174**;Oct 13,1995;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
; SAC EXEMPTION 20200824-01 : Allows the use of the $ZA special variable
; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
;
RDERR ; Error during read process, decrement counter
D LLCNT^HLCSTCP(HLDP,4,1)
ERROR ; Error trap
; OPEN ERROR-retry.
; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
;
;**109**
;I $G(HLMSG) L -^HLMA(HLMSG)
;
; patch HL*1.6*122 start
N STOP
S STOP=0
I $G(HLDP) S STOP=$$STOP^HLCSTCP
; patch HL*1.6*140
S $ETRAP="D HALT^ZU" ;RWF
S HLTCP("$ZA\8192#2")=""
;
; patch HL*1.6*157 start
N HLOSYS
S HLOSYS=$$OS^%ZOSV
; I (^%ZOSF("OS")["OpenM") D
I (HLOSYS["UNIX")!(HLOSYS["VMS") D
. ; patch HL*1.6*157 end
. S HLTCP("$ZA")=$ZA
. ; For TCP devices $ZA\8192#2: the device is currently in the
. ; Connected state talking to a remote host.
. S HLTCP("$ZA\8192#2")=$ZA\8192#2
;
S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
; 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
I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D G:STOP H2^XUSCLEAN Q
. D CC^HLCSTCP2("Op-err")
. S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
. I STOP D Q
.. D CC^HLCSTCP2("Shutdown: (with 'Op-err')")
. I 'STOP D UNWIND^%ZTER
; patch HL*1.6*140 start
; I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
. ; S:$G(HLPRIO)="I" HLERROR="108^Write Error"
. I $G(HLPRIO)="I" D Q
.. S HLERROR="108^Write Error"
.. D CC^HLCSTCP2("Wr-err")
.. D UNWIND^%ZTER
. ;
. I STOP D Q
.. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
. E D Q
.. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Wr-err") Q
.. E D Q
... D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
... D UNWIND^%ZTER
;
; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
; I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
. ; S:$G(HLPRIO)="I" HLERROR="108^Read Error"
. I $G(HLPRIO)="I" D Q
.. S HLERROR="108^Read Error"
.. D CC^HLCSTCP2("Rd-err")
.. D UNWIND^%ZTER
. ;
. I STOP D Q
.. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
. E D Q
.. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Rd-err") Q
.. E D Q
... D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
... D UNWIND^%ZTER
;
; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
; S:$G(HLPRIO)="I" HLERROR="9^Error"
D ^%ZTER
I $G(HLPRIO)="I" D Q
. S HLERROR="9^Error"
. D CC^HLCSTCP2("Error")
. D UNWIND^%ZTER
;
I STOP D Q
. D CC^HLCSTCP2("Shutdown: (with 'Error')")
. D H2^XUSCLEAN
;
D CC^HLCSTCP2("Error")
; patch HL*1.6*122 end
D H2^XUSCLEAN
; patch HL*1.6*140 end
Q
;
PROXY ; set DUZ for application proxy user
;
; removed the execution: patch 122 TEST v2
Q
;
;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
;; S DUZ=HLDUZ
;; D DUZ^XUP(DUZ)
;; Q
;
HLDUZ ; compare DUZ and set DUZ to application proxy user
;
; removed the execution: patch 122 TEST v2
Q
;
;; I '$G(HLDUZ) D PROXY
;
HLDUZ2 ; compare DUZ and HLDUZ
I $G(DUZ)'=HLDUZ D
.S DUZ=HLDUZ
D DUZ^XUP(DUZ) ; HL*1.6*174 moves the call to DUZ^XUP out of the dot structure to ensure the DUZ() array is set up properly.
Q
;
CLEANVAR ; clean variables for server, called from HLCSTCP1
;
; clean variables except Kernel related variables
; protect variables defined in HLCSTCP
N HLDP
N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
;
; protect variables defined in LISTEN^HLCSTCP
; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
N HLLSTN
;
; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
N %
; protect variables defined in this routine HLCSTCP1
N $ETRAP,$ESTACK
N HLMIEN,HLASTMSG
N HLTMBUF
N HLDUZ,DUZ
; Kernel variables for single listener
N ZISOS,ZRULE
;
D KILL^XUSCLEAN
Q
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
N HLMID,X
I HLIND1 D
. S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
. S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
;msg. id is 10th of MSH & 11th for BSH or FSH
S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
;if HLIND1 is set, kill old message, use HLIND1 for new
;message, it means we never got end block for 1st msg.
I HLIND1 D Q
. ;get pointer to 772, kill header
. ;
. ; patch HL*1.6*122: MPI-client/server
. F L +^HLMA(+HLIND1):10 Q:$T H 1
. K ^HLMA(+HLIND1,"MSH")
. L -^HLMA(+HLIND1)
. ;
. I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
. S X=$$MAID^HLTF(+HLIND1,HLMID)
. D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
. S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
D TCP^HLTF(.HLMID,.X,.HLDT)
S HLBUFF("IEN773")=X
I 'X D Q
. ;error - record and reset array
. ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
. D CLEAN^HLCSTCP1 K HLLSTN
. ;error 100=LLP could not en-queue the message, reset array
. D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
;HLIND1=ien in 773^ien in 772
S HLIND1=X_U_+$G(^HLMA(X,0))
S HLBUFF("HLIND1")=HLIND1
;save MSH into 773
D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
Q
;
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
N FS,I,L,L1,L2,X,Y
S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
. S:L1=1 L=L+1
. S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
. S L2=Y,Y=L
Q X
;
ERROR1 ;
; moved from ERROR^HLCSTCP1
; Error trap for disconnect error and return back to the read loop.
; patch HL*1.6*122 start
; patch HL*1.6*140
; S $ETRAP="D HALT^ZU" ;RWF
S $ETRAP="H 1 D HALT^ZU" ;RWF
; patch HL*1.6*157 start
N HLOSYS
S HLOSYS=$$OS^%ZOSV
; I (^%ZOSF("OS")["OpenM") D
I (HLOSYS["UNIX")!(HLOSYS["VMS") D
. ; patch HL*1.6*157 end
. S HLTCP("$ZA")=$ZA
. ; For TCP devices $ZA\8192#2: the device is currently in the
. ; Connected state talking to a remote host.
. S HLTCP("$ZA\8192#2")=$ZA\8192#2
. ; patch HL*1.6*157 to include <DSCON>: disconnected by client
. ; I HLTCP("$ZA\8192#2")=0 D
. I (HLTCP("$ZA\8192#2")=0)!($$EC^%ZOSV["DSCON") D
.. ; decrement counter of multi-listener
.. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP
.. ; process terminated
.. D H2^XUSCLEAN
; patch HL*1.6*140
;S $ETRAP="D UNWIND^%ZTER" ;RWF
; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q
. ; if it is not a multi-listener
. I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")
. D UNWIND^%ZTER
I $$EC^%ZOSV["READ" D Q
. ; if it is not a multi-listener
. I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
. D UNWIND^%ZTER
;
; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
I $$EC^%ZOSV["WRITE" D Q
. ; if it is not a multi-listener
. I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")
. D UNWIND^%ZTER
;
; for GT.M
I $ECODE["UREAD" D Q
. ; if it is not a multi-listener
. I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
. D UNWIND^%ZTER
;
; S HLCSOUT=1 D ^%ZTER,CC("Error")
S HLCSOUT=1
D ^%ZTER
; if it is not a multi-listener
I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")
; patch HL*1.6*122 end
;
D UNWIND^%ZTER
Q
;
CLRMCNTR ;
; clear the counter to set as "0 server" for multi-listener
; HL*1.6*122 start
Q:'$G(HLDP)
Q:'$D(^HLCS(870,"E","M",HLDP))
S $P(^HLCS(870,HLDP,0),"^",4)="MS"
S $P(^HLCS(870,HLDP,0),U,5)="0 server"
Q
;
CREATUSR ;
; patch HL*1.6*122 TEST v2: DUZ code removed
; create application proxy users for listeners and incoming filer
;; N HLTEMP
;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSTCP4 8367 printed Dec 13, 2024@01:57:09 Page 2
HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;08/03/2011 13:29
+1 ;;1.6;HEALTH LEVEL SEVEN;**109,122,140,157,174**;Oct 13,1995;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; SAC EXEMPTION 20200824-01 : Allows the use of the $ZA special variable
+6 ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
+7 ;
RDERR ; Error during read process, decrement counter
+1 DO LLCNT^HLCSTCP(HLDP,4,1)
ERROR ; Error trap
+1 ; OPEN ERROR-retry.
+2 ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
+3 ;
+4 ;**109**
+5 ;I $G(HLMSG) L -^HLMA(HLMSG)
+6 ;
+7 ; patch HL*1.6*122 start
+8 NEW STOP
+9 SET STOP=0
+10 IF $GET(HLDP)
SET STOP=$$STOP^HLCSTCP
+11 ; patch HL*1.6*140
+12 ;RWF
SET $ETRAP="D HALT^ZU"
+13 SET HLTCP("$ZA\8192#2")=""
+14 ;
+15 ; patch HL*1.6*157 start
+16 NEW HLOSYS
+17 SET HLOSYS=$$OS^%ZOSV
+18 ; I (^%ZOSF("OS")["OpenM") D
+19 IF (HLOSYS["UNIX")!(HLOSYS["VMS")
Begin DoDot:1
+20 ; patch HL*1.6*157 end
+21 SET HLTCP("$ZA")=$ZA
+22 ; For TCP devices $ZA\8192#2: the device is currently in the
+23 ; Connected state talking to a remote host.
+24 SET HLTCP("$ZA\8192#2")=$ZA\8192#2
End DoDot:1
+25 ;
+26 SET HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
+27 ; 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
+28 IF $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN")
Begin DoDot:1
+29 DO CC^HLCSTCP2("Op-err")
+30 if $GET(HLPRIO)="I"
SET HLERROR="15^Open Related Error"
+31 IF STOP
Begin DoDot:2
+32 DO CC^HLCSTCP2("Shutdown: (with 'Op-err')")
End DoDot:2
QUIT
+33 IF 'STOP
DO UNWIND^%ZTER
End DoDot:1
if STOP
GOTO H2^XUSCLEAN
QUIT
+34 ; patch HL*1.6*140 start
+35 ; I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
+36 IF $$EC^%ZOSV["WRITE"
Begin DoDot:1
+37 ; S:$G(HLPRIO)="I" HLERROR="108^Write Error"
+38 IF $GET(HLPRIO)="I"
Begin DoDot:2
+39 SET HLERROR="108^Write Error"
+40 DO CC^HLCSTCP2("Wr-err")
+41 DO UNWIND^%ZTER
End DoDot:2
QUIT
+42 ;
+43 IF STOP
Begin DoDot:2
+44 DO ^%ZTER
DO CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
End DoDot:2
QUIT
+45 IF '$TEST
Begin DoDot:2
+46 IF HLTCP("$ZA\8192#2")
DO ^%ZTER
DO CC^HLCSTCP2("Wr-err")
QUIT
+47 IF '$TEST
Begin DoDot:3
+48 DO CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
+49 DO UNWIND^%ZTER
End DoDot:3
QUIT
End DoDot:2
QUIT
End DoDot:1
if STOP!(HLTCP("$ZA\8192#2"))
GOTO H2^XUSCLEAN
QUIT
+50 ;
+51 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
+52 ; I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
+53 IF $$EC^%ZOSV["READ"
Begin DoDot:1
+54 ; S:$G(HLPRIO)="I" HLERROR="108^Read Error"
+55 IF $GET(HLPRIO)="I"
Begin DoDot:2
+56 SET HLERROR="108^Read Error"
+57 DO CC^HLCSTCP2("Rd-err")
+58 DO UNWIND^%ZTER
End DoDot:2
QUIT
+59 ;
+60 IF STOP
Begin DoDot:2
+61 DO ^%ZTER
DO CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
End DoDot:2
QUIT
+62 IF '$TEST
Begin DoDot:2
+63 IF HLTCP("$ZA\8192#2")
DO ^%ZTER
DO CC^HLCSTCP2("Rd-err")
QUIT
+64 IF '$TEST
Begin DoDot:3
+65 DO CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
+66 DO UNWIND^%ZTER
End DoDot:3
QUIT
End DoDot:2
QUIT
End DoDot:1
if STOP!(HLTCP("$ZA\8192#2"))
GOTO H2^XUSCLEAN
QUIT
+67 ;
+68 ; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
+69 ; S:$G(HLPRIO)="I" HLERROR="9^Error"
+70 DO ^%ZTER
+71 IF $GET(HLPRIO)="I"
Begin DoDot:1
+72 SET HLERROR="9^Error"
+73 DO CC^HLCSTCP2("Error")
+74 DO UNWIND^%ZTER
End DoDot:1
QUIT
+75 ;
+76 IF STOP
Begin DoDot:1
+77 DO CC^HLCSTCP2("Shutdown: (with 'Error')")
+78 DO H2^XUSCLEAN
End DoDot:1
QUIT
+79 ;
+80 DO CC^HLCSTCP2("Error")
+81 ; patch HL*1.6*122 end
+82 DO H2^XUSCLEAN
+83 ; patch HL*1.6*140 end
+84 QUIT
+85 ;
PROXY ; set DUZ for application proxy user
+1 ;
+2 ; removed the execution: patch 122 TEST v2
+3 QUIT
+4 ;
+5 ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
+6 ;; S DUZ=HLDUZ
+7 ;; D DUZ^XUP(DUZ)
+8 ;; Q
+9 ;
HLDUZ ; compare DUZ and set DUZ to application proxy user
+1 ;
+2 ; removed the execution: patch 122 TEST v2
+3 QUIT
+4 ;
+5 ;; I '$G(HLDUZ) D PROXY
+6 ;
HLDUZ2 ; compare DUZ and HLDUZ
+1 IF $GET(DUZ)'=HLDUZ
Begin DoDot:1
+2 SET DUZ=HLDUZ
End DoDot:1
+3 ; HL*1.6*174 moves the call to DUZ^XUP out of the dot structure to ensure the DUZ() array is set up properly.
DO DUZ^XUP(DUZ)
+4 QUIT
+5 ;
CLEANVAR ; clean variables for server, called from HLCSTCP1
+1 ;
+2 ; clean variables except Kernel related variables
+3 ; protect variables defined in HLCSTCP
+4 NEW HLDP
+5 NEW HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
+6 NEW HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
+7 ;
+8 ; protect variables defined in LISTEN^HLCSTCP
+9 ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
+10 ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+11 NEW HLLSTN
+12 ;
+13 ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
+14 NEW %
+15 ; protect variables defined in this routine HLCSTCP1
+16 NEW $ETRAP,$ESTACK
+17 NEW HLMIEN,HLASTMSG
+18 NEW HLTMBUF
+19 NEW HLDUZ,DUZ
+20 ; Kernel variables for single listener
+21 NEW ZISOS,ZRULE
+22 ;
+23 DO KILL^XUSCLEAN
+24 QUIT
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
+1 NEW HLMID,X
+2 IF HLIND1
Begin DoDot:1
+3 if '$GET(^HLMA(+HLIND1,0))
SET HLIND1=0
+4 if '$GET(^HL(772,+$PIECE(HLIND1,U,2),0))
SET HLIND1=0
End DoDot:1
+5 ;msg. id is 10th of MSH & 11th for BSH or FSH
+6 SET X=10+($EXTRACT(HLMSG(1,0),1,3)'="MSH")
SET HLMID=$$PMSH(.HLMSG,X)
+7 ;if HLIND1 is set, kill old message, use HLIND1 for new
+8 ;message, it means we never got end block for 1st msg.
+9 IF HLIND1
Begin DoDot:1
+10 ;get pointer to 772, kill header
+11 ;
+12 ; patch HL*1.6*122: MPI-client/server
+13 FOR
LOCK +^HLMA(+HLIND1):10
if $TEST
QUIT
HANG 1
+14 KILL ^HLMA(+HLIND1,"MSH")
+15 LOCK -^HLMA(+HLIND1)
+16 ;
+17 IF $DATA(^HL(772,+$PIECE(HLIND1,U,2),"IN"))
KILL ^("IN")
+18 SET X=$$MAID^HLTF(+HLIND1,HLMID)
+19 DO SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+20 if $PIECE(HLIND1,U,3)
SET $PIECE(HLIND1,U,3)=""
End DoDot:1
QUIT
+21 DO TCP^HLTF(.HLMID,.X,.HLDT)
+22 SET HLBUFF("IEN773")=X
+23 IF 'X
Begin DoDot:1
+24 ;error - record and reset array
+25 ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+26 DO CLEAN^HLCSTCP1
KILL HLLSTN
+27 ;error 100=LLP could not en-queue the message, reset array
+28 DO MONITOR^HLCSDR2(100,19,HLDP)
DO MON^HLCSTCP("ERROR")
HANG 30
End DoDot:1
QUIT
+29 ;HLIND1=ien in 773^ien in 772
+30 SET HLIND1=X_U_+$GET(^HLMA(X,0))
+31 SET HLBUFF("HLIND1")=HLIND1
+32 ;save MSH into 773
+33 DO SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+34 QUIT
+35 ;
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
+1 NEW FS,I,L,L1,L2,X,Y
+2 SET FS=$EXTRACT(MSH(1,0),4)
SET (L2,Y)=0
SET X=""
+3 FOR I=1:1
SET L1=$LENGTH($GET(MSH(I,0)),FS)
SET L=L1+Y-1
Begin DoDot:1
+4 if L1=1
SET L=L+1
+5 if P'>L
SET X=$PIECE($GET(MSH(I-1,0)),FS,P-L2)_$PIECE($GET(MSH(I,0)),FS,(P-Y))
+6 SET L2=Y
SET Y=L
End DoDot:1
if $LENGTH(X)!'$DATA(MSH(I,0))
QUIT
+7 QUIT X
+8 ;
ERROR1 ;
+1 ; moved from ERROR^HLCSTCP1
+2 ; Error trap for disconnect error and return back to the read loop.
+3 ; patch HL*1.6*122 start
+4 ; patch HL*1.6*140
+5 ; S $ETRAP="D HALT^ZU" ;RWF
+6 ;RWF
SET $ETRAP="H 1 D HALT^ZU"
+7 ; patch HL*1.6*157 start
+8 NEW HLOSYS
+9 SET HLOSYS=$$OS^%ZOSV
+10 ; I (^%ZOSF("OS")["OpenM") D
+11 IF (HLOSYS["UNIX")!(HLOSYS["VMS")
Begin DoDot:1
+12 ; patch HL*1.6*157 end
+13 SET HLTCP("$ZA")=$ZA
+14 ; For TCP devices $ZA\8192#2: the device is currently in the
+15 ; Connected state talking to a remote host.
+16 SET HLTCP("$ZA\8192#2")=$ZA\8192#2
+17 ; patch HL*1.6*157 to include <DSCON>: disconnected by client
+18 ; I HLTCP("$ZA\8192#2")=0 D
+19 IF (HLTCP("$ZA\8192#2")=0)!($$EC^%ZOSV["DSCON")
Begin DoDot:2
+20 ; decrement counter of multi-listener
+21 IF $DATA(^HLCS(870,"E","M",+$GET(HLDP)))
DO EXITM^HLCSTCP
+22 ; process terminated
+23 DO H2^XUSCLEAN
End DoDot:2
End DoDot:1
+24 ; patch HL*1.6*140
+25 ;S $ETRAP="D UNWIND^%ZTER" ;RWF
+26 ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+27 IF ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN")
Begin DoDot:1
+28 ; if it is not a multi-listener
+29 IF '$DATA(^HLCS(870,"E","M",+$GET(HLDP)))
DO CC^HLCSTCP1("Open-err")
+30 DO UNWIND^%ZTER
End DoDot:1
QUIT
+31 IF $$EC^%ZOSV["READ"
Begin DoDot:1
+32 ; if it is not a multi-listener
+33 IF '$DATA(^HLCS(870,"E","M",+$GET(HLDP)))
DO CC^HLCSTCP1("Rd-err")
+34 DO UNWIND^%ZTER
End DoDot:1
QUIT
+35 ;
+36 ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+37 IF $$EC^%ZOSV["WRITE"
Begin DoDot:1
+38 ; if it is not a multi-listener
+39 IF '$DATA(^HLCS(870,"E","M",+$GET(HLDP)))
DO CC^HLCSTCP1("Wr-err")
+40 DO UNWIND^%ZTER
End DoDot:1
QUIT
+41 ;
+42 ; for GT.M
+43 IF $ECODE["UREAD"
Begin DoDot:1
+44 ; if it is not a multi-listener
+45 IF '$DATA(^HLCS(870,"E","M",+$GET(HLDP)))
DO CC^HLCSTCP1("Rd-err")
+46 DO UNWIND^%ZTER
End DoDot:1
QUIT
+47 ;
+48 ; S HLCSOUT=1 D ^%ZTER,CC("Error")
+49 SET HLCSOUT=1
+50 DO ^%ZTER
+51 ; if it is not a multi-listener
+52 IF '$DATA(^HLCS(870,"E","M",+$GET(HLDP)))
DO CC^HLCSTCP1("Error")
+53 ; patch HL*1.6*122 end
+54 ;
+55 DO UNWIND^%ZTER
+56 QUIT
+57 ;
CLRMCNTR ;
+1 ; clear the counter to set as "0 server" for multi-listener
+2 ; HL*1.6*122 start
+3 if '$GET(HLDP)
QUIT
+4 if '$DATA(^HLCS(870,"E","M",HLDP))
QUIT
+5 SET $PIECE(^HLCS(870,HLDP,0),"^",4)="MS"
+6 SET $PIECE(^HLCS(870,HLDP,0),U,5)="0 server"
+7 QUIT
+8 ;
CREATUSR ;
+1 ; patch HL*1.6*122 TEST v2: DUZ code removed
+2 ; create application proxy users for listeners and incoming filer
+3 ;; N HLTEMP
+4 ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
+5 QUIT
