- XWBTCPMT ;ISF/RWF - Routine to test a connection ;10/07/09 16:37
- ;;1.1;RPC BROKER;**43,49,53**;Mar 28, 1997;Build 5
- 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 IP'?1.3N1P1.3N1P1.3N1P1.3N S IP=$$ADDRESS^XLFNSLK(IP)
- I IP'?1.3N1P1.3N1P1.3N1P1.3N Q "-1^BAD IP"
- 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)_"TCPConnect5001010.6.17.95f00010f0024ISF-FORTW.vha.med.va.govf"_$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 prevent the Broker"
- W !,"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
- XWBTCPMT ;ISF/RWF - Routine to test a connection ;10/07/09 16:37
- +1 ;;1.1;RPC BROKER;**43,49,53**;Mar 28, 1997;Build 5
- 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 IF IP'?1.3N1P1.3N1P1.3N1P1.3N
- SET IP=$$ADDRESS^XLFNSLK(IP)
- +4 IF IP'?1.3N1P1.3N1P1.3N1P1.3N
- 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)_"TCPConnect5001010.6.17.95f00010f0024ISF-FORTW.vha.med.va.govf"_$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 prevent the Broker"
- +3 WRITE !,"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
