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

USRLM.m

Go to the documentation of this file.
  1. 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
  1. ;======================================================================
  1. ISA(USER,CLASS,ERR,USRDT) ; Boolean - Is USER a Member of CLASS?
  1. N USRY,USRI
  1. I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
  1. ; In case USER is entered as the name, not IEN:
  1. I '+USER S USER=$$FIND1^DIC(200,,"X",USER,,,"USRERR") K USRERR
  1. I +USER'>0 S ERR="INVALID USER" Q 0
  1. I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
  1. I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
  1. ; If USER is a member of CLASS return true
  1. S USRY=0
  1. I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
  1. . N USRMDA
  1. . S USRMDA=0
  1. . F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
  1. .. S USRY=+$$CURRENT(USRMDA,$G(USRDT))
  1. I USRY Q USRY
  1. ; Otherwise, check to see if user is a member of any subclass of CLASS
  1. S USRI=0
  1. F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
  1. . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
  1. . S USRY=$$ISA(USER,USRSUB,,+$G(USRDT)) ; Recurs to find members of subclass
  1. ISAX Q +$G(USRY)
  1. ;======================================================================
  1. ISAWM(USER,CLASS) ; Boolean - Is USER a Member of CLASS, with message.
  1. I $$ISA(USER,CLASS) D Q 1
  1. . W !,"Already a member of this class"
  1. . H 2
  1. E Q 0
  1. ;
  1. ;======================================================================
  1. CURRENT(MEMBER,USRDT) ; Boolean - Is Membership current?
  1. N USRIN,USROUT,USRY
  1. I +$G(USRDT)'>0 S USRDT=DT
  1. S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
  1. S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
  1. I USRIN'>USRDT,$S(USROUT>0&(USROUT'<USRDT):1,USROUT=0:1,1:0) S USRY=1
  1. E S USRY=0
  1. Q USRY
  1. ;
  1. ;======================================================================
  1. 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.
  1. N TERM,TERMDATE,IENS,HUSH
  1. S (TERM,TERMDATE)=0
  1. S IENS=USER_",",TERMDATE=$$GET1^DIQ(200,IENS,9.2,"I",,"ERR") ; ICR 10060
  1. I $D(ERR("DIERR","E",601)) D G ISTERMX
  1. . S ERR="INVALID USER"
  1. . S HUSH=$S($$BROKER^XWBLIB:1,1:0) ; ICR 2198
  1. . I 'HUSH W !,"Warning: bad data. ",+USER," does not exist in file 200!" H 3
  1. I (+TERMDATE>0)&(+TERMDATE<$$NOW^XLFDT) S TERM=1
  1. ISTERMX ;
  1. Q TERM
  1. ;
  1. ;======================================================================
  1. RESIZE(LONG,SHORT,SHRINK) ; Resizes list area
  1. N USRBM S USRBM=$S(VALMMENU:SHORT,+$G(SHRINK):SHORT,1:LONG)
  1. I VALM("BM")'=USRBM S VALMBCK="R" D
  1. . S VALM("BM")=USRBM,VALM("LINES")=(USRBM-VALM("TM"))+1
  1. . I +$G(VALMCC) D RESET^VALM4
  1. Q
  1. ;======================================================================
  1. 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.
  1. ;Sets all Class Memberships to expired.
  1. N IND,OLDTERM,NOW
  1. S NOW=DT ;Piece 4 is date only, time not needed.
  1. S IND=""
  1. F S IND=$O(^USR(8930.3,"B",XUIFN,IND)) Q:IND="" D
  1. . S OLDTERM=+$P($G(^USR(8930.3,IND,0)),U,4)
  1. . I (OLDTERM>0)&(OLDTERM<NOW) Q
  1. . S $P(^USR(8930.3,IND,0),U,4)=NOW
  1. Q
  1. ;
  1. ;======================================================================
  1. WHOIS(MEMBER,CLASS,NAME01) ; Given a Class, set array of CURRENT members. Used in CANDEL.
  1. ; CLASS is pointer to file 8930
  1. ; MEMBER is name of array (local or global) in which members are
  1. ; returned in alphabetical order by name
  1. ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
  1. D WHOIS1^USRLM1(MEMBER,CLASS,+$G(NAME01)) Q ;Moved to USRLM1
  1. ;
  1. ;======================================================================
  1. WHOIS2(MEMBER,USRCLASS,NAME01) ;Given a Class, return list of CURRENT members
  1. ; Uses WHOISTMP^USRLM1 (and XREF ACU)
  1. ; USRCLASS is pointer to file 8930
  1. ; MEMBER is name of array (local or global) in which members are
  1. ; returned in alphabetical order by name - indexed by number
  1. ; i.e. @MEMBER@(1 ...n)
  1. ; @member@(0) = ien of8930^usr class name^count of members
  1. ; @member@(1..n)=
  1. ; 1 2 3 4 5 6 7 8
  1. ; p200^p8930.3^classname^effectdate^inactdate^username^title^mailcode
  1. ; Note: For pieces 2,4 & 5 - Only one of potentially many is returned
  1. ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
  1. ;N USER,USRNM,USRCLNM,USRCNT,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
  1. N USER,USRNM,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
  1. D WHOISTMP^USRLM1(.USRCLASS,+$G(NAME01))
  1. S USRNM="",USRNDX=0
  1. F S USRNM=$O(^TMP("USRWHO",$J,"USRWHO2","B",USRNM)) Q:USRNM']"" D
  1. . S USER=0 F S USER=$O(^TMP("USRWHO",$J,"USRWHO2","B",USRNM,USER)) Q:'USER D
  1. . . S USRNDX=USRNDX+1
  1. . . S @MEMBER@(USRNDX)=^TMP("USRWHO",$J,"USRWHO2",USER)
  1. S @MEMBER@(0)=^TMP("USRWHO",$J,"USRWHO2",0)
  1. S $P(@MEMBER@(0),U,3)=USRNDX
  1. K ^TMP("USRWHO",$J,"USRWHO2")
  1. Q
  1. ;
  1. ;======================================================================
  1. WHATIS(USER,CLASS,NAME01) ; Given a User, set array of classes USER belongs to
  1. ; USER is pointer to file 200
  1. ; CLASS is name of the array (local or global) to be set.
  1. ; Array is set in alpha order
  1. ; by name(display name or class name)in uppercase. Numeric indicator is appended to name
  1. ; to accomodate multiple memberships over time in the same class.
  1. ; ARRAY(Uppername_indicator)=UserClassIEN^MembershipIEN^name^EffectDt^ExpireDt
  1. ; NAME01 is optional. If NAME01>0 use .01 Class Name
  1. ; Otherwise, use Display Name
  1. N IND,GROUP,CLASSNM,CLASSCNT,USRCUR,USRDA,EFFCTV,EXPIRES,EFFCTV1,TMPDATA,UPCLASNM
  1. K ^TMP("USRWHATIS",$J)
  1. S (CLASSCNT,IND,GROUP)=0 S NAME01=+$G(NAME01)
  1. F S GROUP=$O(^USR(8930.3,"AUC",USER,GROUP)) Q:+GROUP'>0 D
  1. . S USRDA=0
  1. . F S USRDA=$O(^USR(8930.3,"AUC",USER,GROUP,USRDA)) Q:+USRDA'>0 D
  1. .. S USRCUR="E",EFFCTV1=""
  1. .. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3) S:EFFCTV="" EFFCTV1=DT
  1. .. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4) S:EXPIRES="" EXPIRES=9999999
  1. .. I EFFCTV'>DT,EXPIRES'<DT S USRCUR="C"
  1. .. I EFFCTV>DT S USRCUR="F"
  1. .. S CLASSNM=$$CLNAME(+GROUP,+$G(NAME01)),UPCLASNM=$$UP^XLFSTR(CLASSNM)
  1. .. S TMPDATA=GROUP_U_USRDA_U_CLASSNM_U_EFFCTV_U_$S(EXPIRES=9999999:"",1:EXPIRES)
  1. .. S ^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,$S(EFFCTV="":EFFCTV1,1:EFFCTV),EXPIRES)=TMPDATA
  1. I $D(^TMP("USRWHATIS",$J)) D
  1. . S UPCLASNM=""
  1. . F S UPCLASNM=$O(^TMP("USRWHATIS",$J,UPCLASNM)) Q:UPCLASNM="" D
  1. .. F USRCUR="F","E","C" D
  1. ... S EFFCTV=""
  1. ... F S EFFCTV=$O(^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,EFFCTV)) Q:EFFCTV="" D
  1. .... S EXPIRES=""
  1. .... F S EXPIRES=$O(^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,EFFCTV,EXPIRES)) Q:EXPIRES="" D
  1. ..... S IND=IND+1
  1. ..... S @CLASS@(UPCLASNM_IND)=$G(^TMP("USRWHATIS",$J,UPCLASNM,USRCUR,EFFCTV,EXPIRES))
  1. ..... S CLASSCNT=+$G(CLASSCNT)+1
  1. S @CLASS@(0)=USER_U_$$SIGNAME^USRLS(+USER)_U_CLASSCNT
  1. K ^TMP("USRWHATIS",$J)
  1. Q
  1. ;======================================================================
  1. 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.
  1. N USRREC,USRY
  1. S USRREC=$G(^USR(8930,+CLASS,0))
  1. Q $S(+$G(NAME01)>0:$P(USRREC,U),$P(USRREC,U,4)]"":$P(USRREC,U,4),1:$$MIXED^USRLS($P(USRREC,U)))
  1. ;
  1. ;======================================================================
  1. PUT(USER,CLASS) ; Make user a member of a given class
  1. N DIC,DLAYGO,DA,DR,DIE,X,Y
  1. S (DIC,DLAYGO)=8930.3,DIC(0)="LXF",X=""""_"`"_USER_"""" D ^DIC Q:+Y'>0
  1. S DIE=DIC,DA=+Y,DR=".02///"_CLASS_";.03///"_DT
  1. D ^DIE
  1. Q
  1. ;======================================================================
  1. SUBCLASS(DA,CLASS) ; Evaluate whether a given USER CLASS is a DESCENDENT
  1. ; of another class
  1. ; Receives DA = record # of possible subclass in 8930, and
  1. ; CLASS = record # of possible descendent class in 8930
  1. N USRI,USRY S (USRI,USRY)=0
  1. I +$G(DA)'>0 S DA=+$O(^USR(8930,"B",DA,0))
  1. I +$G(CLASS)'>0 S CLASS=+$O(^USR(8930,"B",CLASS,0))
  1. F S USRI=$O(^USR(8930,"AD",DA,USRI)) Q:+USRI'>0!(USRY=1) D
  1. . I USRI=CLASS S USRY=1 Q
  1. . S USRY=$$SUBCLASS(USRI,CLASS)
  1. Q USRY
  1. ;======================================================================
  1. 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.
  1. N USRMLST,USRY S USRY=0
  1. D WHOIS1^USRLM1("USRMLST",USRCLDA,+$G(NAME01))
  1. I +$P(USRMLST(0),U,3)>0 S USRY=1 W " There are members of the class ",$$CLNAME(USRCLDA,+$G(NAME01))
  1. Q USRY