Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XQCS

XQCS.m

Go to the documentation of this file.
  1. XQCS ;SEA/Luke - Client/Server Utilities ;09/16/2016 10:11
  1. ;;8.0;KERNEL;**15,28,82,116,115,177,188,157,253,569,674**;Jul 10, 1995;Build 1
  1. ;
  1. CHK(XQUSR,XQOPT,XQRPC) ;Check to see if this user can run this RPC from
  1. ;this option. Called by XWBSEC and XUSRB.
  1. ;
  1. ;Input: XQUSR - DUZ of user
  1. ; XQOPT - name or IEN of the option
  1. ; XQRPC - name or IEN of the remote procedure. If this
  1. ; variable is null no check is made to see if a
  1. ; procedure is allowed. That is, we only look
  1. ; to see if the option is there and if the user
  1. ; has been assigned access to it.
  1. ;
  1. ;Output: XQMES - returned as 1 if the user is allowed to use this
  1. ; option (and RPC is valid if XQRPC input variable is not
  1. ; null), or as a message string explaining why the option
  1. ; or RPC is not allowed.
  1. ;
  1. ;Rules: If M code exists in ^DIC(19,option#,"RPC",rpc#,1) the
  1. ; RULES field for a corresponding RPC, the software sets
  1. ; the flag XQRPCOK to 1 and executes the field's code.
  1. ; If the flag is returned as less than 1, the request for
  1. ; use of that RPC is denied. Rules are written by the
  1. ; package developer and are not required.
  1. ;
  1. ;
  1. N %,X,XQCY0,XQDIC,XQKEY,XQRPCOK,XQPM,XQSM,XQSMY,XQYSAV
  1. ;
  1. I '$G(XQUSR) K ^TMP("XQCS",$J) ;p674 kill ^TMP global upon new session
  1. S XQMES=1
  1. D OPT I 'XQMES Q XQMES
  1. I ($G(XQY0)'="XUS SIGNON")&(XQUSR>0) D USER I 'XQMES Q XQMES
  1. S %=$G(XQRPC) I %]"" S XQRPC=% D RPC I 'XQMES Q XQMES
  1. Q XQMES
  1. ;
  1. ;
  1. OPT ;See if the option is there and is a broker type option
  1. I XQOPT'=+XQOPT S XQOPT=$O(^DIC(19,"B",XQOPT,0))
  1. I XQOPT'>0 S XQMES="No such option in the ""B"" cross reference of the Option File." Q
  1. I $G(MODE)="CHECK" D OPT1 Q
  1. I '$D(^TMP("XQCS",$J)) S XQOPT=$$OPTLK($P(^DIC(19,XQOPT,0),U))
  1. Q
  1. OPT1 ;
  1. 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
  1. I '$D(^DIC(19,XQOPT,0)) S XQMES="No such option in the Option File." Q
  1. ;I $P(^DIC(19,XQOPT,0),U,4)'="B" S XQMES="This option is not a Client/Server-type option." Q
  1. ;
  1. ;Check for Out-Of-Order, etc. Patch XU*8*38 7/16/96
  1. ;
  1. S XQCY0=^DIC(19,XQOPT,0) ;W XQCY0
  1. I $L($P(XQCY0,U,3)) S XQMES="Option out of order with message: "_$P(XQCY0,U,3)_"." Q
  1. 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
  1. 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
  1. 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
  1. 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
  1. ;End patch 38
  1. Q
  1. ;
  1. OPTLK(V) ;Lookup a Option in the file, Return it's IEN
  1. N XQOPT S XQOPT=$O(^DIC(19,"B",V,0)) I XQOPT'>0 Q ""
  1. I '$D(XQMES) N XQMES S XQMES=1
  1. N XQCS,XQCSO S XQCS(XQOPT)="" N XQOPT K ^TMP("XQCS",$J)
  1. F S XQOPT=$O(XQCS("")) Q:XQOPT="" K XQCS(XQOPT) I '$D(XQCSO(XQOPT)) D OPT1 D:XQMES I 'XQMES Q
  1. . 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)
  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)=""
  1. . S XQCSO(XQOPT)=""
  1. . Q
  1. Q $O(^DIC(19,"B",V,0))
  1. ;
  1. 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
  1. ; 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
  1. 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
  1. I '$D(^XWB(8994,XQRPC,0)) S XQMES="No such procedure in the Remote Procedure File." Q
  1. ; 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
  1. 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
  1. ; S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0)),XQKEY=$P(^DIC(19,XQOPT,"RPC",%,0),U,2)
  1. S XQKEY=$P(^TMP("XQCS",$J,XQRPC,0),U,2)
  1. I $L(XQKEY) I '$D(^XUSEC(XQKEY,XQUSR)) S XQMES="Remote procedure is locked." Q
  1. ;
  1. RULES ;Check the rules for this RPC
  1. ;S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0))
  1. ;I $D(^DIC(19,XQOPT,"RPC",%,1)),$L(^(1)) D
  1. I $D(^TMP("XQCS",$J,XQRPC,1)),$L(^(1)) D
  1. . S XQRPCOK=1
  1. . X ^TMP("XQCS",$J,XQRPC,1)
  1. . I XQRPCOK<1 S XQMES="Remote procedure request failed rules test."
  1. . Q
  1. Q
  1. ;
  1. ;
  1. ;
  1. USER ;See if XQUSR has been assigned access this option or not
  1. ;
  1. N XQYES
  1. S XQMES=1,(XQSMY,%,XQYES)=0
  1. ;
  1. TOP ;See if XQOPT is on top level of a tree: primary, secondary, or common
  1. S XQPM=+$G(^VA(200,XQUSR,201)) I XQOPT=XQPM Q
  1. ;
  1. ;Check the Common Options (XUCOMMAND)
  1. I $D(^DIC(19,"B","XUCOMMAND")) D
  1. . N XQCOM
  1. . S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0))
  1. . I $D(^DIC(19,XQCOM,10,"B",XQOPT)) S XQYES=1
  1. . I XQYES Q
  1. . I '$D(^XUTL("XQO","PXU",0)) S %=$$BUILD("PXU")
  1. . I $D(^XUTL("XQO","PXU","^",XQOPT)) S XQYES=1
  1. . Q
  1. I XQYES Q
  1. ;
  1. ;
  1. I $D(^VA(200,XQUSR,203,0)),$P(^(0),U,4)>0 S XQSMY=1 D
  1. .;** P569 START CJM
  1. .N DUZ S DUZ=XQUSR
  1. .;** P569 END CJM
  1. . 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
  1. . S (XQSM,%)=0
  1. . F Q:% S XQSM=$O(^XUTL("XQO",XQDIC,"^",XQSM)) Q:XQSM="" I XQSM=XQOPT S XQYES=1 Q
  1. . Q
  1. I XQYES Q
  1. ;
  1. DEEP ;See if it's under the top somewhere - start with primary tree
  1. I XQPM>0 D
  1. .S XQDIC="P"_XQPM
  1. .S XQYES=$S($D(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$D(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
  1. .Q
  1. I XQYES Q
  1. ;
  1. ;Check secondary trees
  1. S (XQSM,%)=0
  1. I XQSMY F Q:XQYES S XQSM=$O(^XUTL("XQO","U"_XQUSR,"^",XQSM)) Q:XQSM="" D
  1. .S XQDIC="P"_XQSM
  1. .S XQYES=$S($D(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$D(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
  1. . Q
  1. I XQYES Q
  1. ;
  1. 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)
  1. Q
  1. ;
  1. ;End of main program
  1. ;
  1. BUILD(XQDIC) ;A missing ^XUTL node brings us here
  1. I $D(^DIC(19,"AXQ",XQDIC)) D
  1. .L +^DIC(19,"AXQ",XQDIC):5
  1. .I '$D(^XUTL("XQO",XQDIC)) M ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC)
  1. .L -^DIC(19,"AXQ",XQDIC)
  1. .Q
  1. I $D(^XUTL("XQO",XQDIC,0)) Q 1
  1. ;
  1. ;If they are not even in ^DIC the make them from scratch
  1. I '$D(^DIC(19,"AXQ",XQDIC)) D
  1. .;D REACT^XQ84(DUZ)
  1. .S XQMES="Your menus are being rebuilt. Please try again later."
  1. Q 0