- 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 7
- ;======================================================================
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRLM 8705 printed Jan 18, 2025@02:40:03 Page 2
- 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 7
- +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