HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;08/08/2011 14:29
;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122,140,157**;Oct 13, 1995;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
;
; This is an implementation of the HL7 Minimal Lower Layer Protocol
; taskman entry/startup option, HLDP defined in menu entry.
;
Q:'$D(HLDP)
; patch HL*1.6*122 start
L +^HLCS("HLTCPLINK",HLDP):5 I '$T D Q
. D MON^HLCSTCP("TskLcked")
N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
N HLZRULE
;HLCSOUT= 1-error
I '$$INIT D EXITS("Init Error") Q
S HLDP("$J")=$J
S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
; Start the client
I $G(HLTCPCS)="C" D Q
. S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)
. I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
. S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
. ; identify process for ^%SY
. ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
. D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
. K HLDP("$J",0)
. D ST1
. F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
. ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
. I $G(HLCSOUT)=1 D Q
.. D MON("Error") H 1
.. L -^HLCS("HLTCPLINK",HLDP)
. I $G(HLCSOUT)=2 D EXITS("Inactive") Q
. D EXITS("Shutdown")
;
S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
; identify process for ^%SY
; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
K HLDP("$J",0)
; to stop the listener via updated Kernel API, need to pass the
; listener logical link (HLDP)
S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
;single threaded listener
I $G(HLTCPCS)="S" D Q
. D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
. I $$STOP D EXITS("Shutdown") Q
. D EXITS("Openfail")
;
; multi-threaded listener code (for OpenM/NT)
I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D Q
. L -^HLCS("HLTCPLINK",HLDP)
; patch HL*1.6*157
; I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
I ($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX") L -^HLCS("HLTCPLINK",HLDP) Q
D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
; update status of listener
I $$STOP D EXITS("Shutdown") Q
D EXITS("Openfail")
; HL*1.6*122 end
Q
;
SERVER(HLDP) ; single server using Taskman
I '$$INIT D EXITS("Init error") Q
D ^HLCSTCP1
I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
Q:$G(HLCSOUT)=1
D MON("Idle")
Q
;
SERVERS(HLDP) ; Multi-threaded server using Taskman
I '$$INIT D EXITS("Init error") Q
G LISTEN
;
;multiple process servers, called from an external utility
MSM ;MSM entry point, called from User-Defined Services
;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
;HL7 Multi-Threaded SERVER
S (IO,IO(0))=$P
G LISTEN
;
LISTEN ;
N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
I '$$INIT D ^%ZTER Q
; patch HL*1.6*122 start
S HLDP("$J")=$J
S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
; identify process for ^%SY
; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
K HLDP("$J",0)
; patch HL*1.6*122 end
;HLLSTN used to identify a listener to tag MON
S HLLSTN=1
;increment job count, run server
D UPDT(1),^HLCSTCP1,EXITM
Q
;
DCOPEN(HLDP) ;open direct connect - called from HLMA2
Q:'$$INIT 0
Q:HLTCPADD=""!(HLTCPORT="") 0
Q:'$$OPEN^HLCSTCP2 0
Q 1
;
INIT() ; Initialize Variables
; HLDP should be set to the IEN or name of Logical Link, file 870
; patch HL*1.6*157
; S HLOS=$P($G(^%ZOSF("OS")),"^")
S HLOS=$$OS^%ZOSV
N DA,DIQUIET,DR,TMP,X,Y
; patch HL*1.6*140
; S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
S HLTCPLNK("IOF")=$$FLUSHCHR^%ZISTCP
S DIQUIET=1
D DT^DICRW
I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
S DA=HLDP
; patch HL*1.6*122 for field 400.09
S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09"
D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
;
I $D(TMP("DIERR")) QUIT 0
; -- re-transmit attempts
S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I"))
; -- exceed re-transmit action
S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
; -- block size
S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
; -- read timeout
S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
; -- ack timeout
S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
; -- uni-directional wait
S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
; -- tcp address
S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
; -- tcp port
S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
; -- tcp/ip service type
S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
; -- link persistence
S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
; -- retention
S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
;
; patch HL*1.6*140
; patch HL*1.6*122 for field 400.09
; -- tcp/ip openfail timeout
; S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
S HLTCPLNK("TIMEOUT")=+$G(TMP(870,DA_",",400.09,"I"))
;
; -- set defaults in case something's not set
S:HLDREAD=0 HLDREAD=10
S:HLDBACK=0 HLDBACK=60
; patch HL*1.6*122
; S:HLDBSIZE=0 HLDBSIZE=245
S:HLDBSIZE<245 HLDBSIZE=245
S:HLDRETR=0 HLDRETR=5
S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
;
; patch HL*1.6*140, the defaut is 30
; patch HL*1.6*122 for field 400.09
; S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
S:(HLTCPLNK("TIMEOUT")<1) HLTCPLNK("TIMEOUT")=30
;
Q 1
;
ST1 ;record startup in 870 for single server
;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
N HLJ,X
; HL*1.6*122 remove unnecessary locks
;F L +^HLCS(870,HLDP,0):2 Q:$T
S X="HLJ(870,"""_HLDP_","")"
S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
S:$G(ZTSK) @X@(11)=ZTSK
D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
;L -^HLCS(870,HLDP,0)
Q
;
MON(Y) ;Display current state & check for shutdown
;don't display for multiple server
Q:$G(HLLSTN)
; HL*1.6*122 remove unnecessary locks
;F L +^HLCS(870,HLDP,0):2 Q:$T
S $P(^HLCS(870,HLDP,0),U,5)=Y
;L -^HLCS(870,HLDP,0)
Q:'$D(HLTRACE)
N X U IO(0)
W !,"IN State: ",Y
I '$$STOP D
. ; patch HL*1.6*122
. ; R !,"Type Q to Quit: ",X#1:1
. R !,"Type Q to Quit: ",X:1
. ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
. I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1
. ; patch HL*1.6*122 end
U IO
Q
UPDT(Y) ;update job count for multiple servers,X=1 increment
N HLJ,X
;
; HL*1.6*122 start
; F L +^HLCS(870,HLDP,0):2 Q:$T
Q:'$G(HLDP)
Q:'$D(^HLCS(870,"E","M",HLDP))
F L +^HLCS(870,HLDP,0):10 Q:$T H 1
; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
S X=+$P(^HLCS(870,HLDP,0),U,5)
I X<0 S X=0
S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server"
;if incrementing, set the Device Type field to Multi-Server
; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS"
; HL*1.6*122 end
;
L -^HLCS(870,HLDP,0)
Q
STOP() ;stop flag set
N X
F L +^HLCS(870,HLDP,0):2 Q:$T
S X=+$P(^HLCS(870,HLDP,0),U,15)
L -^HLCS(870,HLDP,0)
Q X
;
LLCNT(DP,Y,Z) ;update Logical Link counters
;DP=ien of Logical Link in file 870
;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
;Z: ""=add to counter, 1=subtract from counter
Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
N P,X
S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
; patch HL*1.6*122 start
; F L +^HLCS(870,DP,P):2 Q:$T
; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
; patch HL*1.6*157 start
; adds call $$OS^%ZOSV
I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
I '$L($G(HLOSYS)) N HLOSYS S HLOSYS=$$OS^%ZOSV
; I OS'["DSM",OS'["OpenM" D
I OS'["DSM",OS'["OpenM",(OS["OpenM")&((HLOSYS'["VMS")&(HLOSYS'["UNIX")) D
. ; patch HL*1.6*157 end
. F L +^HLCS(870,DP,P):10 Q:$T H 1
. S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
. L -^HLCS(870,DP,P)
E D
. S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1))
; L -^HLCS(870,DP,P)
; patch HL*1.6*122 end
Q
SDFLD ; set Shutdown? field to yes
Q:'$G(HLDP)
; HL*1.6*122 remove unnecessary lock and call to FM
S $P(^HLCS(870,HLDP,0),U,15)=1
;N HLJ,X
;F L +^HLCS(870,HLDP,0):2 Q:$T
;14=Shutdown LLP?
;S HLJ(870,HLDP_",",14)=1
;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
;L -^HLCS(870,HLDP,0)
Q
;
EXITS(Y) ; shutdown and clean up the listener process for either
; single-threaded or multi-threaded
N HLJ,X
F L +^HLCS(870,HLDP,0):2 Q:$T
;4=status,10=Time Stopped,9=Time Started,11=Task Number
S X="HLJ(870,"""_HLDP_","")"
S @X@(4)=Y,@X@(11)="@"
S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
L -^HLCS(870,HLDP,0)
I $D(ZTQUEUED) S ZTREQ="@"
; HL*1.6*122
L -^HLCS("HLTCPLINK",HLDP)
Q
;
EXITM ;Multiple service shutdown and clean up
; shutdown and clean up a connection spawned by the listener
; process for a multi-threaded listener
D UPDT(0)
I $D(ZTQUEUED) S ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLCSTCP 9877 printed Oct 16, 2024@17:57:53 Page 2
HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;08/08/2011 14:29
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122,140,157**;Oct 13, 1995;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This is an implementation of the HL7 Minimal Lower Layer Protocol
+5 ; taskman entry/startup option, HLDP defined in menu entry.
+6 ;
+7 if '$DATA(HLDP)
QUIT
+8 ; patch HL*1.6*122 start
+9 LOCK +^HLCS("HLTCPLINK",HLDP):5
IF '$TEST
Begin DoDot:1
+10 DO MON^HLCSTCP("TskLcked")
End DoDot:1
QUIT
+11 NEW HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
+12 NEW HLZRULE
+13 ;HLCSOUT= 1-error
+14 IF '$$INIT
DO EXITS("Init Error")
QUIT
+15 SET HLDP("$J")=$JOB
+16 SET HLDP("$J",0,"LENGTH")=$LENGTH(HLDP("$J"))
+17 ; Start the client
+18 IF $GET(HLTCPCS)="C"
Begin DoDot:1
+19 SET HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$LENGTH(HLTCPORT)+$LENGTH(HLDP)
+20 IF HLDP("$J",0,"START")<1
SET HLDP("$J",0,"START")=1
+21 SET HLDP("$J",0)=$EXTRACT(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
+22 ; identify process for ^%SY
+23 ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
+24 DO SETNM^%ZOSV($EXTRACT("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
+25 KILL HLDP("$J",0)
+26 DO ST1
+27 FOR
DO ^HLCSTCP2
if $$STOP!$G(HLCSOUT)
QUIT
+28 ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
+29 IF $GET(HLCSOUT)=1
Begin DoDot:2
+30 DO MON("Error")
HANG 1
+31 LOCK -^HLCS("HLTCPLINK",HLDP)
End DoDot:2
QUIT
+32 IF $GET(HLCSOUT)=2
DO EXITS("Inactive")
QUIT
+33 DO EXITS("Shutdown")
End DoDot:1
QUIT
+34 ;
+35 SET HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$LENGTH(HLTCPORT)
+36 IF HLDP("$J",0,"START")<1
SET HLDP("$J",0,"START")=1
+37 SET HLDP("$J",0)=$EXTRACT(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
+38 ; identify process for ^%SY
+39 ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+40 DO SETNM^%ZOSV($EXTRACT("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
+41 KILL HLDP("$J",0)
+42 ; to stop the listener via updated Kernel API, need to pass the
+43 ; listener logical link (HLDP)
+44 SET HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
+45 ;single threaded listener
+46 IF $GET(HLTCPCS)="S"
Begin DoDot:1
+47 DO ST1
DO MON("Listen")
DO LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
+48 IF $$STOP
DO EXITS("Shutdown")
QUIT
+49 DO EXITS("Openfail")
End DoDot:1
QUIT
+50 ;
+51 ; multi-threaded listener code (for OpenM/NT)
+52 IF ($GET(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM")
Begin DoDot:1
+53 LOCK -^HLCS("HLTCPLINK",HLDP)
End DoDot:1
QUIT
+54 ; patch HL*1.6*157
+55 ; I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
+56 IF ($$OS^%ZOSV["VMS")!($$OS^%ZOSV["UNIX")
LOCK -^HLCS("HLTCPLINK",HLDP)
QUIT
+57 DO ST1
DO MON("Listen")
DO LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
+58 ; update status of listener
+59 IF $$STOP
DO EXITS("Shutdown")
QUIT
+60 DO EXITS("Openfail")
+61 ; HL*1.6*122 end
+62 QUIT
+63 ;
SERVER(HLDP) ; single server using Taskman
+1 IF '$$INIT
DO EXITS("Init error")
QUIT
+2 DO ^HLCSTCP1
+3 IF $$STOP
DO CLOSE^%ZISTCP
DO EXITS("Shutdown")
SET IO("C")=""
QUIT
+4 if $GET(HLCSOUT)=1
QUIT
+5 DO MON("Idle")
+6 QUIT
+7 ;
SERVERS(HLDP) ; Multi-threaded server using Taskman
+1 IF '$$INIT
DO EXITS("Init error")
QUIT
+2 GOTO LISTEN
+3 ;
+4 ;multiple process servers, called from an external utility
MSM ;MSM entry point, called from User-Defined Services
+1 ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
+2 ;HL7 Multi-Threaded SERVER
+3 SET (IO,IO(0))=$PRINCIPAL
+4 GOTO LISTEN
+5 ;
LISTEN ;
+1 NEW HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
+2 IF '$$INIT
DO ^%ZTER
QUIT
+3 ; patch HL*1.6*122 start
+4 SET HLDP("$J")=$JOB
+5 SET HLDP("$J",0,"LENGTH")=$LENGTH(HLDP("$J"))
+6 SET HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$LENGTH(HLTCPORT)
+7 IF HLDP("$J",0,"START")<1
SET HLDP("$J",0,"START")=1
+8 SET HLDP("$J",0)=$EXTRACT(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
+9 ; identify process for ^%SY
+10 ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+11 DO SETNM^%ZOSV($EXTRACT("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
+12 KILL HLDP("$J",0)
+13 ; patch HL*1.6*122 end
+14 ;HLLSTN used to identify a listener to tag MON
+15 SET HLLSTN=1
+16 ;increment job count, run server
+17 DO UPDT(1)
DO ^HLCSTCP1
DO EXITM
+18 QUIT
+19 ;
DCOPEN(HLDP) ;open direct connect - called from HLMA2
+1 if '$$INIT
QUIT 0
+2 if HLTCPADD=""!(HLTCPORT="")
QUIT 0
+3 if '$$OPEN^HLCSTCP2
QUIT 0
+4 QUIT 1
+5 ;
INIT() ; Initialize Variables
+1 ; HLDP should be set to the IEN or name of Logical Link, file 870
+2 ; patch HL*1.6*157
+3 ; S HLOS=$P($G(^%ZOSF("OS")),"^")
+4 SET HLOS=$$OS^%ZOSV
+5 NEW DA,DIQUIET,DR,TMP,X,Y
+6 ; patch HL*1.6*140
+7 ; S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
+8 SET HLTCPLNK("IOF")=$$FLUSHCHR^%ZISTCP
+9 SET DIQUIET=1
+10 DO DT^DICRW
+11 IF 'HLDP
SET HLDP=$ORDER(^HLCS(870,"B",HLDP,0))
IF 'HLDP
QUIT 0
+12 SET DA=HLDP
+13 ; patch HL*1.6*122 for field 400.09
+14 SET DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09"
+15 DO GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
+16 ;
+17 IF $DATA(TMP("DIERR"))
QUIT 0
+18 ; -- re-transmit attempts
+19 SET HLDRETR=+$GET(TMP(870,DA_",",200.02,"I"))
+20 SET HLDRETR("CLOSE")=+$GET(TMP(870,DA_",",200.022,"I"))
+21 ; -- exceed re-transmit action
+22 SET HLRETRA=$GET(TMP(870,DA_",",200.021,"I"))
+23 ; -- block size
+24 SET HLDBSIZE=+$GET(TMP(870,DA_",",200.03,"I"))
+25 ; -- read timeout
+26 SET HLDREAD=+$GET(TMP(870,DA_",",200.04,"I"))
+27 ; -- ack timeout
+28 SET HLDBACK=+$GET(TMP(870,DA_",",200.05,"I"))
+29 ; -- uni-directional wait
+30 SET HLDWAIT=$GET(TMP(870,DA_",",200.09,"I"))
+31 ; -- tcp address
+32 SET HLTCPADD=$GET(TMP(870,DA_",",400.01,"I"))
+33 ; -- tcp port
+34 SET HLTCPORT=$GET(TMP(870,DA_",",400.02,"I"))
+35 ; -- tcp/ip service type
+36 SET HLTCPCS=$GET(TMP(870,DA_",",400.03,"I"))
+37 ; -- link persistence
+38 SET HLTCPLNK=$GET(TMP(870,DA_",",400.04,"I"))
+39 ; -- retention
+40 SET HLTCPRET=$GET(TMP(870,DA_",",400.05,"I"))
+41 ;
+42 ; patch HL*1.6*140
+43 ; patch HL*1.6*122 for field 400.09
+44 ; -- tcp/ip openfail timeout
+45 ; S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
+46 SET HLTCPLNK("TIMEOUT")=+$GET(TMP(870,DA_",",400.09,"I"))
+47 ;
+48 ; -- set defaults in case something's not set
+49 if HLDREAD=0
SET HLDREAD=10
+50 if HLDBACK=0
SET HLDBACK=60
+51 ; patch HL*1.6*122
+52 ; S:HLDBSIZE=0 HLDBSIZE=245
+53 if HLDBSIZE<245
SET HLDBSIZE=245
+54 if HLDRETR=0
SET HLDRETR=5
+55 if HLTCPRET=""
SET X=$PIECE($$PARAM^HLCS2,U,12)
SET HLTCPRET=$SELECT(X:X,1:15)
+56 ;
+57 ; patch HL*1.6*140, the defaut is 30
+58 ; patch HL*1.6*122 for field 400.09
+59 ; S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
+60 if (HLTCPLNK("TIMEOUT")<1)
SET HLTCPLNK("TIMEOUT")=30
+61 ;
+62 QUIT 1
+63 ;
ST1 ;record startup in 870 for single server
+1 ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+2 ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
+3 NEW HLJ,X
+4 ; HL*1.6*122 remove unnecessary locks
+5 ;F L +^HLCS(870,HLDP,0):2 Q:$T
+6 SET X="HLJ(870,"""_HLDP_","")"
+7 SET @X@(4)="Init"
SET (@X@(10),@X@(18))="@"
SET @X@(14)=0
+8 IF HLTCPCS["C"
SET @X@(3)=$SELECT(HLTCPLNK["Y":"PC",1:"NC")
+9 IF '$TEST
SET @X@(3)=$SELECT(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
+10 IF @X@(3)'="NC"
SET @X@(9)=$$NOW^XLFDT
+11 if $GET(ZTSK)
SET @X@(11)=ZTSK
+12 ;HL*1.6*109
DO FILE^HLDIE("","HLJ","","ST1","HLCSTCP")
+13 ;L -^HLCS(870,HLDP,0)
+14 QUIT
+15 ;
MON(Y) ;Display current state & check for shutdown
+1 ;don't display for multiple server
+2 if $GET(HLLSTN)
QUIT
+3 ; HL*1.6*122 remove unnecessary locks
+4 ;F L +^HLCS(870,HLDP,0):2 Q:$T
+5 SET $PIECE(^HLCS(870,HLDP,0),U,5)=Y
+6 ;L -^HLCS(870,HLDP,0)
+7 if '$DATA(HLTRACE)
QUIT
+8 NEW X
USE IO(0)
+9 WRITE !,"IN State: ",Y
+10 IF '$$STOP
Begin DoDot:1
+11 ; patch HL*1.6*122
+12 ; R !,"Type Q to Quit: ",X#1:1
+13 READ !,"Type Q to Quit: ",X:1
+14 ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
+15 IF $LENGTH(X)
IF "Qq"[$EXTRACT(X)
SET $PIECE(^HLCS(870,HLDP,0),U,15)=1
+16 ; patch HL*1.6*122 end
End DoDot:1
+17 USE IO
+18 QUIT
UPDT(Y) ;update job count for multiple servers,X=1 increment
+1 NEW HLJ,X
+2 ;
+3 ; HL*1.6*122 start
+4 ; F L +^HLCS(870,HLDP,0):2 Q:$T
+5 if '$GET(HLDP)
QUIT
+6 if '$DATA(^HLCS(870,"E","M",HLDP))
QUIT
+7 FOR
LOCK +^HLCS(870,HLDP,0):10
if $TEST
QUIT
HANG 1
+8 ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
+9 SET X=+$PIECE(^HLCS(870,HLDP,0),U,5)
+10 IF X<0
SET X=0
+11 SET $PIECE(^HLCS(870,HLDP,0),U,5)=$SELECT(Y:(X+1),X<1:0,1:X-1)_" server"
+12 ;if incrementing, set the Device Type field to Multi-Server
+13 ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
+14 IF $PIECE(^HLCS(870,HLDP,0),"^",4)']""
SET $PIECE(^HLCS(870,HLDP,0),"^",4)="MS"
+15 ; HL*1.6*122 end
+16 ;
+17 LOCK -^HLCS(870,HLDP,0)
+18 QUIT
STOP() ;stop flag set
+1 NEW X
+2 FOR
LOCK +^HLCS(870,HLDP,0):2
if $TEST
QUIT
+3 SET X=+$PIECE(^HLCS(870,HLDP,0),U,15)
+4 LOCK -^HLCS(870,HLDP,0)
+5 QUIT X
+6 ;
LLCNT(DP,Y,Z) ;update Logical Link counters
+1 ;DP=ien of Logical Link in file 870
+2 ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
+3 ;Z: ""=add to counter, 1=subtract from counter
+4 if '$DATA(^HLCS(870,+$GET(DP),0))!('$GET(Y))
QUIT
+5 NEW P,X
+6 SET P=$SELECT(Y<3:"IN",1:"OUT")_" QUEUE "_$SELECT(Y#2:"BACK",1:"FRONT")_" POINTER"
+7 ; patch HL*1.6*122 start
+8 ; F L +^HLCS(870,DP,P):2 Q:$T
+9 ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+10 ; patch HL*1.6*157 start
+11 ; adds call $$OS^%ZOSV
+12 IF '$LENGTH($GET(OS))
NEW OS
SET OS=$GET(^%ZOSF("OS"))
+13 IF '$LENGTH($GET(HLOSYS))
NEW HLOSYS
SET HLOSYS=$$OS^%ZOSV
+14 ; I OS'["DSM",OS'["OpenM" D
+15 IF OS'["DSM"
IF OS'["OpenM"
IF (OS["OpenM")&((HLOSYS'["VMS")&(HLOSYS'["UNIX"))
Begin DoDot:1
+16 ; patch HL*1.6*157 end
+17 FOR
LOCK +^HLCS(870,DP,P):10
if $TEST
QUIT
HANG 1
+18 SET X=+$GET(^HLCS(870,DP,P))
SET ^(P)=X+$SELECT($GET(Z):-1,1:1)
+19 LOCK -^HLCS(870,DP,P)
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21
*** ERROR ***
SET X=$I(^HLCS(870,DP,P),$SELECT($GET(Z):-1,1:1))
End DoDot:1
+22 ; L -^HLCS(870,DP,P)
+23 ; patch HL*1.6*122 end
+24 QUIT
SDFLD ; set Shutdown? field to yes
+1 if '$GET(HLDP)
QUIT
+2 ; HL*1.6*122 remove unnecessary lock and call to FM
+3 SET $PIECE(^HLCS(870,HLDP,0),U,15)=1
+4 ;N HLJ,X
+5 ;F L +^HLCS(870,HLDP,0):2 Q:$T
+6 ;14=Shutdown LLP?
+7 ;S HLJ(870,HLDP_",",14)=1
+8 ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+9 ;L -^HLCS(870,HLDP,0)
+10 QUIT
+11 ;
EXITS(Y) ; shutdown and clean up the listener process for either
+1 ; single-threaded or multi-threaded
+2 NEW HLJ,X
+3 FOR
LOCK +^HLCS(870,HLDP,0):2
if $TEST
QUIT
+4 ;4=status,10=Time Stopped,9=Time Started,11=Task Number
+5 SET X="HLJ(870,"""_HLDP_","")"
+6 SET @X@(4)=Y
SET @X@(11)="@"
+7 if $GET(HLCSOUT)'=2
SET @X@(10)=$$NOW^XLFDT
SET @X@(9)="@"
+8 ; HL*1.6*109
DO FILE^HLDIE("","HLJ","","EXITS","HLCSTCP")
+9 LOCK -^HLCS(870,HLDP,0)
+10 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+11 ; HL*1.6*122
+12 LOCK -^HLCS("HLTCPLINK",HLDP)
+13 QUIT
+14 ;
EXITM ;Multiple service shutdown and clean up
+1 ; shutdown and clean up a connection spawned by the listener
+2 ; process for a multi-threaded listener
+3 DO UPDT(0)
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
