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**