XOBVTCPL ;; mjk/alb - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002 13:00
;;1.6;VistALink Security;**4**;May 08, 2009;Build 7
; ;Per VA Directive 6402, this routine should not be modified.
Q
;
; -- Important: Should always be JOBed using START^XOBVTCP
LISTENER(XOBPORT,XOBCFG) ; -- Start Listener
;
; -- quit if not Cache for NT
I $$GETOS^XOBVTCP()'="OpenM-NT" Q
;
N $ET,$ES S $ET="D APPERROR^%ZTER(""VistALink Error""_ECODE_ "") H" ;*4
;
N X,POP,XOBDA,U,DTIME,DT,XOBIO
S U="^",DTIME=900,DT=$$DT^XLFDT()
I $G(DUZ)="" N DUZ S DUZ=.5,DUZ(0)="@"
;
; -- only start if not already started
I $$LOCK^XOBVTCP(XOBPORT) D
. I $$OPENM(.XOBIO,XOBPORT) D
. . ; -- listener started and now stopping
. . S IO=XOBIO
. . D CLOSE^%ZISTCP
. . ; -- update status to 'stopped'
. . D UPDATE^XOBVTCP(XOBPORT,4,$G(XOBCFG))
. E D
. . ; -- listener failed to start
. . ; -- update status to 'failed'
. . D UPDATE^XOBVTCP(XOBPORT,5,$G(XOBCFG))
. ;
. D UNLOCK^XOBVTCP(XOBPORT)
Q
;
; -- open/start listener port
OPENM(XOBIO,XOBPORT) ;
N XOBBOX,%ZA
S XOBBOX=+$$GETBOX^XOBVTCP()
S XOBIO="|TCP|"_XOBPORT
O XOBIO:(:XOBPORT:"AT"):30
;
; -- if listener port could not be opened then gracefully quit
; (other namespace using port maybe?)
I '$T Q 0
;
; -- indicate listener is 'running'
D UPDATE^XOBVTCP(XOBPORT,2,$G(XOBCFG))
; -- read & spawn loop
F D Q:$$EXIT(XOBBOX,XOBPORT)
. U XOBIO
. R *X:60 I '$T Q
. J CHILDNT^XOBVTCPL():(:4:XOBIO:XOBIO):10 S %ZA=$ZA
. I %ZA\8196#2=1 W *-2 ;Job failed to clear bit
Q 1
;
CHILDNT() ;Child process for OpenM
N XOBEC,$ET,$ES
S $ET="D APPERROR^%ZTER(""VistALink Error "") L HALT" ;4
S IO=$P ;Reset IO to be $P
U IO:(::"-M") ;Packet mode like DSM
; -- do quit to save a stack level
S XOBEC=$$NEWOK()
I XOBEC D LOGINERR(XOBEC,IO)
I 'XOBEC D VAR,SPAWN^XOBVLL
Q
;
VAR ;Setup IO variables
S IO(0)=IO,IO(1,IO)="",POP=0
S IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0
Q
;
NEWOK() ;Is it OK to start a new process
N XQVOL,XUCI,XUENV,XUVOL,X,Y,XOBCODE
D XUVOL^XUS
I $$INHIB1^XUSRB() Q 181004
I $$INHIB2^XUSRB() Q 181003
Q 0
;
; -- process error
LOGINERR(XOBEC,XOBPORT) ;
D ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)
;
; -- give client time to process stream
H 2
Q
;
EXIT(XOBBOX,XOBPORT) ;
; -- is status 'stopping'
Q ($P($G(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3)
;
GETLOGID(XOBBOX,XOBPORT) ;
Q +$O(^XOB(18.04,"C",XOBBOX,XOBPORT,""))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBVTCPL 2528 printed Apr 09, 2024@21:46:55 Page 2
XOBVTCPL ;; mjk/alb - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002 13:00
+1 ;;1.6;VistALink Security;**4**;May 08, 2009;Build 7
+2 ; ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; -- Important: Should always be JOBed using START^XOBVTCP
LISTENER(XOBPORT,XOBCFG) ; -- Start Listener
+1 ;
+2 ; -- quit if not Cache for NT
+3 IF $$GETOS^XOBVTCP()'="OpenM-NT"
QUIT
+4 ;
+5 ;*4
NEW $ETRAP,$ESTACK
SET $ETRAP="D APPERROR^%ZTER(""VistALink Error""_ECODE_ "") H"
+6 ;
+7 NEW X,POP,XOBDA,U,DTIME,DT,XOBIO
+8 SET U="^"
SET DTIME=900
SET DT=$$DT^XLFDT()
+9 IF $GET(DUZ)=""
NEW DUZ
SET DUZ=.5
SET DUZ(0)="@"
+10 ;
+11 ; -- only start if not already started
+12 IF $$LOCK^XOBVTCP(XOBPORT)
Begin DoDot:1
+13 IF $$OPENM(.XOBIO,XOBPORT)
Begin DoDot:2
+14 ; -- listener started and now stopping
+15 SET IO=XOBIO
+16 DO CLOSE^%ZISTCP
+17 ; -- update status to 'stopped'
+18 DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG))
End DoDot:2
+19 IF '$TEST
Begin DoDot:2
+20 ; -- listener failed to start
+21 ; -- update status to 'failed'
+22 DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG))
End DoDot:2
+23 ;
+24 DO UNLOCK^XOBVTCP(XOBPORT)
End DoDot:1
+25 QUIT
+26 ;
+27 ; -- open/start listener port
OPENM(XOBIO,XOBPORT) ;
+1 NEW XOBBOX,%ZA
+2 SET XOBBOX=+$$GETBOX^XOBVTCP()
+3 SET XOBIO="|TCP|"_XOBPORT
+4 OPEN XOBIO:(:XOBPORT:"AT"):30
+5 ;
+6 ; -- if listener port could not be opened then gracefully quit
+7 ; (other namespace using port maybe?)
+8 IF '$TEST
QUIT 0
+9 ;
+10 ; -- indicate listener is 'running'
+11 DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
+12 ; -- read & spawn loop
+13 FOR
Begin DoDot:1
+14 USE XOBIO
+15 READ *X:60
IF '$TEST
QUIT
+16 JOB CHILDNT^XOBVTCPL():(:4:XOBIO:XOBIO):10
SET %ZA=$ZA
+17 ;Job failed to clear bit
IF %ZA\8196#2=1
WRITE *-2
End DoDot:1
if $$EXIT(XOBBOX,XOBPORT)
QUIT
+18 QUIT 1
+19 ;
CHILDNT() ;Child process for OpenM
+1 NEW XOBEC,$ETRAP,$ESTACK
+2 ;4
SET $ETRAP="D APPERROR^%ZTER(""VistALink Error "") L HALT"
+3 ;Reset IO to be $P
SET IO=$PRINCIPAL
+4 ;Packet mode like DSM
USE IO:(::"-M")
+5 ; -- do quit to save a stack level
+6 SET XOBEC=$$NEWOK()
+7 IF XOBEC
DO LOGINERR(XOBEC,IO)
+8 IF 'XOBEC
DO VAR
DO SPAWN^XOBVLL
+9 QUIT
+10 ;
VAR ;Setup IO variables
+1 SET IO(0)=IO
SET IO(1,IO)=""
SET POP=0
+2 SET IOT="TCP"
SET IOF="#"
SET IOST="P-TCP"
SET IOST(0)=0
+3 QUIT
+4 ;
NEWOK() ;Is it OK to start a new process
+1 NEW XQVOL,XUCI,XUENV,XUVOL,X,Y,XOBCODE
+2 DO XUVOL^XUS
+3 IF $$INHIB1^XUSRB()
QUIT 181004
+4 IF $$INHIB2^XUSRB()
QUIT 181003
+5 QUIT 0
+6 ;
+7 ; -- process error
LOGINERR(XOBEC,XOBPORT) ;
+1 DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)
+2 ;
+3 ; -- give client time to process stream
+4 HANG 2
+5 QUIT
+6 ;
EXIT(XOBBOX,XOBPORT) ;
+1 ; -- is status 'stopping'
+2 QUIT ($PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3)
+3 ;
GETLOGID(XOBBOX,XOBPORT) ;
+1 QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,""))
+2 ;
