XULM ;IRMFO-ALB/CJM/SWO/RGG - KERNEL LOCK MANAGER ; 8/25/20 7:35am
;;8.0;KERNEL;**608,736**;Jul 10, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified
;
; ******************************************************************
; * *
; * The Kernel Lock Manager is based on the VistA Lock Manager *
; * developed by Tommy Martin. *
; * *
; ******************************************************************
;
;
MAIN ;Main Program
N XUPARMS,ERROR,NODE,WHERETO,RESULT,VALMIOXY,VALMSGR,VALMWD,XWBCRLFL,NIO
;
N $ETRAP,$ESTACK S $ETRAP="G ERROR^XULM"
;
I ($$VERSION^%ZOSV(1)'["Cache")&($$VERSION^%ZOSV(1)'["IRIS") W !,"This application is for Cache or IRIS systems only!" D PAUSE^XULMU QUIT
;
;Automatic update of HOSTS IP addresses
;D GETIP^XULMU
;
I '$$GETPARMS^XULMP(.XUPARMS,.ERROR) W:$L($G(ERROR)) !,ERROR Q
I 'XUPARMS("ON?") W "This application has been disabled. Please contact the application manager.",!! D PAUSE^XULMU Q
S XUPARMS("LOCKS")=$NA(^XTMP("XULM",$J,"LOCKS",0)) ;location where lock table is placed
S XUPARMS("LOCK INDICES")=$NA(^XTMP("XULM",$J,"LOCK IDX",0)) ;indices on @XUPARMS@(LOCKS)
I (XUPARMS("NODES")>1)!'$D(XUPARMS("NODES",$$NODE^XULMU)) D Q:ERROR
.N LOGIN
.I '$$LOGIN(.LOGIN,.ERROR) W:$L(ERROR) !,ERROR S ERROR=1 Q
.S XUPARMS("LOGIN")=LOGIN
Q:'$$GETLOCKS(.XUPARMS)
W !!,"Building the display screen...."
D
.N IDX,LOCKS,XUENTRY,XULMEXIT,XUTOPIC
.S XULMEXIT=0
.S LOCKS=XUPARMS("LOCKS"),IDX=XUPARMS("LOCK INDICES")
.D EN^VALM("XULM LOCK MANAGER")
;
K ^XTMP("XULM",$J)
D FULL^VALM1
Q
;
GETLOCKS(PARMS) ; query each & every node for its lock table
N NODE,QUIT,IDX,LOCKS
S LOCKS=PARMS("LOCKS"),IDX=PARMS("LOCK INDICES")
K @LOCKS,@IDX,PARMS("REPORTING NODES")
W !!,"Compiling the locks..."
S NODE="",QUIT=0
F S NODE=$O(PARMS("NODES",NODE)) Q:NODE="" D Q:QUIT
.I $$SAMENODE^XULMU(NODE) D
..;
..;Don't need the M-to-M broker to run RPC on this node!
..I $$LOCKS^XULMRPC("",LOCKS,,0) S PARMS("REPORTING NODES",$$NODE^XULMU)=""
.E D
..;
..;need to use the broker
..N CONNECT,ERROR,RPTNODE
..N $ETRAP,$ESTACK S $ETRAP="G ERROR2^XULM"
..S CONNECT=0
..L +@LOCKS@("XULM REPORTED NODE"):1 L -@LOCKS@("XULM REPORTED NODE")
..K @LOCKS@("XULM REPORTED NODE")
..L +@LOCKS@("XULM REPORTED NODE"):1 L -@LOCKS@("XULM REPORTED NODE")
..D
...S CONNECT=$$LOCKRPC(NODE,PARMS("NODES",NODE,"IP ADDRESS"),PARMS("NODES",NODE,"PORT"),PARMS("LOGIN"),LOCKS,.ERROR)
...I CONNECT D
....L +@LOCKS@("XULM REPORTED NODE"):1 L -@LOCKS@("XULM REPORTED NODE")
....I '$L($G(@LOCKS@("XULM REPORTED NODE"))) D
.....N I F I=1:1:5 Q:$L($G(@LOCKS@("XULM REPORTED NODE")))
....S RPTNODE=$G(@LOCKS@("XULM REPORTED NODE"))
....Q:'$L(RPTNODE)
....I NODE'=RPTNODE,'$D(PARMS("REPORTING NODES",RPTNODE)) D
.....N DA,DATA
.....S DA(1)=1,DA=PARMS("NODES",NODE)
.....S DATA(.01)=RPTNODE
.....D UPD^XULMU(8993.11,.DA,.DATA)
.....M PARMS("NODES",RPTNODE)=PARMS("NODES",NODE)
.....K PARMS("NODES",NODE)
....S PARMS("REPORTING NODES",RPTNODE)=""
..I 'CONNECT,'$D(PARMS("REPORTING NODES",NODE)) W !,"Failed to connect to node '"_NODE_"': ",ERROR I '$$ASKYESNO^XULMU("Continue with lock display","YES") S QUIT=1 Q
;
;
;match against the LOCK DICTIONARY and set indices
D:'QUIT
.N LOCK,OWNER,PID,NODE
.S LOCK=""
.L +@LOCKS:5 L -@LOCKS
.F S LOCK=$O(@LOCKS@(LOCK)) Q:LOCK="" D
..;
..S NODE=""
..F S NODE=$O(@LOCKS@(LOCK,NODE)) Q:NODE="" D
...;set the OWNER and PID index
...S OWNER=$P(@LOCKS@(LOCK,NODE,"OWNER"),"^",2)
...S:$L(OWNER) @IDX@("OWNER",OWNER_"^"_+@LOCKS@(LOCK,NODE,"OWNER"),LOCK,NODE)=""
...S PID=@LOCKS@(LOCK,NODE,"PID")
...S:$L(PID) @IDX@("PID",PID,LOCK,NODE)="",@IDX@("PID",PID)=1+$G(@IDX@("PID",PID))
...;
...N TEMPLATE,FILES,VARS
...S TEMPLATE=$$FIND^XULMLD(LOCK,.FILES,.VARS)
...I TEMPLATE D
....S @LOCKS@(LOCK,NODE,"TEMPLATE")=TEMPLATE
....M @LOCKS@(LOCK,NODE,"FILES")=FILES,@LOCKS@(LOCK,NODE,"VARIABLES")=VARS
....;
....;set index on the file references
....S FILES="" F S FILES=$O(FILES(FILES)) Q:'FILES S @IDX@("FILE",FILES,LOCK,NODE)=""
Q 'QUIT
;
LOGIN(LOGIN,ERROR) ;
S ERROR=""
D
.N OPTION
.I '$D(DUZ)#2 S ERROR="Your DUZ is not defined." Q
.I '$D(^XUSEC("XULM LOCKS",DUZ)) S ERROR="You do not hold the XULM LOCKS security key." Q
.;
.; Check for user having context option
.S OPTION=$O(^DIC(19,"B","XULM RPC BROKER CONTEXT",0))
.I 'OPTION S ERROR="The application XULM RPC BROKER CONTEXT option was not found." Q
.I '$D(^VA(200,DUZ,203,"B",OPTION)) S ERROR="You do not have access to the XULM RPC BROKER CONTEXT option." Q
.;
Q:$L(ERROR) 0
Q $$ASKAV(.LOGIN)
;
ASKAV(LOGIN) ; Ask user for access and verify code, return in LOGIN
N OK,CNT,XUF,XUSTMP
D
.S (OK,XUF)=0
.S XUSTMP(51)="ACCESS CODE:",XUSTMP(52)="VERIFY CODE:"
.F CNT=1:1:3 D Q:OK
..W !!,"Please enter your VistA access and verify codes.",!
..X ^%ZOSF("EOFF") S LOGIN=$$ASKAV^XUS() X ^%ZOSF("EON")
..Q:LOGIN="^;^"
..S OK=$$CHECKAV^XUS(LOGIN)
..I OK=0 D Q
...W !,"Invalid access/verify code pair"
...I CNT<3,'$$ASKYESNO^XULMU("Try again","YES") S CNT=4
..;S ACCESS=$$ENCRYP^XUSRB1($P(LOGIN,";")),VERIFY=$$ENCRYP^XUSRB1($P(LOGIN,";",2))
Q OK
;
LOCKRPC(NODE,IP,PORT,LOGIN,GLOBAL,XULMERR) ;
;Run the XULM LOCKS RPC on the specified system
;
N TMP,DIVISION,XURESULT
K XULMERR S XULMERR=""
K ^TMP("XWBM2ME",$J,"ERROR")
;before trying to logon, check if port can be opened
I '$$TEST(NODE,IP,PORT) S XULMERR="RPC Server appears to not be running" Q 0
D
.I '$$CONNECT^XWBM2MC(PORT,IP,LOGIN) S XULMERR="Connection error: Port, IP or server logon error." Q
.I '$$SETCONTX^XWBM2MC("XULM RPC BROKER CONTEXT") S XULMERR="Type 'B' option does not exist on the VistA server." Q
.I '$$GETDIV^XWBM2MC("DIVISION") S XULMERR="Division error: Could not find the user's division." Q
.I '$$SETDIV^XWBM2MC(DIVISION(1)) S XULMERR="Division error: Could not setup the user's division." Q
.D
..S XULMERR="Unable to execute the remote procedure = 'XULM GET LOCK TABLE'!"
..S TMP($J,"TYPE")="STRING",TMP($J,"VALUE")=GLOBAL
..Q:'$$PARAM^XWBM2MC(1,$NA(TMP($J)))
..;
..S XURESULT=$NA(^XTMP("XULM",$J,"RPC RESULT",0)) ;@XURESULT is where the RPCs place a return value
..S TMP($J,"TYPE")="STRING",TMP($J,"VALUE")=XURESULT
..Q:'$$PARAM^XWBM2MC(2,$NA(TMP($J)))
..;
..Q:'$$CALLRPC^XWBM2MC("XULM GET LOCK TABLE",,1)
..S XULMERR=""
;
D CLOSE^XWBM2MC()
U $PRINCIPAL
D HOME^%ZIS
Q:$L(XULMERR) 0
Q 1
;
KILLRPC(IP,PORT,LOGIN,PID,ERROR) ;
;Run the XULM KILL PROCESS RPC on the specified system
;
N TMP,DIVISION,XURESULT
S XURESULT=$NA(^XTMP("XULM",$J,"RPC RESULT",0)) ;@XURESULT is where the RPCs place a return value
K ERROR S ERROR=""
D
.N ERRCNT S ERRCNT=0
.I '$$CONNECT^XWBM2MC(PORT,IP,LOGIN) S ERROR="Connection error: Port, IP or server logon error." Q
.I '$$SETCONTX^XWBM2MC("XULM RPC BROKER CONTEXT") S ERROR="Type 'B' option does not exist on the VistA server." Q
.I '$$GETDIV^XWBM2MC("DIVISION") S ERROR="Division error: Could not find the user's division." Q
.I '$$SETDIV^XWBM2MC(DIVISION(1)) S ERROR="Division error: Could not setup the user's division." Q
.D
..S TMP($J,"TYPE")="STRING",TMP($J,"VALUE")=PID
..I '$$PARAM^XWBM2MC(1,$NA(TMP($J))) S ERROR="Call to PARAM^XQBM2MC filed while trying to execute the remote procedure XULM KILL PROCESS,",ERROR(1)="PID="_PID Q
..;
..S TMP($J,"TYPE")="STRING",TMP($J,"VALUE")=XURESULT
..I '$$PARAM^XWBM2MC(2,$NA(TMP($J))) S ERROR="Call to PARAM^XQBM2MC failed while trying to execute the remote procedure XULM KILL PROCESS,",ERROR(1)="XURESULT="_XURESULT Q
..;
..I '$$CALLRPC^XWBM2MC("XULM KILL PROCESS",,1) S ERROR="Call to CALLRPC^XQBM2MC failed while trying to execute the remote procedure",ERROR(1)="XULM KILL PROCESS, PID="_PID_" ,XURESULT="_XURESULT Q
..S ERROR=""
;
D CLOSE^XWBM2MC()
U $PRINCIPAL
D HOME^%ZIS
Q:$L(ERROR) 0
Q 1
;
ERROR ;
S $ETRAP="Q:$QUIT """" Q"
K XUPARMS("LOGIN"),LOGIN,PARMS("LOGIN")
Q:$QUIT ""
Q
;
ERROR2 ;
S $ETRAP="Q:$QUIT """" Q"
S ERROR=$ZE
S $ECODE=""
S CONNECT=0
U $PRINCIPAL
Q:$QUIT "" Q
Q
TEST(NODE,IP,SOCK) ;Tests if the port can be opened - waits only 2 seconds.
;If not, asks user if he wants to try to connect anyway - can take
;60 seconds.
;
N POP,TO,OK
S TO=2
D CONT^%ZISTCP
S OK='POP
D CLOSE^%ZISTCP
U $PRINCIPAL
I 'OK D
.W !,"Node '"_NODE_"' does not appear to be a valid system name, please correct"
.W !,"if necessary. This node will not be included in the Lockmanager list."
.S OK=$$ASKYESNO^XULMU("Would you like to try to connect anyway (could take a long while)?","NO")
.I OK=0 K PARMS("NODE",NODE)
Q OK
EXIT ;clean up and exit
K ^XTMP("XULM",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXULM 9001 printed Oct 16, 2024@18:10:43 Page 2
XULM ;IRMFO-ALB/CJM/SWO/RGG - KERNEL LOCK MANAGER ; 8/25/20 7:35am
+1 ;;8.0;KERNEL;**608,736**;Jul 10, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ; ******************************************************************
+5 ; * *
+6 ; * The Kernel Lock Manager is based on the VistA Lock Manager *
+7 ; * developed by Tommy Martin. *
+8 ; * *
+9 ; ******************************************************************
+10 ;
+11 ;
MAIN ;Main Program
+1 NEW XUPARMS,ERROR,NODE,WHERETO,RESULT,VALMIOXY,VALMSGR,VALMWD,XWBCRLFL,NIO
+2 ;
+3 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERROR^XULM"
+4 ;
+5 IF ($$VERSION^%ZOSV(1)'["Cache")&($$VERSION^%ZOSV(1)'["IRIS")
WRITE !,"This application is for Cache or IRIS systems only!"
DO PAUSE^XULMU
QUIT
+6 ;
+7 ;Automatic update of HOSTS IP addresses
+8 ;D GETIP^XULMU
+9 ;
+10 IF '$$GETPARMS^XULMP(.XUPARMS,.ERROR)
if $LENGTH($GET(ERROR))
WRITE !,ERROR
QUIT
+11 IF 'XUPARMS("ON?")
WRITE "This application has been disabled. Please contact the application manager.",!!
DO PAUSE^XULMU
QUIT
+12 ;location where lock table is placed
SET XUPARMS("LOCKS")=$NAME(^XTMP("XULM",$JOB,"LOCKS",0))
+13 ;indices on @XUPARMS@(LOCKS)
SET XUPARMS("LOCK INDICES")=$NAME(^XTMP("XULM",$JOB,"LOCK IDX",0))
+14 IF (XUPARMS("NODES")>1)!'$DATA(XUPARMS("NODES",$$NODE^XULMU))
Begin DoDot:1
+15 NEW LOGIN
+16 IF '$$LOGIN(.LOGIN,.ERROR)
if $LENGTH(ERROR)
WRITE !,ERROR
SET ERROR=1
QUIT
+17 SET XUPARMS("LOGIN")=LOGIN
End DoDot:1
if ERROR
QUIT
+18 if '$$GETLOCKS(.XUPARMS)
QUIT
+19 WRITE !!,"Building the display screen...."
+20 Begin DoDot:1
+21 NEW IDX,LOCKS,XUENTRY,XULMEXIT,XUTOPIC
+22 SET XULMEXIT=0
+23 SET LOCKS=XUPARMS("LOCKS")
SET IDX=XUPARMS("LOCK INDICES")
+24 DO EN^VALM("XULM LOCK MANAGER")
End DoDot:1
+25 ;
+26 KILL ^XTMP("XULM",$JOB)
+27 DO FULL^VALM1
+28 QUIT
+29 ;
GETLOCKS(PARMS) ; query each & every node for its lock table
+1 NEW NODE,QUIT,IDX,LOCKS
+2 SET LOCKS=PARMS("LOCKS")
SET IDX=PARMS("LOCK INDICES")
+3 KILL @LOCKS,@IDX,PARMS("REPORTING NODES")
+4 WRITE !!,"Compiling the locks..."
+5 SET NODE=""
SET QUIT=0
+6 FOR
SET NODE=$ORDER(PARMS("NODES",NODE))
if NODE=""
QUIT
Begin DoDot:1
+7 IF $$SAMENODE^XULMU(NODE)
Begin DoDot:2
+8 ;
+9 ;Don't need the M-to-M broker to run RPC on this node!
+10 IF $$LOCKS^XULMRPC("",LOCKS,,0)
SET PARMS("REPORTING NODES",$$NODE^XULMU)=""
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 ;
+13 ;need to use the broker
+14 NEW CONNECT,ERROR,RPTNODE
+15 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERROR2^XULM"
+16 SET CONNECT=0
+17 LOCK +@LOCKS@("XULM REPORTED NODE"):1
LOCK -@LOCKS@("XULM REPORTED NODE")
+18 KILL @LOCKS@("XULM REPORTED NODE")
+19 LOCK +@LOCKS@("XULM REPORTED NODE"):1
LOCK -@LOCKS@("XULM REPORTED NODE")
+20 Begin DoDot:3
+21 SET CONNECT=$$LOCKRPC(NODE,PARMS("NODES",NODE,"IP ADDRESS"),PARMS("NODES",NODE,"PORT"),PARMS("LOGIN"),LOCKS,.ERROR)
+22 IF CONNECT
Begin DoDot:4
+23 LOCK +@LOCKS@("XULM REPORTED NODE"):1
LOCK -@LOCKS@("XULM REPORTED NODE")
+24 IF '$LENGTH($GET(@LOCKS@("XULM REPORTED NODE")))
Begin DoDot:5
+25 NEW I
FOR I=1:1:5
if $LENGTH($GET(@LOCKS@("XULM REPORTED NODE")))
QUIT
End DoDot:5
+26 SET RPTNODE=$GET(@LOCKS@("XULM REPORTED NODE"))
+27 if '$LENGTH(RPTNODE)
QUIT
+28 IF NODE'=RPTNODE
IF '$DATA(PARMS("REPORTING NODES",RPTNODE))
Begin DoDot:5
+29 NEW DA,DATA
+30 SET DA(1)=1
SET DA=PARMS("NODES",NODE)
+31 SET DATA(.01)=RPTNODE
+32 DO UPD^XULMU(8993.11,.DA,.DATA)
+33 MERGE PARMS("NODES",RPTNODE)=PARMS("NODES",NODE)
+34 KILL PARMS("NODES",NODE)
End DoDot:5
+35 SET PARMS("REPORTING NODES",RPTNODE)=""
End DoDot:4
End DoDot:3
+36 IF 'CONNECT
IF '$DATA(PARMS("REPORTING NODES",NODE))
WRITE !,"Failed to connect to node '"_NODE_"': ",ERROR
IF '$$ASKYESNO^XULMU("Continue with lock display","YES")
SET QUIT=1
QUIT
End DoDot:2
End DoDot:1
if QUIT
QUIT
+37 ;
+38 ;
+39 ;match against the LOCK DICTIONARY and set indices
+40 if 'QUIT
Begin DoDot:1
+41 NEW LOCK,OWNER,PID,NODE
+42 SET LOCK=""
+43 LOCK +@LOCKS:5
LOCK -@LOCKS
+44 FOR
SET LOCK=$ORDER(@LOCKS@(LOCK))
if LOCK=""
QUIT
Begin DoDot:2
+45 ;
+46 SET NODE=""
+47 FOR
SET NODE=$ORDER(@LOCKS@(LOCK,NODE))
if NODE=""
QUIT
Begin DoDot:3
+48 ;set the OWNER and PID index
+49 SET OWNER=$PIECE(@LOCKS@(LOCK,NODE,"OWNER"),"^",2)
+50 if $LENGTH(OWNER)
SET @IDX@("OWNER",OWNER_"^"_+@LOCKS@(LOCK,NODE,"OWNER"),LOCK,NODE)=""
+51 SET PID=@LOCKS@(LOCK,NODE,"PID")
+52 if $LENGTH(PID)
SET @IDX@("PID",PID,LOCK,NODE)=""
SET @IDX@("PID",PID)=1+$GET(@IDX@("PID",PID))
+53 ;
+54 NEW TEMPLATE,FILES,VARS
+55 SET TEMPLATE=$$FIND^XULMLD(LOCK,.FILES,.VARS)
+56 IF TEMPLATE
Begin DoDot:4
+57 SET @LOCKS@(LOCK,NODE,"TEMPLATE")=TEMPLATE
+58 MERGE @LOCKS@(LOCK,NODE,"FILES")=FILES,@LOCKS@(LOCK,NODE,"VARIABLES")=VARS
+59 ;
+60 ;set index on the file references
+61 SET FILES=""
FOR
SET FILES=$ORDER(FILES(FILES))
if 'FILES
QUIT
SET @IDX@("FILE",FILES,LOCK,NODE)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+62 QUIT 'QUIT
+63 ;
LOGIN(LOGIN,ERROR) ;
+1 SET ERROR=""
+2 Begin DoDot:1
+3 NEW OPTION
+4 IF '$DATA(DUZ)#2
SET ERROR="Your DUZ is not defined."
QUIT
+5 IF '$DATA(^XUSEC("XULM LOCKS",DUZ))
SET ERROR="You do not hold the XULM LOCKS security key."
QUIT
+6 ;
+7 ; Check for user having context option
+8 SET OPTION=$ORDER(^DIC(19,"B","XULM RPC BROKER CONTEXT",0))
+9 IF 'OPTION
SET ERROR="The application XULM RPC BROKER CONTEXT option was not found."
QUIT
+10 IF '$DATA(^VA(200,DUZ,203,"B",OPTION))
SET ERROR="You do not have access to the XULM RPC BROKER CONTEXT option."
QUIT
+11 ;
End DoDot:1
+12 if $LENGTH(ERROR)
QUIT 0
+13 QUIT $$ASKAV(.LOGIN)
+14 ;
ASKAV(LOGIN) ; Ask user for access and verify code, return in LOGIN
+1 NEW OK,CNT,XUF,XUSTMP
+2 Begin DoDot:1
+3 SET (OK,XUF)=0
+4 SET XUSTMP(51)="ACCESS CODE:"
SET XUSTMP(52)="VERIFY CODE:"
+5 FOR CNT=1:1:3
Begin DoDot:2
+6 WRITE !!,"Please enter your VistA access and verify codes.",!
+7 XECUTE ^%ZOSF("EOFF")
SET LOGIN=$$ASKAV^XUS()
XECUTE ^%ZOSF("EON")
+8 if LOGIN="^;^"
QUIT
+9 SET OK=$$CHECKAV^XUS(LOGIN)
+10 IF OK=0
Begin DoDot:3
+11 WRITE !,"Invalid access/verify code pair"
+12 IF CNT<3
IF '$$ASKYESNO^XULMU("Try again","YES")
SET CNT=4
End DoDot:3
QUIT
+13 ;S ACCESS=$$ENCRYP^XUSRB1($P(LOGIN,";")),VERIFY=$$ENCRYP^XUSRB1($P(LOGIN,";",2))
End DoDot:2
if OK
QUIT
End DoDot:1
+14 QUIT OK
+15 ;
LOCKRPC(NODE,IP,PORT,LOGIN,GLOBAL,XULMERR) ;
+1 ;Run the XULM LOCKS RPC on the specified system
+2 ;
+3 NEW TMP,DIVISION,XURESULT
+4 KILL XULMERR
SET XULMERR=""
+5 KILL ^TMP("XWBM2ME",$JOB,"ERROR")
+6 ;before trying to logon, check if port can be opened
+7 IF '$$TEST(NODE,IP,PORT)
SET XULMERR="RPC Server appears to not be running"
QUIT 0
+8 Begin DoDot:1
+9 IF '$$CONNECT^XWBM2MC(PORT,IP,LOGIN)
SET XULMERR="Connection error: Port, IP or server logon error."
QUIT
+10 IF '$$SETCONTX^XWBM2MC("XULM RPC BROKER CONTEXT")
SET XULMERR="Type 'B' option does not exist on the VistA server."
QUIT
+11 IF '$$GETDIV^XWBM2MC("DIVISION")
SET XULMERR="Division error: Could not find the user's division."
QUIT
+12 IF '$$SETDIV^XWBM2MC(DIVISION(1))
SET XULMERR="Division error: Could not setup the user's division."
QUIT
+13 Begin DoDot:2
+14 SET XULMERR="Unable to execute the remote procedure = 'XULM GET LOCK TABLE'!"
+15 SET TMP($JOB,"TYPE")="STRING"
SET TMP($JOB,"VALUE")=GLOBAL
+16 if '$$PARAM^XWBM2MC(1,$NAME(TMP($JOB)))
QUIT
+17 ;
+18 ;@XURESULT is where the RPCs place a return value
SET XURESULT=$NAME(^XTMP("XULM",$JOB,"RPC RESULT",0))
+19 SET TMP($JOB,"TYPE")="STRING"
SET TMP($JOB,"VALUE")=XURESULT
+20 if '$$PARAM^XWBM2MC(2,$NAME(TMP($JOB)))
QUIT
+21 ;
+22 if '$$CALLRPC^XWBM2MC("XULM GET LOCK TABLE",,1)
QUIT
+23 SET XULMERR=""
End DoDot:2
End DoDot:1
+24 ;
+25 DO CLOSE^XWBM2MC()
+26 USE $PRINCIPAL
+27 DO HOME^%ZIS
+28 if $LENGTH(XULMERR)
QUIT 0
+29 QUIT 1
+30 ;
KILLRPC(IP,PORT,LOGIN,PID,ERROR) ;
+1 ;Run the XULM KILL PROCESS RPC on the specified system
+2 ;
+3 NEW TMP,DIVISION,XURESULT
+4 ;@XURESULT is where the RPCs place a return value
SET XURESULT=$NAME(^XTMP("XULM",$JOB,"RPC RESULT",0))
+5 KILL ERROR
SET ERROR=""
+6 Begin DoDot:1
+7 NEW ERRCNT
SET ERRCNT=0
+8 IF '$$CONNECT^XWBM2MC(PORT,IP,LOGIN)
SET ERROR="Connection error: Port, IP or server logon error."
QUIT
+9 IF '$$SETCONTX^XWBM2MC("XULM RPC BROKER CONTEXT")
SET ERROR="Type 'B' option does not exist on the VistA server."
QUIT
+10 IF '$$GETDIV^XWBM2MC("DIVISION")
SET ERROR="Division error: Could not find the user's division."
QUIT
+11 IF '$$SETDIV^XWBM2MC(DIVISION(1))
SET ERROR="Division error: Could not setup the user's division."
QUIT
+12 Begin DoDot:2
+13 SET TMP($JOB,"TYPE")="STRING"
SET TMP($JOB,"VALUE")=PID
+14 IF '$$PARAM^XWBM2MC(1,$NAME(TMP($JOB)))
SET ERROR="Call to PARAM^XQBM2MC filed while trying to execute the remote procedure XULM KILL PROCESS,"
SET ERROR(1)="PID="_PID
QUIT
+15 ;
+16 SET TMP($JOB,"TYPE")="STRING"
SET TMP($JOB,"VALUE")=XURESULT
+17 IF '$$PARAM^XWBM2MC(2,$NAME(TMP($JOB)))
SET ERROR="Call to PARAM^XQBM2MC failed while trying to execute the remote procedure XULM KILL PROCESS,"
SET ERROR(1)="XURESULT="_XURESULT
QUIT
+18 ;
+19 IF '$$CALLRPC^XWBM2MC("XULM KILL PROCESS",,1)
SET ERROR="Call to CALLRPC^XQBM2MC failed while trying to execute the remote procedure"
SET ERROR(1)="XULM KILL PROCESS, PID="_PID_" ,XURESULT="_XURESULT
QUIT
+20 SET ERROR=""
End DoDot:2
End DoDot:1
+21 ;
+22 DO CLOSE^XWBM2MC()
+23 USE $PRINCIPAL
+24 DO HOME^%ZIS
+25 if $LENGTH(ERROR)
QUIT 0
+26 QUIT 1
+27 ;
ERROR ;
+1 SET $ETRAP="Q:$QUIT """" Q"
+2 KILL XUPARMS("LOGIN"),LOGIN,PARMS("LOGIN")
+3 if $QUIT
QUIT ""
+4 QUIT
+5 ;
ERROR2 ;
+1 SET $ETRAP="Q:$QUIT """" Q"
+2 SET ERROR=$ZE
+3 SET $ECODE=""
+4 SET CONNECT=0
+5 USE $PRINCIPAL
+6 if $QUIT
QUIT ""
QUIT
+7 QUIT
TEST(NODE,IP,SOCK) ;Tests if the port can be opened - waits only 2 seconds.
+1 ;If not, asks user if he wants to try to connect anyway - can take
+2 ;60 seconds.
+3 ;
+4 NEW POP,TO,OK
+5 SET TO=2
+6 DO CONT^%ZISTCP
+7 SET OK='POP
+8 DO CLOSE^%ZISTCP
+9 USE $PRINCIPAL
+10 IF 'OK
Begin DoDot:1
+11 WRITE !,"Node '"_NODE_"' does not appear to be a valid system name, please correct"
+12 WRITE !,"if necessary. This node will not be included in the Lockmanager list."
+13 SET OK=$$ASKYESNO^XULMU("Would you like to try to connect anyway (could take a long while)?","NO")
+14 IF OK=0
KILL PARMS("NODE",NODE)
End DoDot:1
+15 QUIT OK
EXIT ;clean up and exit
+1 KILL ^XTMP("XULM",$JOB)
+2 QUIT
