source: WorldVistAEHR/trunk/r/AUTHORIZATION_SUBSCRIPTION-USR/USRLM.m@ 1361

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1USRLM ; SLC/JER - User Class Membership functions and proc's ; Jan 1, 2004
2 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,6,7,8,13,16,25,28**;Jun 20, 1997
3 ; 15 Dec 99 MA - Modified entry point TERM
4 ; 14 Feb 00 MA - Add check to verify that x-ref AUC has valid 0 node.
5 ; 27 Jun 00 MA - Changed WHOIS to build array in alphabetical order
6 ; by subscriber name.
7ISA(USER,CLASS,ERR,USRDT) ; Boolean - Is USER a Member of CLASS?
8 N USRY,USRI
9 I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
10 I '+USER S USER=+$O(^VA(200,"B",USER,0))
11 I +USER'>0 S ERR="INVALID USER" Q 0
12 I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
13 I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
14 ; If USER is a member of CLASS return true
15 S USRY=0
16 I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
17 . N USRMDA
18 . S USRMDA=0
19 . F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
20 .. S USRY=+$$CURRENT(USRMDA,$G(USRDT))
21 I USRY Q USRY
22 ; Otherwise, check to see if user is a member of any subclass of CLASS
23 S USRI=0
24 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
25 . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
26 . S USRY=$$ISA(USER,USRSUB,,+$G(USRDT)) ; Recurs to find members of subclass
27ISAX Q +$G(USRY)
28 ;======================================================================
29ISAWM(USER,CLASS) ; Boolean - Is USER a Member of CLASS, with message.
30 I $$ISA(USER,CLASS) D Q 1
31 . W !,"Already a member of this class"
32 . H 2
33 E Q 0
34 ;
35 ;======================================================================
36CURRENT(MEMBER,USRDT) ; Boolean - Is Membership current?
37 N USRIN,USROUT,USRY
38 I +$G(USRDT)'>0 S USRDT=DT
39 S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
40 S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
41 I USRIN'>USRDT,$S(USROUT>0&(USROUT'<USRDT):1,USROUT=0:1,1:0) S USRY=1
42 E S USRY=0
43 Q USRY
44 ;
45 ;======================================================================
46ISTERM(USER) ;Return true if USER has a termination date and that date
47 ;is less than the current date and time. The read is covered by
48 ;DBIA 10060
49 N TERM,TERMDATE
50 S TERM=0
51 I '$D(^VA(200,+USER,0)) D
52 . S TERMDATE=0
53 . W !,"Warning bad data DUZ=",+USER," found in file 8930.3 but does not exist in file 200!"
54 . H 3
55 E S TERMDATE=+$P(^VA(200,+USER,0),U,11)
56 I (TERMDATE>0) D
57 . I TERMDATE<$$NOW^XLFDT S TERM=1
58 Q TERM
59 ;
60 ;======================================================================
61RESIZE(LONG,SHORT,SHRINK) ; Resizes list area
62 N USRBM S USRBM=$S(VALMMENU:SHORT,+$G(SHRINK):SHORT,1:LONG)
63 I VALM("BM")'=USRBM S VALMBCK="R" D
64 . S VALM("BM")=USRBM,VALM("LINES")=(USRBM-VALM("TM"))+1
65 . I +$G(VALMCC) D RESET^VALM4
66 Q
67 ;======================================================================
68TERM ;Actions to be taken when a user is terminated. Invoked by
69 ;XU USER TERMINATE. XUIFN is the user being terminated.
70 ;15 DEC 99 MA - Replaced $$NOW^XLFDT with DT. Piece 4 does
71 ;not need the time. Piece 4 is date only.
72 N IND,OLDTERM,NOW
73 S NOW=DT
74 S IND=""
75 F S IND=$O(^USR(8930.3,"B",XUIFN,IND)) Q:IND="" D
76 . S OLDTERM=+$P($G(^USR(8930.3,IND,0)),U,4)
77 . I (OLDTERM>0)&(OLDTERM<NOW) Q
78 . S $P(^USR(8930.3,IND,0),U,4)=NOW
79 Q
80 ;
81 ;======================================================================
82WHOIS(MEMBER,CLASS) ; Given a Class, return list of CURRENT members
83 ; CLASS is pointer to file 8930
84 ; MEMBER is name of array (local or global) in which members are
85 ; returned in alphabetical order by name
86 N USER,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRNAME,EFFCTV1,EXPIRES1
87 K ^TMP("USRWHOIS",$J)
88 S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
89 F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
90 . S USRDA=""
91 . F S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,USRDA)) Q:USRDA="" D
92 .. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3) S:EFFCTV="" EFFCTV1="0000000"
93 .. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4) S:EXPIRES="" EXPIRES1=9999999
94 .. S USRCLNM=$$CLNAME(+CLASS)
95 .. S USRNAME=$$GET1^DIQ(200,USER,.01)
96 .. S ^TMP("USRWHOIS",$J,USRNAME,$S(EFFCTV="":EFFCTV1,1:EFFCTV),$S(EXPIRES="":EXPIRES1,1:EXPIRES))=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES
97 .. S USRCNT=+$G(USRCNT)+1
98 I $D(^TMP("USRWHOIS",$J)) D
99 . S USRNAME="" F S USRNAME=$O(^TMP("USRWHOIS",$J,USRNAME)) Q:USRNAME="" D
100 .. S EFFCTV="" F S EFFCTV=$O(^TMP("USRWHOIS",$J,USRNAME,EFFCTV)) Q:EFFCTV="" Q:EFFCTV>DT D
101 ... S EXPIRES="" F S EXPIRES=$O(^TMP("USRWHOIS",$J,USRNAME,EFFCTV,EXPIRES),-1) Q:EXPIRES="" Q:EXPIRES<DT D
102 .... S @MEMBER@(USRNAME)=$G(^TMP("USRWHOIS",$J,USRNAME,EFFCTV,EXPIRES))
103 I '$D(@MEMBER@(0)) S @MEMBER@(0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
104 S $P(@MEMBER@(0),U,3)=USRCNT
105 S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
106 . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
107 . D WHOIS(MEMBER,USRSUB) ; Recurs to find members of subclass
108 K ^TMP("USRWHOIS",$J)
109 Q
110WHOIS2(MEMBER,CLASS) ; Given a Class, return list of CURRENT members
111 ; CLASS is pointer to file 8930
112 ; MEMBER is name of array (local or global) in which members are
113 ; returned in alphabetical order by name - indexed by number
114 ; i.e. @MEMBER@(1 ...n)
115 ; @member@(0) = ien of8930^usr class name^count of members
116 ; @member@(1..n)=
117 ; 1 2 3 4 5 6 7 8
118 ; p200^p8930.3^classname^effectdate^inactdate^username^title^mailcode
119 ; Note: For pieces 2,4 & 5 - Only one of potentially many is returned
120 ;
121 N USER,USRNM,USRCLNM,USRCNT,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
122 D WHOISTMP(.CLASS)
123 S USRNM="",USRNDX=0
124 F S USRNM=$O(^TMP($J,"USRWHO2","B",USRNM)) Q:USRNM']"" D
125 . S USER=0 F S USER=$O(^TMP($J,"USRWHO2","B",USRNM,USER)) Q:'USER D
126 . . S USRNDX=USRNDX+1
127 . . S @MEMBER@(USRNDX)=^TMP($J,"USRWHO2",USER)
128 S @MEMBER@(0)=^TMP($J,"USRWHO2",0)
129 S $P(@MEMBER@(0),U,3)=USRNDX
130 K ^TMP($J,"USRWHO2")
131 Q
132WHOISTMP(CLASS) ; Given a Class, return list of CURRENT members into ^TMP
133 ; CLASS is pointer to file 8930
134 ; MEMBER is name of array (local or global) in which members are
135 ; returned in order by user/x-ref by name
136 ; main = ^tmp($j,"USRWHO2",user)
137 ; x-ref= ^tmp($j,"USRWHO2","b",usrnm,user)
138 ; -- used by whois2 call
139 N USER,USRNM,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRMC,USRTIT,USRX
140 S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
141 F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
142 . S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,0)) Q:+USRDA'>0
143 . S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3)
144 . S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4)
145 . S USRNM=$P($G(^VA(200,+USER,0)),U)
146 . S USRX=$P($G(^VA(200,+USER,0)),U,9)
147 . S USRTIT=$$EXTERNAL^DILFD(200,8,"",USRX)
148 . S USRMC=$P($G(^VA(200,+USER,5)),U,2)
149 . S USRCLNM=$$CLNAME(+CLASS)
150 . S ^TMP($J,"USRWHO2",USER)=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES_U_USRNM_U_USRTIT_U_USRMC
151 . S ^TMP($J,"USRWHO2","B",USRNM,USER)=""
152 . S USRCNT=+$G(USRCNT)+1
153 I '$D(^TMP($J,"USRWHO2",0))#2 S ^TMP($J,"USRWHO2",0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
154 S $P(^TMP($J,"USRWHO2",0),U,3)=USRCNT
155 S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
156 . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
157 . D WHOISTMP(USRSUB) ; Recurs to find members of subclass
158 Q
159WHATIS(USER,CLASS) ; Given a User, return list of class memberships
160 ; USER is pointer to file 200
161 ; CLASS is name of array (local or global) in which the list of
162 ; classes to which the USER belongs will be returned in
163 ; alphabetic order by class name
164 N IND,GROUP,CLASSNM,CLASSCNT,USRCUR,USRDA,EFFCTV,EXPIRES,EFFCTV1
165 K ^TMP("USRWHATIS",$J)
166 S (CLASSCNT,IND,GROUP)=0
167 F S GROUP=$O(^USR(8930.3,"AUC",USER,GROUP)) Q:+GROUP'>0 D
168 . S USRDA=0
169 . F S USRDA=$O(^USR(8930.3,"AUC",USER,GROUP,USRDA)) Q:+USRDA'>0 D
170 .. S USRCUR="E",EFFCTV1=""
171 .. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3) S:EFFCTV="" EFFCTV1=DT
172 .. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4) S:EXPIRES="" EXPIRES=9999999
173 .. I EFFCTV'>DT,EXPIRES'<DT S USRCUR="C"
174 .. I EFFCTV>DT S USRCUR="F"
175 .. S CLASSNM=$$CLNAME(+GROUP)
176 .. S ^TMP("USRWHATIS",$J,CLASSNM,USRCUR,$S(EFFCTV="":EFFCTV1,1:EFFCTV),EXPIRES)=GROUP_U_USRDA_U_CLASSNM_U_EFFCTV_U_$S(EXPIRES=9999999:"",1:EXPIRES)
177 I $D(^TMP("USRWHATIS",$J)) D
178 . S CLASSNM=""
179 . F S CLASSNM=$O(^TMP("USRWHATIS",$J,CLASSNM)) Q:CLASSNM="" D
180 .. F USRCUR="F","E","C" D
181 ... S EFFCTV=""
182 ... F S EFFCTV=$O(^TMP("USRWHATIS",$J,CLASSNM,USRCUR,EFFCTV)) Q:EFFCTV="" D
183 .... S EXPIRES=""
184 .... F S EXPIRES=$O(^TMP("USRWHATIS",$J,CLASSNM,USRCUR,EFFCTV,EXPIRES)) Q:EXPIRES="" D
185 ..... S IND=IND+1
186 ..... S @CLASS@(CLASSNM_IND)=$G(^TMP("USRWHATIS",$J,CLASSNM,USRCUR,EFFCTV,EXPIRES))
187 ..... S CLASSCNT=+$G(CLASSCNT)+1
188 S @CLASS@(0)=USER_U_$$SIGNAME^USRLS(+USER)_U_CLASSCNT
189 K ^TMP("USRWHATIS",$J)
190 Q
191CLNAME(CLASS) ; Given a class, return the Display Name
192 N USRREC,USRY
193 S USRREC=$G(^USR(8930,+CLASS,0))
194 Q $S($P(USRREC,U,4)]"":$P(USRREC,U,4),1:$$MIXED^USRLS($P(USRREC,U)))
195PUT(USER,CLASS) ; Make user a member of a given class
196 N DIC,DLAYGO,DA,DR,DIE,X,Y
197 S (DIC,DLAYGO)=8930.3,DIC(0)="LXF",X=""""_"`"_USER_"""" D ^DIC Q:+Y'>0
198 S DIE=DIC,DA=+Y,DR=".02///"_CLASS_";.03///"_DT
199 D ^DIE
200 Q
201SUBCLASS(DA,CLASS) ; Evaluate whether a given USER CLASS is a DESCENDENT
202 ; of another class
203 ; Receives DA = record # of possible subclass in 8930, and
204 ; CLASS = record # of possible descendent class in 8930
205 N USRI,USRY S (USRI,USRY)=0
206 I +$G(DA)'>0 S DA=+$O(^USR(8930,"B",DA,0))
207 I +$G(CLASS)'>0 S CLASS=+$O(^USR(8930,"B",CLASS,0))
208 F S USRI=$O(^USR(8930,"AD",DA,USRI)) Q:+USRI'>0!(USRY=1) D
209 . I USRI=CLASS S USRY=1 Q
210 . S USRY=$$SUBCLASS(USRI,CLASS)
211 Q USRY
212CANDEL(USRCLDA) ; Evaluate whether user can delete a class
213 N USRMLST,USRY S USRY=0
214 D WHOIS("USRMLST",USRCLDA)
215 I +$P(USRMLST(0),U,3)>0 S USRY=1 W " There are members of the class ",$$CLNAME(USRCLDA)
216 Q USRY
Note: See TracBrowser for help on using the repository browser.