XQCS ;SEA/Luke - Client/Server Utilities ;05/09/2011
;;8.0;KERNEL;**15,28,82,116,115,177,188,157,253,569**;Jul 10, 1995;Build 4
;
CHK(XQUSR,XQOPT,XQRPC) ;Check to see if this user can run this RPC from
;this option. Called by XWBSEC and XUSRB.
;
;Input: XQUSR-DUZ of user
; XQOPT - name or IEN of the option
; XQRPC - name or IEN of the remote procedure. If this
; variable is null no check is made to see if a
; procedure is allowed. That is, we only look
; to see if the option is there and if the user
; has been assigned access to it.
;
;Output: XQMES - returned as 1 if the user is allowed to use this
; option (and RPC is valid if XQRPC input variable is not
; null), or as a message string explaining why the option
; or RPC is not allowed.
;
;Rules: If M code exsists in ^DIC(19,option#,"RPC",rpc#,1) the
; RULES field for a corresponding RPC, the software sets
; the flag XQRPCOK to 1 and executes the field's code.
; If the flag is returned as less than 1, the request for
; use of that RPC is denied. Rules are written by the
; package developer and are not required.
;
;
N %,X,XQCY0,XQDIC,XQKEY,XQRPCOK,XQPM,XQSM,XQSMY,XQYSAV
;
S XQMES=1
D OPT I 'XQMES Q XQMES
I ($G(XQY0)'="XUS SIGNON")&(XQUSR>0) D USER I 'XQMES Q XQMES
S %=$G(XQRPC) I %]"" S XQRPC=% D RPC I 'XQMES Q XQMES
Q XQMES
;
;
OPT ;See if the option is there and is a broker type option
I XQOPT'=+XQOPT S XQOPT=$O(^DIC(19,"B",XQOPT,0))
I XQOPT'>0 S XQMES="No such option in the ""B"" cross reference of the Option File." Q
I $G(MODE)="CHECK" D OPT1 Q
I '$D(^TMP("XQCS",$J)) S XQOPT=$$OPTLK($P(^DIC(19,XQOPT,0),U))
Q
OPT1 ;
I XQOPT'=+XQOPT S XQOPT=$O(^DIC(19,"B",XQOPT,0)) I XQOPT'>0 S XQMES="No such option in the ""B"" cross reference of the Option File." Q
I '$D(^DIC(19,XQOPT,0)) S XQMES="No such option in the Option File." Q
;I $P(^DIC(19,XQOPT,0),U,4)'="B" S XQMES="This option is not a Client/Server-type option." Q
;
;Check for Out-Of-Order, etc. Patch XU*8*38 7/16/96
;
S XQCY0=^DIC(19,XQOPT,0) ;W XQCY0
I $L($P(XQCY0,U,3)) S XQMES="Option out of order with message: "_$P(XQCY0,U,3)_"." Q
I $L($P(XQCY0,U,6)) S %=$P(XQCY0,U,6) I '$D(^XUSEC(%,DUZ)) S XQMES="Option locked, "_$P(^VA(200,DUZ,0),U)_" does not hold the key." Q
I $L($P(XQCY0,U,16)) I $D(^DIC(19,XQOPT,3)),^(3)]"" S %=^(3) I $D(^XUSEC(%,DUZ)) S XQMES="Reverse lock, "_$P(^VA(200,DUZ,0),U)_" holds the key." Q
I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S (XX,X)=% D XQO^XQ92 I X=""!(XX'=X) S XQMES="This option is time restricted." Q
I $D(^DIC(19,+XQOPT,3.91)),$P(^(3.91,0),U,4)>1 S:$D(XQY) XQYSAV=XQY D ^XQDATE S X=%,XQY=+XQOPT D ^XQ92 S:$D(XQYSAV) XQY=XQYSAV I X="" S XQMES="This option is time restricted." Q
;End patch 38
Q
;
OPTLK(V) ;Lookup a Option in the file, Return it's IEN
N XQOPT S XQOPT=$O(^DIC(19,"B",V,0)) I XQOPT'>0 Q ""
I '$D(XQMES) N XQMES S XQMES=1
N XQCS,XQCSO S XQCS(XQOPT)="" N XQOPT K ^TMP("XQCS",$J)
F S XQOPT=$O(XQCS("")) Q:XQOPT="" K XQCS(XQOPT) I '$D(XQCSO(XQOPT)) D OPT1 D:XQMES I 'XQMES Q
. N I,J F I=0:0 S I=$O(^DIC(19,XQOPT,"RPC",I)) Q:I'>0 K J S J=^(I,0) S:$D(^(1)) J(1)=^(1) I '$D(^TMP("XQCS",$J,+J)) S ^TMP("XQCS",$J,+J,0)=J I $D(J(1)) S ^(1)=J(1)
. F I=0:0 S I=$O(^DIC(19,XQOPT,10,I)) Q:I'>0 S J=+^(I,0) I $P(^DIC(19,J,0),U,4)="B" S XQCS(J)=""
. S XQCSO(XQOPT)=""
. Q
Q $O(^DIC(19,"B",V,0))
;
RPC ;See if rpc exsists, is registered, is locked, etc.
; I '$D(^DIC(19,XQOPT,"RPC",0)) S XQMES="No RPC subfile defined for the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
; I $P(^DIC(19,XQOPT,"RPC",0),U,4)<1 S XQMES="No remote procedure calls registered for the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
I XQRPC'=+XQRPC S XQRPC=$O(^XWB(8994,"B",XQRPC,0)) I XQRPC'>0 S XQMES="No RPC by that name in the ""B"" cross-reference of the Remote Procedure File." Q
I '$D(^XWB(8994,XQRPC,0)) S XQMES="No such procedure in the Remote Procedure File." Q
; I '$D(^DIC(19,XQOPT,"RPC","B",XQRPC)) S XQMES="The remote procedure "_$P(^XWB(8994,XQRPC,0),U)_" is not registered to the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
I '$D(^TMP("XQCS",$J,XQRPC)) S XQMES="The remote procedure "_$P(^XWB(8994,XQRPC,0),U)_" is not registered to the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
; S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0)),XQKEY=$P(^DIC(19,XQOPT,"RPC",%,0),U,2)
S XQKEY=$P(^TMP("XQCS",$J,XQRPC,0),U,2)
I $L(XQKEY) I '$D(^XUSEC(XQKEY,XQUSR)) S XQMES="Remote procedure is locked." Q
;
RULES ;Check the rules for this RPC
;S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0))
;I $D(^DIC(19,XQOPT,"RPC",%,1)),$L(^(1)) D
I $D(^TMP("XQCS",$J,XQRPC,1)),$L(^(1)) D
. S XQRPCOK=1
. X ^TMP("XQCS",$J,XQRPC,1)
. I XQRPCOK<1 S XQMES="Remote procedure request failed rules test."
. Q
Q
;
;
;
USER ;See if XQUSR has been assigned access this option or not
;
N XQYES
S XQMES=1,(XQSMY,%,XQYES)=0
;
TOP ;See if XQOPT is on top level of a tree: primary, secondary, or common
S XQPM=+$G(^VA(200,XQUSR,201)) I XQOPT=XQPM Q
;
;Check the Common Options (XUCOMMAND)
I $D(^DIC(19,"B","XUCOMMAND")) D
. N XQCOM
. S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0))
. I $D(^DIC(19,XQCOM,10,"B",XQOPT)) S XQYES=1
. I XQYES Q
. I '$D(^XUTL("XQO","PXU",0)) S %=$$BUILD("PXU")
. I $D(^XUTL("XQO","PXU","^",XQOPT)) S XQYES=1
. Q
I XQYES Q
;
;
I $D(^VA(200,XQUSR,203,0)),$P(^(0),U,4)>0 S XQSMY=1 D
.;** P569 START CJM
.N DUZ S DUZ=XQUSR
.;** P569 END CJM
. S XQDIC="U"_XQUSR I $S('$D(^XUTL("XQO",XQDIC,0)):1,'$D(^VA(200,XQUSR,203.1)):1,1:^VA(200,XQUSR,203.1)'=$P(^XUTL("XQO",XQDIC,0),U,2)) D ^XQSET
. S (XQSM,%)=0
. F Q:% S XQSM=$O(^XUTL("XQO",XQDIC,"^",XQSM)) Q:XQSM="" I XQSM=XQOPT S XQYES=1 Q
. Q
I XQYES Q
;
DEEP ;See if it's under the top somewhere - start with primary tree
I XQPM>0 D
.S XQDIC="P"_XQPM
.S XQYES=$S($D(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$D(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
.Q
I XQYES Q
;
;Check secondary trees
S (XQSM,%)=0
I XQSMY F Q:XQYES S XQSM=$O(^XUTL("XQO","U"_XQUSR,"^",XQSM)) Q:XQSM="" D
.S XQDIC="P"_XQSM
.S XQYES=$S($D(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$D(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
. Q
I XQYES Q
;
I $L(XQMES<5) S XQMES="User "_$P(^VA(200,XQUSR,0),U)_" does not have access to option "_$P(^DIC(19,XQOPT,0),U)
Q
;
;End of main program
;
BUILD(XQDIC) ;A missing ^XUTL node brings us here
I $D(^DIC(19,"AXQ",XQDIC)) D
.L +^DIC(19,"AXQ",XQDIC):5
.I '$D(^XUTL("XQO",XQDIC)) M ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC)
.L -^DIC(19,"AXQ",XQDIC)
.Q
I $D(^XUTL("XQO",XQDIC,0)) Q 1
;
;If they are not even in ^DIC the make them from scratch
I '$D(^DIC(19,"AXQ",XQDIC)) D
.;D REACT^XQ84(DUZ)
.S XQMES="Your menus are being rebuilt. Please try again later."
Q 0
XQCS ;SEA/Luke - Client/Server Utilities ;05/09/2011
+1 ;;8.0;KERNEL;**15,28,82,116,115,177,188,157,253,569**;Jul 10, 1995;Build 4
+2 ;
CHK(XQUSR,XQOPT,XQRPC) ;Check to see if this user can run this RPC from
+1 ;this option. Called by XWBSEC and XUSRB.
+2 ;
+3 ;Input: XQUSR-DUZ of user
+4 ; XQOPT - name or IEN of the option
+5 ; XQRPC - name or IEN of the remote procedure. If this
+6 ; variable is null no check is made to see if a
+7 ; procedure is allowed. That is, we only look
+8 ; to see if the option is there and if the user
+9 ; has been assigned access to it.
+10 ;
+11 ;Output: XQMES - returned as 1 if the user is allowed to use this
+12 ; option (and RPC is valid if XQRPC input variable is not
+13 ; null), or as a message string explaining why the option
+14 ; or RPC is not allowed.
+15 ;
+16 ;Rules: If M code exsists in ^DIC(19,option#,"RPC",rpc#,1) the
+17 ; RULES field for a corresponding RPC, the software sets
+18 ; the flag XQRPCOK to 1 and executes the field's code.
+19 ; If the flag is returned as less than 1, the request for
+20 ; use of that RPC is denied. Rules are written by the
+21 ; package developer and are not required.
+22 ;
+23 ;
+24 NEW %,X,XQCY0,XQDIC,XQKEY,XQRPCOK,XQPM,XQSM,XQSMY,XQYSAV
+25 ;
+26 SET XQMES=1
+27 DO OPT
IF 'XQMES
QUIT XQMES
+28 IF ($GET(XQY0)'="XUS SIGNON")&(XQUSR>0)
DO USER
IF 'XQMES
QUIT XQMES
+29 SET %=$GET(XQRPC)
IF %]""
SET XQRPC=%
DO RPC
IF 'XQMES
QUIT XQMES
+30 QUIT XQMES
+31 ;
+32 ;
OPT ;See if the option is there and is a broker type option
+1 IF XQOPT'=+XQOPT
SET XQOPT=$ORDER(^DIC(19,"B",XQOPT,0))
+2 IF XQOPT'>0
SET XQMES="No such option in the ""B"" cross reference of the Option File."
QUIT
+3 IF $GET(MODE)="CHECK"
DO OPT1
QUIT
+4 IF '$DATA(^TMP("XQCS",$JOB))
SET XQOPT=$$OPTLK($PIECE(^DIC(19,XQOPT,0),U))
+5 QUIT
OPT1 ;
+1 IF XQOPT'=+XQOPT
SET XQOPT=$ORDER(^DIC(19,"B",XQOPT,0))
IF XQOPT'>0
SET XQMES="No such option in the ""B"" cross reference of the Option File."
QUIT
+2 IF '$DATA(^DIC(19,XQOPT,0))
SET XQMES="No such option in the Option File."
QUIT
+3 ;I $P(^DIC(19,XQOPT,0),U,4)'="B" S XQMES="This option is not a Client/Server-type option." Q
+4 ;
+5 ;Check for Out-Of-Order, etc. Patch XU*8*38 7/16/96
+6 ;
+7 ;W XQCY0
SET XQCY0=^DIC(19,XQOPT,0)
+8 IF $LENGTH($PIECE(XQCY0,U,3))
SET XQMES="Option out of order with message: "_$PIECE(XQCY0,U,3)_"."
QUIT
+9 IF $LENGTH($PIECE(XQCY0,U,6))
SET %=$PIECE(XQCY0,U,6)
IF '$DATA(^XUSEC(%,DUZ))
SET XQMES="Option locked, "_$PIECE(^VA(200,DUZ,0),U)_" does not hold the key."
QUIT
+10 IF $LENGTH($PIECE(XQCY0,U,16))
IF $DATA(^DIC(19,XQOPT,3))
IF ^(3)]""
SET %=^(3)
IF $DATA(^XUSEC(%,DUZ))
SET XQMES="Reverse lock, "_$PIECE(^VA(200,DUZ,0),U)_" holds the key."
QUIT
+11 IF $LENGTH($PIECE(XQCY0,U,9))
SET XQZ=$PIECE(XQCY0,U,9)
DO ^XQDATE
SET (XX,X)=%
DO XQO^XQ92
IF X=""!(XX'=X)
SET XQMES="This option is time restricted."
QUIT
+12 IF $DATA(^DIC(19,+XQOPT,3.91))
IF $PIECE(^(3.91,0),U,4)>1
IF $DATA(XQY)
SET XQYSAV=XQY
DO ^XQDATE
SET X=%
SET XQY=+XQOPT
DO ^XQ92
IF $DATA(XQYSAV)
SET XQY=XQYSAV
IF X=""
SET XQMES="This option is time restricted."
QUIT
+13 ;End patch 38
+14 QUIT
+15 ;
OPTLK(V) ;Lookup a Option in the file, Return it's IEN
+1 NEW XQOPT
SET XQOPT=$ORDER(^DIC(19,"B",V,0))
IF XQOPT'>0
QUIT ""
+2 IF '$DATA(XQMES)
NEW XQMES
SET XQMES=1
+3 NEW XQCS,XQCSO
SET XQCS(XQOPT)=""
NEW XQOPT
KILL ^TMP("XQCS",$JOB)
+4 FOR
SET XQOPT=$ORDER(XQCS(""))
IF XQOPT=""
QUIT
KILL XQCS(XQOPT)
IF '$DATA(XQCSO(XQOPT))
DO OPT1
IF XQMES
Begin DoDot:1
+5 NEW I,J
FOR I=0:0
SET I=$ORDER(^DIC(19,XQOPT,"RPC",I))
IF I'>0
QUIT
KILL J
SET J=^(I,0)
IF $DATA(^(1))
SET J(1)=^(1)
IF '$DATA(^TMP("XQCS",$JOB,+J))
SET ^TMP("XQCS",$JOB,+J,0)=J
IF $DATA(J(1))
SET ^(1)=J(1)
+6 FOR I=0:0
SET I=$ORDER(^DIC(19,XQOPT,10,I))
IF I'>0
QUIT
SET J=+^(I,0)
IF $PIECE(^DIC(19,J,0),U,4)="B"
SET XQCS(J)=""
+7 SET XQCSO(XQOPT)=""
+8 QUIT
End DoDot:1
IF 'XQMES
QUIT
+9 QUIT $ORDER(^DIC(19,"B",V,0))
+10 ;
RPC ;See if rpc exsists, is registered, is locked, etc.
+1 ; I '$D(^DIC(19,XQOPT,"RPC",0)) S XQMES="No RPC subfile defined for the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
+2 ; I $P(^DIC(19,XQOPT,"RPC",0),U,4)<1 S XQMES="No remote procedure calls registered for the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
+3 IF XQRPC'=+XQRPC
SET XQRPC=$ORDER(^XWB(8994,"B",XQRPC,0))
IF XQRPC'>0
SET XQMES="No RPC by that name in the ""B"" cross-reference of the Remote Procedure File."
QUIT
+4 IF '$DATA(^XWB(8994,XQRPC,0))
SET XQMES="No such procedure in the Remote Procedure File."
QUIT
+5 ; I '$D(^DIC(19,XQOPT,"RPC","B",XQRPC)) S XQMES="The remote procedure "_$P(^XWB(8994,XQRPC,0),U)_" is not registered to the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
+6 IF '$DATA(^TMP("XQCS",$JOB,XQRPC))
SET XQMES="The remote procedure "_$PIECE(^XWB(8994,XQRPC,0),U)_" is not registered to the option "_$PIECE(^DIC(19,XQOPT,0),U)_"."
QUIT
+7 ; S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0)),XQKEY=$P(^DIC(19,XQOPT,"RPC",%,0),U,2)
+8 SET XQKEY=$PIECE(^TMP("XQCS",$JOB,XQRPC,0),U,2)
+9 IF $LENGTH(XQKEY)
IF '$DATA(^XUSEC(XQKEY,XQUSR))
SET XQMES="Remote procedure is locked."
QUIT
+10 ;
RULES ;Check the rules for this RPC
+1 ;S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0))
+2 ;I $D(^DIC(19,XQOPT,"RPC",%,1)),$L(^(1)) D
+3 IF $DATA(^TMP("XQCS",$JOB,XQRPC,1))
IF $LENGTH(^(1))
Begin DoDot:1
+4 SET XQRPCOK=1
+5 XECUTE ^TMP("XQCS",$JOB,XQRPC,1)
+6 IF XQRPCOK<1
SET XQMES="Remote procedure request failed rules test."
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
+10 ;
+11 ;
USER ;See if XQUSR has been assigned access this option or not
+1 ;
+2 NEW XQYES
+3 SET XQMES=1
SET (XQSMY,%,XQYES)=0
+4 ;
TOP ;See if XQOPT is on top level of a tree: primary, secondary, or common
+1 SET XQPM=+$GET(^VA(200,XQUSR,201))
IF XQOPT=XQPM
QUIT
+2 ;
+3 ;Check the Common Options (XUCOMMAND)
+4 IF $DATA(^DIC(19,"B","XUCOMMAND"))
Begin DoDot:1
+5 NEW XQCOM
+6 SET XQCOM=$ORDER(^DIC(19,"B","XUCOMMAND",0))
+7 IF $DATA(^DIC(19,XQCOM,10,"B",XQOPT))
SET XQYES=1
+8 IF XQYES
QUIT
+9 IF '$DATA(^XUTL("XQO","PXU",0))
SET %=$$BUILD("PXU")
+10 IF $DATA(^XUTL("XQO","PXU","^",XQOPT))
SET XQYES=1
+11 QUIT
End DoDot:1
+12 IF XQYES
QUIT
+13 ;
+14 ;
+15 IF $DATA(^VA(200,XQUSR,203,0))
IF $PIECE(^(0),U,4)>0
SET XQSMY=1
Begin DoDot:1
+16 ;** P569 START CJM
+17 NEW DUZ
SET DUZ=XQUSR
+18 ;** P569 END CJM
+19 SET XQDIC="U"_XQUSR
IF $SELECT('$DATA(^XUTL("XQO",XQDIC,0)):1,'$DATA(^VA(200,XQUSR,203.1)):1,1:^VA(200,XQUSR,203.1)'=$PIECE(^XUTL("XQO",XQDIC,0),U,2))
DO ^XQSET
+20 SET (XQSM,%)=0
+21 FOR
IF %
QUIT
SET XQSM=$ORDER(^XUTL("XQO",XQDIC,"^",XQSM))
IF XQSM=""
QUIT
IF XQSM=XQOPT
SET XQYES=1
QUIT
+22 QUIT
End DoDot:1
+23 IF XQYES
QUIT
+24 ;
DEEP ;See if it's under the top somewhere - start with primary tree
+1 IF XQPM>0
Begin DoDot:1
+2 SET XQDIC="P"_XQPM
+3 SET XQYES=$SELECT($DATA(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$DATA(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
+4 QUIT
End DoDot:1
+5 IF XQYES
QUIT
+6 ;
+7 ;Check secondary trees
+8 SET (XQSM,%)=0
+9 IF XQSMY
FOR
IF XQYES
QUIT
SET XQSM=$ORDER(^XUTL("XQO","U"_XQUSR,"^",XQSM))
IF XQSM=""
QUIT
Begin DoDot:1
+10 SET XQDIC="P"_XQSM
+11 SET XQYES=$SELECT($DATA(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$DATA(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
+12 QUIT
End DoDot:1
+13 IF XQYES
QUIT
+14 ;
+15 IF $LENGTH(XQMES<5)
SET XQMES="User "_$PIECE(^VA(200,XQUSR,0),U)_" does not have access to option "_$PIECE(^DIC(19,XQOPT,0),U)
+16 QUIT
+17 ;
+18 ;End of main program
+19 ;
BUILD(XQDIC) ;A missing ^XUTL node brings us here
+1 IF $DATA(^DIC(19,"AXQ",XQDIC))
Begin DoDot:1
+2 LOCK +^DIC(19,"AXQ",XQDIC):5
+3 IF '$DATA(^XUTL("XQO",XQDIC))
MERGE ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC)
+4 LOCK -^DIC(19,"AXQ",XQDIC)
+5 QUIT
End DoDot:1
+6 IF $DATA(^XUTL("XQO",XQDIC,0))
QUIT 1
+7 ;
+8 ;If they are not even in ^DIC the make them from scratch
+9 IF '$DATA(^DIC(19,"AXQ",XQDIC))
Begin DoDot:1
+10 ;D REACT^XQ84(DUZ)
+11 SET XQMES="Your menus are being rebuilt. Please try again later."
End DoDot:1
+12 QUIT 0
