Released USR*1*8 SEQ #8
Extracted from mail message
**KIDS**:USR*1.0*8^
**INSTALL NAME**
USR*1.0*8
"BLD",852,0)
USR*1.0*8^AUTHORIZATION/SUBSCRIPTION^0^2980709^y
"BLD",852,1,0)
^^2^2^2980709^^^^
"BLD",852,1,1,0)
ASU patch 8, USR*1.0*8. This patch allows for two users to have the same
"BLD",852,1,2,0)
name. See the National Patch Module for a complete description.
"BLD",852,4,0)
^9.64PA^^0
"BLD",852,"ABPKG")
n
"BLD",852,"INI")
"BLD",852,"INIT")
"BLD",852,"KRN",0)
^9.67PA^8994^18
"BLD",852,"KRN",.4,0)
.4
"BLD",852,"KRN",.4,"NM",0)
^9.68A^^0
"BLD",852,"KRN",.401,0)
.401
"BLD",852,"KRN",.401,"NM",0)
^9.68A^^
"BLD",852,"KRN",.402,0)
.402
"BLD",852,"KRN",.403,0)
.403
"BLD",852,"KRN",.5,0)
.5
"BLD",852,"KRN",.84,0)
.84
"BLD",852,"KRN",3.6,0)
3.6
"BLD",852,"KRN",3.8,0)
3.8
"BLD",852,"KRN",9.2,0)
9.2
"BLD",852,"KRN",9.8,0)
9.8
"BLD",852,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",852,"KRN",9.8,"NM",1,0)
USRUMMBR^^0^B14142338
"BLD",852,"KRN",9.8,"NM",2,0)
USRLM^^0^B41142780
"BLD",852,"KRN",9.8,"NM","B","USRLM",2)
"BLD",852,"KRN",9.8,"NM","B","USRUMMBR",1)
"BLD",852,"KRN",19,0)
19
"BLD",852,"KRN",19,"NM",0)
^9.68A^^0
"BLD",852,"KRN",19.1,0)
19.1
"BLD",852,"KRN",19.1,"NM",0)
^9.68A^^
"BLD",852,"KRN",101,0)
101
"BLD",852,"KRN",101,"NM",0)
^9.68A^^0
"BLD",852,"KRN",409.61,0)
409.61
"BLD",852,"KRN",409.61,"NM",0)
^9.68A^^0
"BLD",852,"KRN",771,0)
771
"BLD",852,"KRN",869.2,0)
869.2
"BLD",852,"KRN",870,0)
870
"BLD",852,"KRN",8994,0)
8994
"BLD",852,"KRN","B",.4,.4)
"BLD",852,"KRN","B",.401,.401)
"BLD",852,"KRN","B",.402,.402)
"BLD",852,"KRN","B",.403,.403)
"BLD",852,"KRN","B",.5,.5)
"BLD",852,"KRN","B",.84,.84)
"BLD",852,"KRN","B",3.6,3.6)
"BLD",852,"KRN","B",3.8,3.8)
"BLD",852,"KRN","B",9.2,9.2)
"BLD",852,"KRN","B",9.8,9.8)
"BLD",852,"KRN","B",19,19)
"BLD",852,"KRN","B",19.1,19.1)
"BLD",852,"KRN","B",101,101)
"BLD",852,"KRN","B",409.61,409.61)
"BLD",852,"KRN","B",771,771)
"BLD",852,"KRN","B",869.2,869.2)
"BLD",852,"KRN","B",870,870)
"BLD",852,"KRN","B",8994,8994)
"BLD",852,"QUES",0)
^9.62^^
"BLD",852,"REQB",0)
^9.611^1^1
"BLD",852,"REQB",1,0)
USR*1.0*7^2
"BLD",852,"REQB","B","USR*1.0*7",1)
"PKG",419,-1)
1^1
"PKG",419,0)
AUTHORIZATION/SUBSCRIPTION^USR^User Authorization
"PKG",419,20,0)
^9.402P^^
"PKG",419,22,0)
^9.49I^1^1
"PKG",419,22,1,0)
1.0^2970620^2971124^117
"PKG",419,22,1,"PAH",1,0)
8^2980709
"PKG",419,22,1,"PAH",1,1,0)
^^2^2^2980709
"PKG",419,22,1,"PAH",1,1,1,0)
ASU patch 8, USR*1.0*8. This patch allows for two users to have the same
"PKG",419,22,1,"PAH",1,1,2,0)
name. See the National Patch Module for a complete description.
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")
"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
YES
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
2
"RTN","USRLM")
0^2^B41142780
"RTN","USRLM",1,0)
USRLM ; SLC/JER - User Class Membership functions and proc's ;07/09/98
"RTN","USRLM",2,0)
;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,6,7,8**;Jun 20, 1997
"RTN","USRLM",3,0)
ISA(USER,CLASS,ERR) ; Boolean - Is USER a Member of CLASS?
"RTN","USRLM",4,0)
N USRY,USRI
"RTN","USRLM",5,0)
I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
"RTN","USRLM",6,0)
I '+USER S USER=+$O(^VA(200,"B",USER,0))
"RTN","USRLM",7,0)
I +USER'>0 S ERR="INVALID USER" Q 0
"RTN","USRLM",8,0)
I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
"RTN","USRLM",9,0)
I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
"RTN","USRLM",10,0)
; If USER is a member of CLASS return true
"RTN","USRLM",11,0)
S USRY=0
"RTN","USRLM",12,0)
I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
"RTN","USRLM",13,0)
. N USRMDA
"RTN","USRLM",14,0)
. S USRMDA=0
"RTN","USRLM",15,0)
. F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
"RTN","USRLM",16,0)
.. S USRY=+$$CURRENT(USRMDA)
"RTN","USRLM",17,0)
I USRY Q USRY
"RTN","USRLM",18,0)
; Otherwise, check to see if user is a member of any subclass of CLASS
"RTN","USRLM",19,0)
S USRI=0
"RTN","USRLM",20,0)
F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
"RTN","USRLM",21,0)
. N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
"RTN","USRLM",22,0)
. S USRY=$$ISA(USER,USRSUB) ; Recurse to find members of subclass
"RTN","USRLM",23,0)
ISAX Q +$G(USRY)
"RTN","USRLM",24,0)
;======================================================================
"RTN","USRLM",25,0)
ISAWM(USER,CLASS) ; Boolean - Is USER a Member of CLASS, with message.
"RTN","USRLM",26,0)
I $$ISA(USER,CLASS) D Q 1
"RTN","USRLM",27,0)
. W !,"Already a member of this class"
"RTN","USRLM",28,0)
. H 2
"RTN","USRLM",29,0)
E Q 0
"RTN","USRLM",30,0)
;
"RTN","USRLM",31,0)
;======================================================================
"RTN","USRLM",32,0)
CURRENT(MEMBER) ; Boolean - Is Membership current?
"RTN","USRLM",33,0)
N USRIN,USROUT,USRY
"RTN","USRLM",34,0)
S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
"RTN","USRLM",35,0)
S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
"RTN","USRLM",36,0)
I USRIN'>DT,$S(USROUT>0&(USROUT'
0) D
"RTN","USRLM",52,0)
. I TERMDATE<$$NOW^XLFDT S TERM=1
"RTN","USRLM",53,0)
Q TERM
"RTN","USRLM",54,0)
;
"RTN","USRLM",55,0)
;======================================================================
"RTN","USRLM",56,0)
RESIZE(LONG,SHORT,SHRINK) ; Resizes list area
"RTN","USRLM",57,0)
N USRBM S USRBM=$S(VALMMENU:SHORT,+$G(SHRINK):SHORT,1:LONG)
"RTN","USRLM",58,0)
I VALM("BM")'=USRBM S VALMBCK="R" D
"RTN","USRLM",59,0)
. S VALM("BM")=USRBM,VALM("LINES")=(USRBM-VALM("TM"))+1
"RTN","USRLM",60,0)
. I +$G(VALMCC) D RESET^VALM4
"RTN","USRLM",61,0)
Q
"RTN","USRLM",62,0)
;======================================================================
"RTN","USRLM",63,0)
TERM ;Actions to be taken when a user is terminated. Invoked by
"RTN","USRLM",64,0)
;XU USER TERMINATE. XUIFN is the user being terminated.
"RTN","USRLM",65,0)
N IND,NOW,OLDTERM
"RTN","USRLM",66,0)
S NOW=$$NOW^XLFDT
"RTN","USRLM",67,0)
S IND=""
"RTN","USRLM",68,0)
F S IND=$O(^USR(8930.3,"B",XUIFN,IND)) Q:IND="" D
"RTN","USRLM",69,0)
. S OLDTERM=+$P($G(^USR(8930.3,IND,0)),U,4)
"RTN","USRLM",70,0)
. I (OLDTERM>0)&(OLDTERM0 D
"RTN","USRLM",82,0)
. S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,0)) Q:+USRDA'>0
"RTN","USRLM",83,0)
. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3)
"RTN","USRLM",84,0)
. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4)
"RTN","USRLM",85,0)
. S USRCLNM=$$CLNAME(+CLASS)
"RTN","USRLM",86,0)
. S @MEMBER@(USRDA)=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES
"RTN","USRLM",87,0)
. S USRCNT=+$G(USRCNT)+1
"RTN","USRLM",88,0)
I '$D(@MEMBER@(0)) S @MEMBER@(0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
"RTN","USRLM",89,0)
S $P(@MEMBER@(0),U,3)=USRCNT
"RTN","USRLM",90,0)
S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
"RTN","USRLM",91,0)
. N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
"RTN","USRLM",92,0)
. D WHOIS(MEMBER,USRSUB) ; Recurse to find members of subclass
"RTN","USRLM",93,0)
Q
"RTN","USRLM",94,0)
WHOIS2(MEMBER,CLASS) ; Given a Class, return list of CURRENT members
"RTN","USRLM",95,0)
; CLASS is pointer to file 8930
"RTN","USRLM",96,0)
; MEMBER is name of array (local or global) in which members are
"RTN","USRLM",97,0)
; returned in alphabetical order by name - indexed by number
"RTN","USRLM",98,0)
; i.e. @MEMBER@(1 ...n)
"RTN","USRLM",99,0)
; @member@(0) = ien of8930^usr class name^count of members
"RTN","USRLM",100,0)
; @member@(1..n)=
"RTN","USRLM",101,0)
; 1 2 3 4 5 6 7 8
"RTN","USRLM",102,0)
; p200^p8930.3^classname^effectdate^inactdate^username^title^mailcode
"RTN","USRLM",103,0)
; Note: For pieces 2,4 & 5 - Only one of potentially many is returned
"RTN","USRLM",104,0)
;
"RTN","USRLM",105,0)
N USER,USRNM,USRCLNM,USRCNT,USRDA,USRNDX,EFFCTV,EXPIRES,USRI
"RTN","USRLM",106,0)
D WHOISTMP(.CLASS)
"RTN","USRLM",107,0)
S USRNM="",USRNDX=0
"RTN","USRLM",108,0)
F S USRNM=$O(^TMP($J,"USRWHO2","B",USRNM)) Q:USRNM']"" D
"RTN","USRLM",109,0)
. S USER=0 F S USER=$O(^TMP($J,"USRWHO2","B",USRNM,USER)) Q:'USER D
"RTN","USRLM",110,0)
. . S USRNDX=USRNDX+1
"RTN","USRLM",111,0)
. . S @MEMBER@(USRNDX)=^TMP($J,"USRWHO2",USER)
"RTN","USRLM",112,0)
S @MEMBER@(0)=^TMP($J,"USRWHO2",0)
"RTN","USRLM",113,0)
S $P(@MEMBER@(0),U,3)=USRNDX
"RTN","USRLM",114,0)
K ^TMP($J,"USRWHO2")
"RTN","USRLM",115,0)
Q
"RTN","USRLM",116,0)
WHOISTMP(CLASS) ; Given a Class, return list of CURRENT members into ^TMP
"RTN","USRLM",117,0)
; CLASS is pointer to file 8930
"RTN","USRLM",118,0)
; MEMBER is name of array (local or global) in which members are
"RTN","USRLM",119,0)
; returned in order by user/x-ref by name
"RTN","USRLM",120,0)
; main = ^tmp($j,"USRWHO2",user)
"RTN","USRLM",121,0)
; x-ref= ^tmp($j,"USRWHO2","b",usrnm,user)
"RTN","USRLM",122,0)
; -- used by whois2 call
"RTN","USRLM",123,0)
N USER,USRNM,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRMC,USRTIT,USRX
"RTN","USRLM",124,0)
S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
"RTN","USRLM",125,0)
F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
"RTN","USRLM",126,0)
. S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,0)) Q:+USRDA'>0
"RTN","USRLM",127,0)
. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3)
"RTN","USRLM",128,0)
. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4)
"RTN","USRLM",129,0)
. S USRNM=$P($G(^VA(200,+USER,0)),U)
"RTN","USRLM",130,0)
. S USRX=$P($G(^VA(200,+USER,0)),U,9)
"RTN","USRLM",131,0)
. S USRTIT=$$EXTERNAL^DILFD(200,8,"",USRX)
"RTN","USRLM",132,0)
. S USRMC=$P($G(^VA(200,+USER,5)),U,2)
"RTN","USRLM",133,0)
. S USRCLNM=$$CLNAME(+CLASS)
"RTN","USRLM",134,0)
. S ^TMP($J,"USRWHO2",USER)=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES_U_USRNM_U_USRTIT_U_USRMC
"RTN","USRLM",135,0)
. S ^TMP($J,"USRWHO2","B",USRNM,USER)=""
"RTN","USRLM",136,0)
. S USRCNT=+$G(USRCNT)+1
"RTN","USRLM",137,0)
I '$D(^TMP($J,"USRWHO2",0))#2 S ^TMP($J,"USRWHO2",0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
"RTN","USRLM",138,0)
S $P(^TMP($J,"USRWHO2",0),U,3)=USRCNT
"RTN","USRLM",139,0)
S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
"RTN","USRLM",140,0)
. N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
"RTN","USRLM",141,0)
. D WHOISTMP(USRSUB) ; Recurse to find members of subclass
"RTN","USRLM",142,0)
Q
"RTN","USRLM",143,0)
WHATIS(USER,CLASS) ; Given a User, return list of class memberships
"RTN","USRLM",144,0)
; USER is pointer to file 200
"RTN","USRLM",145,0)
; CLASS is name of array (local or global) in which the list of
"RTN","USRLM",146,0)
; classes to which the USER belongs will be returned in
"RTN","USRLM",147,0)
; alphabetic order by class name
"RTN","USRLM",148,0)
N IND,GROUP,CLASSNM,CLASSCNT,USRDA,EFFCTV,EXPIRES
"RTN","USRLM",149,0)
S (CLASSCNT,IND,GROUP)=0
"RTN","USRLM",150,0)
F S GROUP=$O(^USR(8930.3,"AUC",USER,GROUP)) Q:+GROUP'>0 D
"RTN","USRLM",151,0)
. S USRDA=0
"RTN","USRLM",152,0)
. F S USRDA=$O(^USR(8930.3,"AUC",USER,GROUP,USRDA)) Q:+USRDA'>0 D
"RTN","USRLM",153,0)
.. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3)
"RTN","USRLM",154,0)
.. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4)
"RTN","USRLM",155,0)
.. S CLASSNM=$$CLNAME(+GROUP)
"RTN","USRLM",156,0)
.. S IND=IND+1
"RTN","USRLM",157,0)
.. S @CLASS@(CLASSNM_IND)=GROUP_U_USRDA_U_CLASSNM_U_EFFCTV_U_EXPIRES
"RTN","USRLM",158,0)
.. S CLASSCNT=+$G(CLASSCNT)+1
"RTN","USRLM",159,0)
S @CLASS@(0)=USER_U_$$SIGNAME^USRLS(+USER)_U_CLASSCNT
"RTN","USRLM",160,0)
Q
"RTN","USRLM",161,0)
CLNAME(CLASS) ; Given a class, return the Display Name
"RTN","USRLM",162,0)
N USRREC,USRY
"RTN","USRLM",163,0)
S USRREC=$G(^USR(8930,+CLASS,0))
"RTN","USRLM",164,0)
Q $S($P(USRREC,U,4)]"":$P(USRREC,U,4),1:$$MIXED^USRLS($P(USRREC,U)))
"RTN","USRLM",165,0)
PUT(USER,CLASS) ; Make user a member of a given class
"RTN","USRLM",166,0)
N DIC,DLAYGO,DA,DR,DIE,X,Y
"RTN","USRLM",167,0)
S (DIC,DLAYGO)=8930.3,DIC(0)="LXF",X=""""_"`"_USER_"""" D ^DIC Q:+Y'>0
"RTN","USRLM",168,0)
S DIE=DIC,DA=+Y,DR=".02///"_CLASS_";.03///"_DT
"RTN","USRLM",169,0)
D ^DIE
"RTN","USRLM",170,0)
Q
"RTN","USRLM",171,0)
SUBCLASS(DA,CLASS) ; Evaluate whether a given USER CLASS is a DESCENDENT
"RTN","USRLM",172,0)
; of another class
"RTN","USRLM",173,0)
; Receives DA = record # of possible subclass in 8930, and
"RTN","USRLM",174,0)
; CLASS = record # of possible descendent class in 8930
"RTN","USRLM",175,0)
N USRI,USRY S (USRI,USRY)=0
"RTN","USRLM",176,0)
I +$G(DA)'>0 S DA=+$O(^USR(8930,"B",DA,0))
"RTN","USRLM",177,0)
I +$G(CLASS)'>0 S CLASS=+$O(^USR(8930,"B",CLASS,0))
"RTN","USRLM",178,0)
F S USRI=$O(^USR(8930,"AD",DA,USRI)) Q:+USRI'>0!(USRY=1) D
"RTN","USRLM",179,0)
. I USRI=CLASS S USRY=1 Q
"RTN","USRLM",180,0)
. S USRY=$$SUBCLASS(USRI,CLASS)
"RTN","USRLM",181,0)
Q USRY
"RTN","USRLM",182,0)
CANDEL(USRCLDA) ; Evaluate whether user can delete a class
"RTN","USRLM",183,0)
N USRMLST,USRY S USRY=0
"RTN","USRLM",184,0)
D WHOIS("USRMLST",USRCLDA)
"RTN","USRLM",185,0)
I +$P(USRMLST(0),U,3)>0 S USRY=1 W " There are members of the class ",$$CLNAME(USRCLDA)
"RTN","USRLM",186,0)
Q USRY
"RTN","USRUMMBR")
0^1^B14142338
"RTN","USRUMMBR",1,0)
USRUMMBR ; SLC/JER - User Class Membership by User actions ;06/09/98
"RTN","USRUMMBR",2,0)
;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,5,6,7,8**;Jun 20, 1997
"RTN","USRUMMBR",3,0)
EDIT ; Edit user's class membership
"RTN","USRUMMBR",4,0)
N USRDA,USRDATA,USREXPND,USRI,USRSTAT,DIROUT,USRCHNG,USRLST
"RTN","USRUMMBR",5,0)
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
"RTN","USRUMMBR",6,0)
S (USRCHNG,USRI)=0
"RTN","USRUMMBR",7,0)
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
"RTN","USRUMMBR",8,0)
. S USRDATA=$G(^TMP("USRUSERIDX",$J,USRI))
"RTN","USRUMMBR",9,0)
. W !!,"Editing #",+USRDATA,!
"RTN","USRUMMBR",10,0)
. S USRDA=+$P(USRDATA,U,2) D EDIT1
"RTN","USRUMMBR",11,0)
. I +$G(USRCHNG) S USRLST=$S($L($G(USRLST)):$G(USRLST)_", ",1:"")_USRI
"RTN","USRUMMBR",12,0)
. I $D(USRDATA) D UPDATE^USRUM(USRDATA)
"RTN","USRUMMBR",13,0)
W !,"Refreshing the list."
"RTN","USRUMMBR",14,0)
S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" Edited **"
"RTN","USRUMMBR",15,0)
K VALMY S VALMBCK="R"
"RTN","USRUMMBR",16,0)
Q
"RTN","USRUMMBR",17,0)
EDIT1 ; Single record edit
"RTN","USRUMMBR",18,0)
; Receives USRDA
"RTN","USRUMMBR",19,0)
N DA,DIE,DR
"RTN","USRUMMBR",20,0)
I '+$G(USRDA) W !,"No Member selected." H 2 S USRCHNG=0 Q
"RTN","USRUMMBR",21,0)
S DIE="^USR(8930.3,",DA=USRDA,DR="[USR MEMBERSHIP EDIT]"
"RTN","USRUMMBR",22,0)
D FULL^VALM1,^DIE S USRCHNG=1
"RTN","USRUMMBR",23,0)
Q
"RTN","USRUMMBR",24,0)
ADD ; Add a membership to selected classes for current user
"RTN","USRUMMBR",25,0)
N CLASSADD,DIC,DLAYGO,FDA,MSG,X,Y
"RTN","USRUMMBR",26,0)
N I2N,FDA,FDAIEN,MSG
"RTN","USRUMMBR",27,0)
N USRCLASS,USRCREAT,USRUSER,USRCNT,USRQUIT
"RTN","USRUMMBR",28,0)
D FULL^VALM1
"RTN","USRUMMBR",29,0)
I $$ISTERM^USRLM(USRDUZ) D Q
"RTN","USRUMMBR",30,0)
. W !,"You cannot add class memberships, this user is terminated!"
"RTN","USRUMMBR",31,0)
. H 2
"RTN","USRUMMBR",32,0)
S USRCNT=0
"RTN","USRUMMBR",33,0)
F D Q:+$G(USRQUIT)
"RTN","USRUMMBR",34,0)
. W !
"RTN","USRUMMBR",35,0)
. S DIC=8930,DIC(0)="AEMQ"
"RTN","USRUMMBR",36,0)
. S DIC("A")="Select "_$S(USRCNT'>0:"",1:"Another ")_"USER CLASS: "
"RTN","USRUMMBR",37,0)
. D ^DIC I +Y'>0 S USRQUIT=1 Q
"RTN","USRUMMBR",38,0)
. S USRCLASS=+Y
"RTN","USRUMMBR",39,0)
. S DIC=200,DIC(0)="NMX",X="`"_USRDUZ
"RTN","USRUMMBR",40,0)
.;Make sure the user is not already a member of this class.
"RTN","USRUMMBR",41,0)
. I $$ISAWM^USRLM(USRDUZ,USRCLASS) S USRQUIT=1 Q
"RTN","USRUMMBR",42,0)
. K FDA,FDAIEN,MSG
"RTN","USRUMMBR",43,0)
. S CLASSADD=0
"RTN","USRUMMBR",44,0)
. S I2N="+1,"
"RTN","USRUMMBR",45,0)
. S FDA(8930.3,I2N,.01)=USRDUZ
"RTN","USRUMMBR",46,0)
. S FDA(8930.3,I2N,.02)=USRCLASS
"RTN","USRUMMBR",47,0)
. D UPDATE^DIE("","FDA","FDAIEN","MSG")
"RTN","USRUMMBR",48,0)
. I +$G(FDAIEN(1))>0 D
"RTN","USRUMMBR",49,0)
.. S CLASSADD=1
"RTN","USRUMMBR",50,0)
.. S DA=+FDAIEN(1),DIE=8930.3,DIE("NO^")="BACK"
"RTN","USRUMMBR",51,0)
.. S DR=".03;.04" D ^DIE
"RTN","USRUMMBR",52,0)
.. I $D(Y) D
"RTN","USRUMMBR",53,0)
... S DIK=DIC D ^DIK K DIK
"RTN","USRUMMBR",54,0)
... S CLASSADD=0
"RTN","USRUMMBR",55,0)
. I 'CLASSADD D Q
"RTN","USRUMMBR",56,0)
.. W !,"Error adding ",$$CLNAME^USRLM(+$P($G(^USR(8930.3,+DA,0)),U,2))
"RTN","USRUMMBR",57,0)
. E S USRCNT=USRCNT+1
"RTN","USRUMMBR",58,0)
W !,"Rebuilding membership list."
"RTN","USRUMMBR",59,0)
D BUILD^USRULST(USRDUZ)
"RTN","USRUMMBR",60,0)
I USRCNT>0 D
"RTN","USRUMMBR",61,0)
. S USRUSER=$$SIGNAME^USRLS(+$G(USRDUZ))
"RTN","USRUMMBR",62,0)
. S VALMSG="** "_USRUSER_" added to "_USRCNT_" classes **"
"RTN","USRUMMBR",63,0)
S VALMCNT=+$G(@VALMAR@(0))
"RTN","USRUMMBR",64,0)
S VALMBCK="R"
"RTN","USRUMMBR",65,0)
Q
"RTN","USRUMMBR",66,0)
DELETE ; Delete a member of the class
"RTN","USRUMMBR",67,0)
N DIE,X,Y,USRCLASS D FULL^VALM1
"RTN","USRUMMBR",68,0)
N USRCLASS,USRDA,USRCHNG,USRDATA,USRI,USRLST,DIROUT
"RTN","USRUMMBR",69,0)
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
"RTN","USRUMMBR",70,0)
S USRI=0
"RTN","USRUMMBR",71,0)
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
"RTN","USRUMMBR",72,0)
. S USRDATA=$G(^TMP("USRUSERIDX",$J,USRI))
"RTN","USRUMMBR",73,0)
. S USRDA=+$P(USRDATA,U,2) D DELETE1(USRDA)
"RTN","USRUMMBR",74,0)
. S:+USRCHNG USRLST=$S(+$G(USRLST):USRLST_", ",1:"")_+USRDATA
"RTN","USRUMMBR",75,0)
. I $D(USRDATA) D UPDATE^USRUM(USRDATA)
"RTN","USRUMMBR",76,0)
W !,"Rebuilding the list."
"RTN","USRUMMBR",77,0)
S USRCLASS=+$G(^TMP("USRU",$J,0))
"RTN","USRUMMBR",78,0)
D BUILD^USRULST(USRDUZ)
"RTN","USRUMMBR",79,0)
S VALMCNT=+$G(@VALMAR@(0))
"RTN","USRUMMBR",80,0)
K VALMY S VALMBCK="R"
"RTN","USRUMMBR",81,0)
S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" removed **"
"RTN","USRUMMBR",82,0)
Q
"RTN","USRUMMBR",83,0)
DELETE1(DA) ; Delete one member from a class
"RTN","USRUMMBR",84,0)
N DIE,DR,USER,CLASS,USRMEM S USRMEM=$G(^USR(8930.3,+DA,0))
"RTN","USRUMMBR",85,0)
I USRMEM']"" W !,"Record #",DA," NOT FOUND!" Q
"RTN","USRUMMBR",86,0)
S USER=$P($G(^VA(200,+USRMEM,0)),U)
"RTN","USRUMMBR",87,0)
S CLASS=$P($G(^USR(8930,+$P(USRMEM,U,2),0)),U)
"RTN","USRUMMBR",88,0)
W !,"Removing ",USER," from ",CLASS
"RTN","USRUMMBR",89,0)
I '$$READ^USRU("Y","Are you SURE","NO") S USRCHNG=0 W !,USER," NOT Removed from ",CLASS,"." H 2 Q
"RTN","USRUMMBR",90,0)
S USRCHNG=1
"RTN","USRUMMBR",91,0)
S DIK="^USR(8930.3," D ^DIK W "."
"RTN","USRUMMBR",92,0)
Q
"VER")
8.0^21.0
**END**
**END**