XWBTCPMT ;ISF/RWF - Routine to test a connection ;12/02/14 08:48
;;1.1;RPC BROKER;**43,49,53,64**;Mar 28, 1997;Build 12
;Per VA Directive 6402, this routine should not be modified.
;
CALL ;Interactive
N IP,PORT,STAT
D HOME^%ZIS
S U="^",DTIME=$$DTIME^XUP
W !,"Interactive Broker Test"
R !,"IP ADDRESS: ",IP:DTIME
I IP["^" Q
R !,"PORT: ",PORT:DTIME
I PORT["^" Q
S STAT=$$TEST(IP,PORT,1)
U $P
W !,$S(STAT>0:"Success, response: "_$P(STAT,U,2),1:"Failed: "_$P(STAT,U,2,9)),!
Q
;
TEST(IP,PORT,TALK) ;
N T1,T2,T3,T4,OS,RES,RES2,RES3
S OS=^%ZOSF("OS")
I '$$VALIDATE^XLFIPV(IP) S IP=$$ADDRESS^XLFNSLK(IP) ;p64
I '$$VALIDATE^XLFIPV(IP) Q "-1^BAD IP" ;p64
I OS["OpenM" X "S T1=$ZH"
D CALL^%ZISTCP(IP,PORT)
I OS["OpenM" X "S T2=$ZH"
I POP Q "-1^Failed to Connect"
U IO
N $ET S $ET="G ERR^XWBTCPMT"
;TCPConnect
W "[XWB]10304"_$C(10)_"TCPConnect50010127.0.0.1f00010f0024ISF-FORTW.vha.domain.extf"_$C(4),@IOF
R RES:10 I '$T S RES="-1^TIMEOUT" G EXIT
I OS["OpenM" X "S T3=$ZH"
W "[XWB]11302"_$C(1)_"0"_$C(16)_"XUS SIGNON SETUP54f"_$C(4),@IOF
R RES2:10
I OS["OpenM" X "S T4=$ZH"
W "[XWB]10304"_$C(5)_"#BYE#"_$C(4),@IOF
R RES3:3 I '$T S RES="-1^TIMEOUT after accept" G EXIT
S RES="1^"_RES_U_($G(T2)-$G(T1))_U_($G(T3)-$G(T2))_U_($G(T4)-$G(T3))
EXIT ;Close and Exit
D CLOSE^%ZISTCP
Q RES
;
ERR ;
D CLOSE^%ZISTCP
U $P
Q "-1^"_$$EC^%ZOSV
;
CHECK ;Check server setup
N XPARSYS,XWBDEBUG,XWBOS,XWBT,XWNRBUF,XWBTIME,NEWJOB,XWBVER
W !,"This will check for some of the errors that can"
W !,"prevent the Broker from getting started.",!
D HOME^%ZIS
S XWBVER=1.108
D INIT^XWBTCPM
W !,"Debugging is set to ",$S(XWBDEBUG=1:"On",XWBDEBUG=2:"Verbose",XWBDEBUG=3:"Very Verbose",1:"Off")
D SETTIME^XWBTCPM(0)
W !,"Broker activity timeout is set to ",XWBTIME
S %ZIS="M",IOP="NULL" D ^%ZIS
I POP W !,"The NULL device is not setup correctly."
I 'POP D
. W !,"Checking can Write to null device"
. U IO W !,"TEST",!
. D ^%ZISC U IO W !,"The NULL device is OK."
I $T(SHARELIC^%ZOSV)="" W !,"The routine %ZOSV is missing the entry point 'SHARELIC'."
I $T(GETPEER^%ZOSV)="" W !,"The routine %ZOSV is missing the entry point 'GETPEER'."
I $G(XWBT("PCNT")),$T(COUNT^XUSCNT)="" W !,"The routine XUSCNT is missing on a GT.M system."
W !,"Checking if new JOB's can start."
S ^TMP("XWB",$J)=1 X "J HOLD^XWBTCPMT($J) H 1"
I $G(^TMP("XWB",$J))=1 W !,"Doesn't look like a new JOB could start!",!
S NEWJOB=$$NEWJOB^XWBTCPM()
W !,"New jobs are "_$S('NEWJOB:"not ",1:"")_"allowed."
W !,"Done with the checks.",!
K ^TMP("XWB",$J)
Q
;
HOLD(MJ) ;Show that a new job is allowed.
S ^TMP("XWB",MJ)=5
HANG 5
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBTCPMT 2700 printed Nov 22, 2024@17:47:29 Page 2
XWBTCPMT ;ISF/RWF - Routine to test a connection ;12/02/14 08:48
+1 ;;1.1;RPC BROKER;**43,49,53,64**;Mar 28, 1997;Build 12
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
CALL ;Interactive
+1 NEW IP,PORT,STAT
+2 DO HOME^%ZIS
+3 SET U="^"
SET DTIME=$$DTIME^XUP
+4 WRITE !,"Interactive Broker Test"
+5 READ !,"IP ADDRESS: ",IP:DTIME
+6 IF IP["^"
QUIT
+7 READ !,"PORT: ",PORT:DTIME
+8 IF PORT["^"
QUIT
+9 SET STAT=$$TEST(IP,PORT,1)
+10 USE $PRINCIPAL
+11 WRITE !,$SELECT(STAT>0:"Success, response: "_$PIECE(STAT,U,2),1:"Failed: "_$PIECE(STAT,U,2,9)),!
+12 QUIT
+13 ;
TEST(IP,PORT,TALK) ;
+1 NEW T1,T2,T3,T4,OS,RES,RES2,RES3
+2 SET OS=^%ZOSF("OS")
+3 ;p64
IF '$$VALIDATE^XLFIPV(IP)
SET IP=$$ADDRESS^XLFNSLK(IP)
+4 ;p64
IF '$$VALIDATE^XLFIPV(IP)
QUIT "-1^BAD IP"
+5 IF OS["OpenM"
XECUTE "S T1=$ZH"
+6 DO CALL^%ZISTCP(IP,PORT)
+7 IF OS["OpenM"
XECUTE "S T2=$ZH"
+8 IF POP
QUIT "-1^Failed to Connect"
+9 USE IO
+10 NEW $ETRAP
SET $ETRAP="G ERR^XWBTCPMT"
+11 ;TCPConnect
+12 WRITE "[XWB]10304"_$CHAR(10)_"TCPConnect50010127.0.0.1f00010f0024ISF-FORTW.vha.domain.extf"_$CHAR(4),@IOF
+13 READ RES:10
IF '$TEST
SET RES="-1^TIMEOUT"
GOTO EXIT
+14 IF OS["OpenM"
XECUTE "S T3=$ZH"
+15 WRITE "[XWB]11302"_$CHAR(1)_"0"_$CHAR(16)_"XUS SIGNON SETUP54f"_$CHAR(4),@IOF
+16 READ RES2:10
+17 IF OS["OpenM"
XECUTE "S T4=$ZH"
+18 WRITE "[XWB]10304"_$CHAR(5)_"#BYE#"_$CHAR(4),@IOF
+19 READ RES3:3
IF '$TEST
SET RES="-1^TIMEOUT after accept"
GOTO EXIT
+20 SET RES="1^"_RES_U_($GET(T2)-$GET(T1))_U_($GET(T3)-$GET(T2))_U_($GET(T4)-$GET(T3))
EXIT ;Close and Exit
+1 DO CLOSE^%ZISTCP
+2 QUIT RES
+3 ;
ERR ;
+1 DO CLOSE^%ZISTCP
+2 USE $PRINCIPAL
+3 QUIT "-1^"_$$EC^%ZOSV
+4 ;
CHECK ;Check server setup
+1 NEW XPARSYS,XWBDEBUG,XWBOS,XWBT,XWNRBUF,XWBTIME,NEWJOB,XWBVER
+2 WRITE !,"This will check for some of the errors that can"
+3 WRITE !,"prevent the Broker from getting started.",!
+4 DO HOME^%ZIS
+5 SET XWBVER=1.108
+6 DO INIT^XWBTCPM
+7 WRITE !,"Debugging is set to ",$SELECT(XWBDEBUG=1:"On",XWBDEBUG=2:"Verbose",XWBDEBUG=3:"Very Verbose",1:"Off")
+8 DO SETTIME^XWBTCPM(0)
+9 WRITE !,"Broker activity timeout is set to ",XWBTIME
+10 SET %ZIS="M"
SET IOP="NULL"
DO ^%ZIS
+11 IF POP
WRITE !,"The NULL device is not setup correctly."
+12 IF 'POP
Begin DoDot:1
+13 WRITE !,"Checking can Write to null device"
+14 USE IO
WRITE !,"TEST",!
+15 DO ^%ZISC
USE IO
WRITE !,"The NULL device is OK."
End DoDot:1
+16 IF $TEXT(SHARELIC^%ZOSV)=""
WRITE !,"The routine %ZOSV is missing the entry point 'SHARELIC'."
+17 IF $TEXT(GETPEER^%ZOSV)=""
WRITE !,"The routine %ZOSV is missing the entry point 'GETPEER'."
+18 IF $GET(XWBT("PCNT"))
IF $TEXT(COUNT^XUSCNT)=""
WRITE !,"The routine XUSCNT is missing on a GT.M system."
+19 WRITE !,"Checking if new JOB's can start."
+20 SET ^TMP("XWB",$JOB)=1
XECUTE "J HOLD^XWBTCPMT($J) H 1"
+21 IF $GET(^TMP("XWB",$JOB))=1
WRITE !,"Doesn't look like a new JOB could start!",!
+22 SET NEWJOB=$$NEWJOB^XWBTCPM()
+23 WRITE !,"New jobs are "_$SELECT('NEWJOB:"not ",1:"")_"allowed."
+24 WRITE !,"Done with the checks.",!
+25 KILL ^TMP("XWB",$JOB)
+26 QUIT
+27 ;
HOLD(MJ) ;Show that a new job is allowed.
+1 SET ^TMP("XWB",MJ)=5
+2 HANG 5
+3 QUIT
