- 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 Feb 18, 2025@23:23:30 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