USRLM ; SLC/JER - User Class Membership functions and proc's ; 11/25/09
;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,6,7,8,13,16,25,28,33**;Jun 20, 1997;Build 5
;======================================================================
ISA(USER,CLASS,ERR,USRDT) ; Boolean - Is USER a Member of CLASS?
N USRY,USRI
I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
; In case USER is entered as the name, not IEN:
I '+USER S USER=$$FIND1^DIC(200,,"X",USER,,,"USRERR") K USRERR
I +USER'>0 S ERR="INVALID USER" Q 0
I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
; If USER is a member of CLASS return true
S USRY=0
I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
. N USRMDA
. S USRMDA=0
. F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
.. S USRY=+$$CURRENT(USRMDA,$G(USRDT))
I USRY Q USRY
; Otherwise, check to see if user is a member of any subclass of CLASS
S USRI=0
F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
. N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
. S USRY=$$ISA(USER,USRSUB,,+$G(USRDT)) ; Recurs to find members of subclass
ISAX Q +$G(USRY)
;======================================================================
ISAWM(USER,CLASS) ; Boolean - Is USER a Member of CLASS, with message.
I $$ISA(USER,CLASS) D Q 1
. W !,"Already a member of this class"
. H 2
E Q 0
;
;======================================================================
CURRENT(MEMBER,USRDT) ; Boolean - Is Membership current?
N USRIN,USROUT,USRY
I +$G(USRDT)'>0 S USRDT=DT
S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
I USRIN'>USRDT,$S(USROUT>0&(USROUT'<USRDT):1,USROUT=0:1,1:0) S USRY=1
E S USRY=0
Q USRY
;
;======================================================================
ISTERM(USER,ERR) ;Return true if USER (DUZ or IEN in file 200) has a termination date
; and that date is less than the current date and time.
N TERM,TERMDATE,IENS,HUSH
S (TERM,TERMDATE)=0
S IENS=USER_",",TERMDATE=$$GET1^DIQ(200,IENS,9.2,"I",,"ERR") ; ICR 10060
I $D(ERR("DIERR","E",601)) D G ISTERMX
. S ERR="INVALID USER"
. S HUSH=$S($$BROKER^XWBLIB:1,1:0) ; ICR 2198
. I 'HUSH W !,"Warning: bad data. ",+USER," does not exist in file 200!" H 3
I (+TERMDATE>0)&(+TERMDATE<$$NOW^XLFDT) S TERM=1
ISTERMX ;
Q TERM
;
;======================================================================
RESIZE(LONG,SHORT,SHRINK) ; Resizes list area
N USRBM S USRBM=$S(VALMMENU:SHORT,+$G(SHRINK):SHORT,1:LONG)
I VALM("BM")'=USRBM S VALMBCK="R" D
. S VALM("BM")=USRBM,VALM("LINES")=(USRBM-VALM("TM"))+1
. I +$G(VALMCC) D RESET^VALM4
Q
;======================================================================
TERM ;USR actions to be taken when a user is terminated. Invoked by
;XU USER TERMINATE. XUIFN is the user being terminated; Newed in XUSERP.
;Sets all Class Memberships to expired.
N IND,OLDTERM,NOW
S NOW=DT ;Piece 4 is date only, time not needed.
S IND=""
F S IND=$O(^USR(8930.3,"B",XUIFN,IND)) Q:IND="" D
. S OLDTERM=+$P($G(^USR(8930.3,IND,0)),U,4)
. I (OLDTERM>0)&(OLDTERM<NOW) Q
. S $P(^USR(8930.3,IND,0),U,4)=NOW
Q
;
;======================================================================
WHOIS(MEMBER,CLASS,NAME01) ; Given a Class, set array of CURRENT members. Used in CANDEL.
; CLASS is pointer to file 8930
; MEMBER is name of array (local or global) in which members are
; returned in alphabetical order by name
; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
D WHOIS1^USRLM1(MEMBER,CLASS,+$G(NAME01)) Q ;Moved to USRLM1
;
;======================================================================
WHOIS2(MEMBER,USRCLASS,NAME01) ;Given a Class, return list of CURRENT members
; Uses WHOISTMP^USRLM1 (and XREF ACU)
; USRCLASS is pointer to file 8930
; MEMBER is name of array (local or global) in which members are
; returned in alphabetical order by name - indexed by number
; i.e. @MEMBER@(1 ...n)
; @member@(0) = ien of8930^usr class name^count of members
; @member@(1..n)=
; 1 2 3 4 5 6 7 8
; p200^p8930.3^classname^effectdate^inactdate^username^title^mailcode
; Note: For pieces 2,4 & 5 - Only one of potentially many is returned
; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
;N USER,USRNM,USRCLNM,USRCNT,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
N USER,USRNM,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
D WHOISTMP^USRLM1(.USRCLASS,+$G(NAME01))
S USRNM="",USRNDX=0
F S USRNM=$O(^TMP("USRWHO",$J,"USRWHO2","B",USRNM)) Q:USRNM']"" D
. S USER=0 F S USER=$O(^TMP("USRWHO",$J,"USRWHO2","B",USRNM,USER)) Q:'USER D
. . S USRNDX=USRNDX+1
. . S @MEMBER@(USRNDX)=^TMP("USRWHO",$J,"USRWHO2",USER)
S @MEMBER@(0)=^TMP("USRWHO",$J,"USRWHO2",0)
S $P(@MEMBER@(0),U,3)=USRNDX
K ^TMP("USRWHO",$J,"USRWHO2")
Q
;
;======================================================================
WHATIS(USER,CLASS,NAME01) ; Given a User, set array of classes USER belongs to
; USER is pointer to file 200
; CLASS is name of the array (local or global) to be set.
; Array is set in alpha order
; by name(display name or class name)in uppercase. Numeric indicator is appended to name
; to accomodate multiple memberships over time in the same class.
; ARRAY(Uppername_indicator)=UserClassIEN^MembershipIEN^name^EffectDt^ExpireDt
; NAME01 is optional. If NAME01>0 use .01 Class Name
; Otherwise, use Display Name
N IND,GROUP,CLASSNM,CLASSCNT,USRCUR,USRDA,EFFCTV,EXPIRES,EFFCTV1,TMPDATA,UPCLASNM
K ^TMP("USRWHATIS",$J)
S (CLASSCNT,IND,GROUP)=0 S NAME01=+$G(NAME01)
F S GROUP=$O(^USR(8930.3,"AUC",USER,GROUP)) Q:+GROUP'>0 D
. S USRDA=0
. F S USRDA=$O(^USR(8930.3,"AUC",USER,GROUP,USRDA)) Q:+USRDA'>0 D
.. S USRCUR="E",EFFCTV1=""
.. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3) S:EFFCTV="" EFFCTV1=DT
.. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4) S:EXPIRES="" EXPIRES=9999999
.. I EFFCTV'>DT,EXPIRES'<DT S USRCUR="C"
.. I EFFCTV>DT S USRCUR="F"
.. S CLASSNM=$$CLNAME(+GROUP,+$G(NAME01)),UPCLASNM=$$UP^XLFSTR(CLASSNM)
.. S TMPDATA=GROUP_U_USRDA_U_CLASSNM_U_EFFCTV_U_$S(EXPIRES=9999999:"",1:EXPIRES)
.. S ^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,$S(EFFCTV="":EFFCTV1,1:EFFCTV),EXPIRES)=TMPDATA
I $D(^TMP("USRWHATIS",$J)) D
. S UPCLASNM=""
. F S UPCLASNM=$O(^TMP("USRWHATIS",$J,UPCLASNM)) Q:UPCLASNM="" D
.. F USRCUR="F","E","C" D
... S EFFCTV=""
... F S EFFCTV=$O(^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,EFFCTV)) Q:EFFCTV="" D
.... S EXPIRES=""
.... F S EXPIRES=$O(^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,EFFCTV,EXPIRES)) Q:EXPIRES="" D
..... S IND=IND+1
..... S @CLASS@(UPCLASNM_IND)=$G(^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,EFFCTV,EXPIRES))
..... S CLASSCNT=+$G(CLASSCNT)+1
S @CLASS@(0)=USER_U_$$SIGNAME^USRLS(+USER)_U_CLASSCNT
K ^TMP("USRWHATIS",$J)
Q
;======================================================================
CLNAME(CLASS,NAME01) ; Given a class, return the Display Name or
; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
N USRREC,USRY
S USRREC=$G(^USR(8930,+CLASS,0))
Q $S(+$G(NAME01)>0:$P(USRREC,U),$P(USRREC,U,4)]"":$P(USRREC,U,4),1:$$MIXED^USRLS($P(USRREC,U)))
;
;======================================================================
PUT(USER,CLASS) ; Make user a member of a given class
N DIC,DLAYGO,DA,DR,DIE,X,Y
S (DIC,DLAYGO)=8930.3,DIC(0)="LXF",X=""""_"`"_USER_"""" D ^DIC Q:+Y'>0
S DIE=DIC,DA=+Y,DR=".02///"_CLASS_";.03///"_DT
D ^DIE
Q
;======================================================================
SUBCLASS(DA,CLASS) ; Evaluate whether a given USER CLASS is a DESCENDENT
; of another class
; Receives DA = record # of possible subclass in 8930, and
; CLASS = record # of possible descendent class in 8930
N USRI,USRY S (USRI,USRY)=0
I +$G(DA)'>0 S DA=+$O(^USR(8930,"B",DA,0))
I +$G(CLASS)'>0 S CLASS=+$O(^USR(8930,"B",CLASS,0))
F S USRI=$O(^USR(8930,"AD",DA,USRI)) Q:+USRI'>0!(USRY=1) D
. I USRI=CLASS S USRY=1 Q
. S USRY=$$SUBCLASS(USRI,CLASS)
Q USRY
;======================================================================
CANDEL(USRCLDA,NAME01) ; Evaluate whether user can delete a class. Can't find where it's used.
; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
N USRMLST,USRY S USRY=0
D WHOIS1^USRLM1("USRMLST",USRCLDA,+$G(NAME01))
I +$P(USRMLST(0),U,3)>0 S USRY=1 W " There are members of the class ",$$CLNAME(USRCLDA,+$G(NAME01))
Q USRY
USRLM ; SLC/JER - User Class Membership functions and proc's ; 11/25/09
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,6,7,8,13,16,25,28,33**;Jun 20, 1997;Build 5
+2 ;======================================================================
ISA(USER,CLASS,ERR,USRDT) ; Boolean - Is USER a Member of CLASS?
+1 NEW USRY,USRI
+2 IF $SELECT(CLASS="USER":1,CLASS=+$ORDER(^USR(8930,"B","USER",0)):1,1:0)
SET USRY=1
GOTO ISAX
+3 ; In case USER is entered as the name, not IEN:
+4 IF '+USER
SET USER=$$FIND1^DIC(200,,"X",USER,,,"USRERR")
KILL USRERR
+5 IF +USER'>0
SET ERR="INVALID USER"
QUIT 0
+6 IF '+CLASS
SET CLASS=+$ORDER(^USR(8930,"B",CLASS,0))
+7 IF +CLASS'>0
SET ERR="INVALID USER CLASS"
QUIT 0
+8 ; If USER is a member of CLASS return true
+9 SET USRY=0
+10 IF +$DATA(^USR(8930.3,"AUC",USER,CLASS))
Begin DoDot:1
+11 NEW USRMDA
+12 SET USRMDA=0
+13 FOR
SET USRMDA=+$ORDER(^USR(8930.3,"AUC",USER,CLASS,USRMDA))
IF ((+USRMDA'>0)!(USRY))
QUIT
Begin DoDot:2
+14 SET USRY=+$$CURRENT(USRMDA,$GET(USRDT))
End DoDot:2
End DoDot:1
+15 IF USRY
QUIT USRY
+16 ; Otherwise, check to see if user is a member of any subclass of CLASS
+17 SET USRI=0
+18 FOR
SET USRI=$ORDER(^USR(8930,+CLASS,1,USRI))
IF +USRI'>0!+$GET(USRY)
QUIT
Begin DoDot:1
+19 NEW USRSUB
SET USRSUB=+$GET(^USR(8930,+CLASS,1,USRI,0))
IF +USRSUB'>0
QUIT
+20 ; Recurs to find members of subclass
SET USRY=$$ISA(USER,USRSUB,,+$GET(USRDT))
End DoDot:1
ISAX QUIT +$GET(USRY)
+1 ;======================================================================
ISAWM(USER,CLASS) ; Boolean - Is USER a Member of CLASS, with message.
+1 IF $$ISA(USER,CLASS)
Begin DoDot:1
+2 WRITE !,"Already a member of this class"
+3 HANG 2
End DoDot:1
QUIT 1
+4 IF '$TEST
QUIT 0
+5 ;
+6 ;======================================================================
CURRENT(MEMBER,USRDT) ; Boolean - Is Membership current?
+1 NEW USRIN,USROUT,USRY
+2 IF +$GET(USRDT)'>0
SET USRDT=DT
+3 SET USRIN=+$PIECE($GET(^USR(8930.3,+MEMBER,0)),U,3)
+4 SET USROUT=+$PIECE($GET(^USR(8930.3,+MEMBER,0)),U,4)
+5 IF USRIN'>USRDT
IF $SELECT(USROUT>0&(USROUT'<USRDT):1,USROUT=0:1,1:0)
SET USRY=1
+6 IF '$TEST
SET USRY=0
+7 QUIT USRY
+8 ;
+9 ;======================================================================
ISTERM(USER,ERR) ;Return true if USER (DUZ or IEN in file 200) has a termination date
+1 ; and that date is less than the current date and time.
+2 NEW TERM,TERMDATE,IENS,HUSH
+3 SET (TERM,TERMDATE)=0
+4 ; ICR 10060
SET IENS=USER_","
SET TERMDATE=$$GET1^DIQ(200,IENS,9.2,"I",,"ERR")
+5 IF $DATA(ERR("DIERR","E",601))
Begin DoDot:1
+6 SET ERR="INVALID USER"
+7 ; ICR 2198
SET HUSH=$SELECT($$BROKER^XWBLIB:1,1:0)
+8 IF 'HUSH
WRITE !,"Warning: bad data. ",+USER," does not exist in file 200!"
HANG 3
End DoDot:1
GOTO ISTERMX
+9 IF (+TERMDATE>0)&(+TERMDATE<$$NOW^XLFDT)
SET TERM=1
ISTERMX ;
+1 QUIT TERM
+2 ;
+3 ;======================================================================
RESIZE(LONG,SHORT,SHRINK) ; Resizes list area
+1 NEW USRBM
SET USRBM=$SELECT(VALMMENU:SHORT,+$GET(SHRINK):SHORT,1:LONG)
+2 IF VALM("BM")'=USRBM
SET VALMBCK="R"
Begin DoDot:1
+3 SET VALM("BM")=USRBM
SET VALM("LINES")=(USRBM-VALM("TM"))+1
+4 IF +$GET(VALMCC)
DO RESET^VALM4
End DoDot:1
+5 QUIT
+6 ;======================================================================
TERM ;USR actions to be taken when a user is terminated. Invoked by
+1 ;XU USER TERMINATE. XUIFN is the user being terminated; Newed in XUSERP.
+2 ;Sets all Class Memberships to expired.
+3 NEW IND,OLDTERM,NOW
+4 ;Piece 4 is date only, time not needed.
SET NOW=DT
+5 SET IND=""
+6 FOR
SET IND=$ORDER(^USR(8930.3,"B",XUIFN,IND))
IF IND=""
QUIT
Begin DoDot:1
+7 SET OLDTERM=+$PIECE($GET(^USR(8930.3,IND,0)),U,4)
+8 IF (OLDTERM>0)&(OLDTERM<NOW)
QUIT
+9 SET $PIECE(^USR(8930.3,IND,0),U,4)=NOW
End DoDot:1
+10 QUIT
+11 ;
+12 ;======================================================================
WHOIS(MEMBER,CLASS,NAME01) ; Given a Class, set array of CURRENT members. Used in CANDEL.
+1 ; CLASS is pointer to file 8930
+2 ; MEMBER is name of array (local or global) in which members are
+3 ; returned in alphabetical order by name
+4 ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
+5 ;Moved to USRLM1
DO WHOIS1^USRLM1(MEMBER,CLASS,+$GET(NAME01))
QUIT
+6 ;
+7 ;======================================================================
WHOIS2(MEMBER,USRCLASS,NAME01) ;Given a Class, return list of CURRENT members
+1 ; Uses WHOISTMP^USRLM1 (and XREF ACU)
+2 ; USRCLASS is pointer to file 8930
+3 ; MEMBER is name of array (local or global) in which members are
+4 ; returned in alphabetical order by name - indexed by number
+5 ; i.e. @MEMBER@(1 ...n)
+6 ; @member@(0) = ien of8930^usr class name^count of members
+7 ; @member@(1..n)=
+8 ; 1 2 3 4 5 6 7 8
+9 ; p200^p8930.3^classname^effectdate^inactdate^username^title^mailcode
+10 ; Note: For pieces 2,4 & 5 - Only one of potentially many is returned
+11 ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
+12 ;N USER,USRNM,USRCLNM,USRCNT,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
+13 NEW USER,USRNM,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
+14 DO WHOISTMP^USRLM1(.USRCLASS,+$GET(NAME01))
+15 SET USRNM=""
SET USRNDX=0
+16 FOR
SET USRNM=$ORDER(^TMP("USRWHO",$JOB,"USRWHO2","B",USRNM))
IF USRNM']""
QUIT
Begin DoDot:1
+17 SET USER=0
FOR
SET USER=$ORDER(^TMP("USRWHO",$JOB,"USRWHO2","B",USRNM,USER))
IF 'USER
QUIT
Begin DoDot:2
+18 SET USRNDX=USRNDX+1
+19 SET @MEMBER@(USRNDX)=^TMP("USRWHO",$JOB,"USRWHO2",USER)
End DoDot:2
End DoDot:1
+20 SET @MEMBER@(0)=^TMP("USRWHO",$JOB,"USRWHO2",0)
+21 SET $PIECE(@MEMBER@(0),U,3)=USRNDX
+22 KILL ^TMP("USRWHO",$JOB,"USRWHO2")
+23 QUIT
+24 ;
+25 ;======================================================================
WHATIS(USER,CLASS,NAME01) ; Given a User, set array of classes USER belongs to
+1 ; USER is pointer to file 200
+2 ; CLASS is name of the array (local or global) to be set.
+3 ; Array is set in alpha order
+4 ; by name(display name or class name)in uppercase. Numeric indicator is appended to name
+5 ; to accomodate multiple memberships over time in the same class.
+6 ; ARRAY(Uppername_indicator)=UserClassIEN^MembershipIEN^name^EffectDt^ExpireDt
+7 ; NAME01 is optional. If NAME01>0 use .01 Class Name
+8 ; Otherwise, use Display Name
+9 NEW IND,GROUP,CLASSNM,CLASSCNT,USRCUR,USRDA,EFFCTV,EXPIRES,EFFCTV1,TMPDATA,UPCLASNM
+10 KILL ^TMP("USRWHATIS",$JOB)
+11 SET (CLASSCNT,IND,GROUP)=0
SET NAME01=+$GET(NAME01)
+12 FOR
SET GROUP=$ORDER(^USR(8930.3,"AUC",USER,GROUP))
IF +GROUP'>0
QUIT
Begin DoDot:1
+13 SET USRDA=0
+14 FOR
SET USRDA=$ORDER(^USR(8930.3,"AUC",USER,GROUP,USRDA))
IF +USRDA'>0
QUIT
Begin DoDot:2
+15 SET USRCUR="E"
SET EFFCTV1=""
+16 SET EFFCTV=$PIECE($GET(^USR(8930.3,+USRDA,0)),U,3)
IF EFFCTV=""
SET EFFCTV1=DT
+17 SET EXPIRES=$PIECE($GET(^USR(8930.3,+USRDA,0)),U,4)
IF EXPIRES=""
SET EXPIRES=9999999
+18 IF EFFCTV'>DT
IF EXPIRES'<DT
SET USRCUR="C"
+19 IF EFFCTV>DT
SET USRCUR="F"
+20 SET CLASSNM=$$CLNAME(+GROUP,+$GET(NAME01))
SET UPCLASNM=$$UP^XLFSTR(CLASSNM)
+21 SET TMPDATA=GROUP_U_USRDA_U_CLASSNM_U_EFFCTV_U_$SELECT(EXPIRES=9999999:"",1:EXPIRES)
+22 SET ^TMP("USRWHATIS",$JOB,UPCLASNM,USRCUR,$SELECT(EFFCTV="":EFFCTV1,1:EFFCTV),EXPIRES)=TMPDATA
End DoDot:2
End DoDot:1
+23 IF $DATA(^TMP("USRWHATIS",$JOB))
Begin DoDot:1
+24 SET UPCLASNM=""
+25 FOR
SET UPCLASNM=$ORDER(^TMP("USRWHATIS",$JOB,UPCLASNM))
IF UPCLASNM=""
QUIT
Begin DoDot:2
+26 FOR USRCUR="F","E","C"
Begin DoDot:3
+27 SET EFFCTV=""
+28 FOR
SET EFFCTV=$ORDER(^TMP("USRWHATIS",$JOB,UPCLASNM,USRCUR,EFFCTV))
IF EFFCTV=""
QUIT
Begin DoDot:4
+29 SET EXPIRES=""
+30 FOR
SET EXPIRES=$ORDER(^TMP("USRWHATIS",$JOB,UPCLASNM,USRCUR,EFFCTV,EXPIRES))
IF EXPIRES=""
QUIT
Begin DoDot:5
+31 SET IND=IND+1
+32 SET @CLASS@(UPCLASNM_IND)=$GET(^TMP("USRWHATIS",$JOB,UPCLASNM,USRCUR,EFFCTV,EXPIRES))
+33 SET CLASSCNT=+$GET(CLASSCNT)+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 SET @CLASS@(0)=USER_U_$$SIGNAME^USRLS(+USER)_U_CLASSCNT
+35 KILL ^TMP("USRWHATIS",$JOB)
+36 QUIT
+37 ;======================================================================
CLNAME(CLASS,NAME01) ; Given a class, return the Display Name or
+1 ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
+2 NEW USRREC,USRY
+3 SET USRREC=$GET(^USR(8930,+CLASS,0))
+4 QUIT $SELECT(+$GET(NAME01)>0:$PIECE(USRREC,U),$PIECE(USRREC,U,4)]"":$PIECE(USRREC,U,4),1:$$MIXED^USRLS($PIECE(USRREC,U)))
+5 ;
+6 ;======================================================================
PUT(USER,CLASS) ; Make user a member of a given class
+1 NEW DIC,DLAYGO,DA,DR,DIE,X,Y
+2 SET (DIC,DLAYGO)=8930.3
SET DIC(0)="LXF"
SET X=""""_"`"_USER_""""
DO ^DIC
IF +Y'>0
QUIT
+3 SET DIE=DIC
SET DA=+Y
SET DR=".02///"_CLASS_";.03///"_DT
+4 DO ^DIE
+5 QUIT
+6 ;======================================================================
SUBCLASS(DA,CLASS) ; Evaluate whether a given USER CLASS is a DESCENDENT
+1 ; of another class
+2 ; Receives DA = record # of possible subclass in 8930, and
+3 ; CLASS = record # of possible descendent class in 8930
+4 NEW USRI,USRY
SET (USRI,USRY)=0
+5 IF +$GET(DA)'>0
SET DA=+$ORDER(^USR(8930,"B",DA,0))
+6 IF +$GET(CLASS)'>0
SET CLASS=+$ORDER(^USR(8930,"B",CLASS,0))
+7 FOR
SET USRI=$ORDER(^USR(8930,"AD",DA,USRI))
IF +USRI'>0!(USRY=1)
QUIT
Begin DoDot:1
+8 IF USRI=CLASS
SET USRY=1
QUIT
+9 SET USRY=$$SUBCLASS(USRI,CLASS)
End DoDot:1
+10 QUIT USRY
+11 ;======================================================================
CANDEL(USRCLDA,NAME01) ; Evaluate whether user can delete a class. Can't find where it's used.
+1 ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
+2 NEW USRMLST,USRY
SET USRY=0
+3 DO WHOIS1^USRLM1("USRMLST",USRCLDA,+$GET(NAME01))
+4 IF +$PIECE(USRMLST(0),U,3)>0
SET USRY=1
WRITE " There are members of the class ",$$CLNAME(USRCLDA,+$GET(NAME01))
+5 QUIT USRY
