XOBVTCPL.m

XOBVTCPL ;; mjk/alb - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002  13:00

 ;;1.5;VistALink;;Sep 09, 2005

 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]

 ;

 QUIT

 ;

 ; -- Important: Should always be JOBed using START^XOBVTCP

LISTENER(XOBPORT,XOBCFG) ; -- Start Listener

 ;

 ; -- quit if not Cache for NT

 IF $$GETOS^XOBVTCP()'="OpenM-NT" QUIT

 ;

 NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT"

 ;

 NEW X,POP,XOBDA,U,DTIME,DT,XOBIO

 SET U="^",DTIME=900,DT=$$DT^XLFDT()

 IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@"

 ;

 ; -- only start if not already started

 IF $$LOCK^XOBVTCP(XOBPORT) DO

 . IF $$OPENM(.XOBIO,XOBPORT) DO

 . . ; -- listener started and now stopping

 . . SET IO=XOBIO

 . . DO CLOSE^%ZISTCP

 . . ; -- update status to 'stopped'

 . . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG))

 . ELSE  DO

 . . ; -- listener failed to start

 . . ; -- update status to 'failed'

 . . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG))

 . ;

 . DO UNLOCK^XOBVTCP(XOBPORT)

 QUIT

 ;

 ; -- open/start listener port

OPENM(XOBIO,XOBPORT) ;

 NEW XOBBOX,%ZA

 SET XOBBOX=+$$GETBOX^XOBVTCP()

 SET XOBIO="|TCP|"_XOBPORT

 OPEN XOBIO:(:XOBPORT:"AT"):30

 ;

 ; -- if listener port could not be openned then gracefully quit

 ;    (other namespace using port maybe?)

 IF '$TEST QUIT 0

 ;

 ; -- indicate listener is 'running'

 DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))

 ; -- read & spawn loop

 FOR  DO  QUIT:$$EXIT(XOBBOX,XOBPORT)

 . USE XOBIO

 . READ *X:60 IF '$TEST QUIT

 . JOB CHILDNT^XOBVTCPL():(:4:XOBIO:XOBIO):10 SET %ZA=$ZA

 . IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit

 QUIT 1

 ;

CHILDNT() ;Child process for OpenM

 NEW XOBEC

 SET $ETRAP="D ^%ZTER L  HALT"

 SET IO=$PRINCIPAL ;Reset IO to be $P

 USE IO:(::"-M") ;Packet mode like DSM

 ; -- do quit to save a stack level

 SET XOBEC=$$NEWOK()

 IF XOBEC DO LOGINERR(XOBEC,IO)

 IF 'XOBEC DO VAR,SPAWN^XOBVLL

 QUIT

 ;

VAR ;Setup IO variables

 SET IO(0)=IO,IO(1,IO)="",POP=0

 SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0

 QUIT

 ;

NEWOK() ;Is it OK to start a new process

 NEW XQVOL,XUVOL,X,XOBCODE,Y

 SET U="^"

 DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2)

 SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")

 SET XOBCODE=$$INHIBIT^XUSRB()

 IF XOBCODE=1 QUIT 181004

 IF XOBCODE=2 QUIT 181003

 QUIT 0

 ;

 ; -- process error

LOGINERR(XOBEC,XOBPORT) ;

 DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)

 ;

 ; -- give client time to process stream

 HANG 2

 QUIT

 ;

EXIT(XOBBOX,XOBPORT) ;

 ; -- is status 'stopping'

 QUIT ($PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3)

 ;

GETLOGID(XOBBOX,XOBPORT) ;

 QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,""))

 ;

XOBVTCPL  ;; mjk/alb - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002  13:00

 +1       ;;1.5;VistALink;;Sep 09, 2005

 +2       ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]

 +3       ;

 +4        QUIT 

 +5       ;

 +6       ; -- 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        NEW $ETRAP,$ESTACK

           SET $ETRAP="D ^%ZTER HALT"

 +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 openned 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

 +2        SET $ETRAP="D ^%ZTER 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,XUVOL,X,XOBCODE,Y

 +2        SET U="^"

 +3        DO GETENV^%ZOSV

           SET XQVOL=$PIECE(Y,U,2)

 +4        SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","","")

           SET XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")

 +5        SET XOBCODE=$$INHIBIT^XUSRB()

 +6        IF XOBCODE=1

               QUIT 181004

 +7        IF XOBCODE=2

               QUIT 181003

 +8        QUIT 0

 +9       ;

 +10      ; -- 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       ;