source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCS.m@ 738

Last change on this file since 738 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.6 KB
Line 
1XQCS ;SEA/Luke - Client/Server Utilities ;01/07/2003 13:53
2 ;;8.0;KERNEL;**15,28,82,116,115,177,188,157,253**;Jul 10, 1995
3 ;
4CHK(XQUSR,XQOPT,XQRPC) ;Check to see if this user can run this RPC from
5 ;this option. Called by XWBSEC and XUSRB.
6 ;
7 ;Input: XQUSR-DUZ of user
8 ; XQOPT - name or IEN of the option
9 ; XQRPC - name or IEN of the remote procedure. If this
10 ; variable is null no check is made to see if a
11 ; procedure is allowed. That is, we only look
12 ; to see if the option is there and if the user
13 ; has been assigned access to it.
14 ;
15 ;Output: XQMES - returned as 1 if the user is allowed to use this
16 ; option (and RPC is valid if XQRPC input variable is not
17 ; null), or as a message string explaining why the option
18 ; or RPC is not allowed.
19 ;
20 ;Rules: If M code exsists in ^DIC(19,option#,"RPC",rpc#,1) the
21 ; RULES field for a corresponding RPC, the software sets
22 ; the flag XQRPCOK to 1 and executes the field's code.
23 ; If the flag is returned as less than 1, the request for
24 ; use of that RPC is denied. Rules are written by the
25 ; package developer and are not required.
26 ;
27 ;
28 N %,X,XQCY0,XQDIC,XQKEY,XQRPCOK,XQPM,XQSM,XQSMY,XQYSAV
29 ;
30 S XQMES=1
31 D OPT I 'XQMES Q XQMES
32 I ($G(XQY0)'="XUS SIGNON")&(XQUSR>0) D USER I 'XQMES Q XQMES
33 S %=$G(XQRPC) I %]"" S XQRPC=% D RPC I 'XQMES Q XQMES
34 Q XQMES
35 ;
36 ;
37OPT ;See if the option is there and is a broker type option
38 I XQOPT'=+XQOPT S XQOPT=$O(^DIC(19,"B",XQOPT,0))
39 I XQOPT'>0 S XQMES="No such option in the ""B"" cross reference of the Option File." Q
40 I $G(MODE)="CHECK" D OPT1 Q
41 I '$D(^TMP("XQCS",$J)) S XQOPT=$$OPTLK($P(^DIC(19,XQOPT,0),U))
42 Q
43OPT1 ;
44 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
45 I '$D(^DIC(19,XQOPT,0)) S XQMES="No such option in the Option File." Q
46 ;I $P(^DIC(19,XQOPT,0),U,4)'="B" S XQMES="This option is not a Client/Server-type option." Q
47 ;
48 ;Check for Out-Of-Order, etc. Patch XU*8*38 7/16/96
49 ;
50 S XQCY0=^DIC(19,XQOPT,0) ;W XQCY0
51 I $L($P(XQCY0,U,3)) S XQMES="Option out of order with message: "_$P(XQCY0,U,3)_"." Q
52 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
53 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
54 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
55 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
56 ;End patch 38
57 Q
58 ;
59OPTLK(V) ;Lookup a Option in the file, Return it's IEN
60 N XQOPT S XQOPT=$O(^DIC(19,"B",V,0)) I XQOPT'>0 Q ""
61 I '$D(XQMES) N XQMES S XQMES=1
62 N XQCS,XQCSO S XQCS(XQOPT)="" N XQOPT K ^TMP("XQCS",$J)
63 F S XQOPT=$O(XQCS("")) Q:XQOPT="" K XQCS(XQOPT) I '$D(XQCSO(XQOPT)) D OPT1 D:XQMES I 'XQMES Q
64 . 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)
65 . 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)=""
66 . S XQCSO(XQOPT)=""
67 . Q
68 Q $O(^DIC(19,"B",V,0))
69 ;
70RPC ;See if rpc exsists, is registered, is locked, etc.
71 ; I '$D(^DIC(19,XQOPT,"RPC",0)) S XQMES="No RPC subfile defined for the option "_$P(^DIC(19,XQOPT,0),U)_"." Q
72 ; 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
73 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
74 I '$D(^XWB(8994,XQRPC,0)) S XQMES="No such procedure in the Remote Procedure File." Q
75 ; 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
76 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
77 ; S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0)),XQKEY=$P(^DIC(19,XQOPT,"RPC",%,0),U,2)
78 S XQKEY=$P(^TMP("XQCS",$J,XQRPC,0),U,2)
79 I $L(XQKEY) I '$D(^XUSEC(XQKEY,XQUSR)) S XQMES="Remote procedure is locked." Q
80 ;
81RULES ;Check the rules for this RPC
82 ;S %=$O(^DIC(19,XQOPT,"RPC","B",XQRPC,0))
83 ;I $D(^DIC(19,XQOPT,"RPC",%,1)),$L(^(1)) D
84 I $D(^TMP("XQCS",$J,XQRPC,1)),$L(^(1)) D
85 . S XQRPCOK=1
86 . X ^TMP("XQCS",$J,XQRPC,1)
87 . I XQRPCOK<1 S XQMES="Remote procedure request failed rules test."
88 . Q
89 Q
90 ;
91 ;
92 ;
93USER ;See if XQUSR has been assigned access this option or not
94 ;
95 N XQYES
96 S XQMES=1,(XQSMY,%,XQYES)=0
97 ;
98TOP ;See if XQOPT is on top level of a tree: primary, secondary, or common
99 S XQPM=+$G(^VA(200,XQUSR,201)) I XQOPT=XQPM Q
100 ;
101 ;Check the Common Options (XUCOMMAND)
102 I $D(^DIC(19,"B","XUCOMMAND")) D
103 . N XQCOM
104 . S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0))
105 . I $D(^DIC(19,XQCOM,10,"B",XQOPT)) S XQYES=1
106 . I XQYES Q
107 . I '$D(^XUTL("XQO","PXU",0)) S %=$$BUILD("PXU")
108 . I $D(^XUTL("XQO","PXU","^",XQOPT)) S XQYES=1
109 . Q
110 I XQYES Q
111 ;
112 ;
113 I $D(^VA(200,XQUSR,203,0)),$P(^(0),U,4)>0 S XQSMY=1 D
114 . 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
115 . S (XQSM,%)=0
116 . F Q:% S XQSM=$O(^XUTL("XQO",XQDIC,"^",XQSM)) Q:XQSM="" I XQSM=XQOPT S XQYES=1 Q
117 . Q
118 I XQYES Q
119 ;
120DEEP ;See if it's under the top somewhere - start with primary tree
121 I XQPM>0 D
122 .S XQDIC="P"_XQPM
123 .S XQYES=$S($D(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$D(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
124 .Q
125 I XQYES Q
126 ;
127 ;Check secondary trees
128 S (XQSM,%)=0
129 I XQSMY F Q:XQYES S XQSM=$O(^XUTL("XQO","U"_XQUSR,"^",XQSM)) Q:XQSM="" D
130 .S XQDIC="P"_XQSM
131 .S XQYES=$S($D(^XUTL("XQO",XQDIC,"^",XQOPT)):1,$D(^DIC(19,"AXQ",XQDIC,"^",XQOPT)):1,1:0)
132 . Q
133 I XQYES Q
134 ;
135 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)
136 Q
137 ;
138 ;End of main program
139 ;
140BUILD(XQDIC) ;A missing ^XUTL node brings us here
141 I $D(^DIC(19,"AXQ",XQDIC)) D
142 .L +^DIC(19,"AXQ",XQDIC):5
143 .I '$D(^XUTL("XQO",XQDIC)) M ^XUTL("XQO",XQDIC)=^DIC(19,"AXQ",XQDIC)
144 .L -^DIC(19,"AXQ",XQDIC)
145 .Q
146 I $D(^XUTL("XQO",XQDIC,0)) Q 1
147 ;
148 ;If they are not even in ^DIC the make them from scratch
149 I '$D(^DIC(19,"AXQ",XQDIC)) D
150 .;D REACT^XQ84(DUZ)
151 .S XQMES="Your menus are being rebuilt. Please try again later."
152 Q 0
Note: See TracBrowser for help on using the repository browser.