- USRLM1 ; SLC/MAM - User Class Membership functions and proc's Cont ; 03/04/10
- ;;1.0;AUTHORIZATION/SUBSCRIPTION;**33**;Jun 20, 1997;Build 7
- ;======================================================================
- WHOISTMP(CLASS,NAME01) ; Given a Class, return list of CURRENT members into ^TMP
- ; Uses 8930.3 xref ACU
- ; CLASS is pointer to file 8930
- ; MEMBER is name of array (local or global) in which members are
- ; returned in order by user/x-ref by name
- ; main = ^tmp("USRWHO",$j,"USRWHO2",user)
- ; x-ref= ^tmp("USRWHO",$j,"USRWHO2","b",usrnm,user)
- ; -- used by whois2 call
- ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
- N USER,USRNM,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRMC,USRTIT,IENS
- S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
- F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
- . S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,0)) Q:+USRDA'>0 ;User membership DA
- . S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3)
- . S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4)
- . S USRNM=$$PERSNAME(+USER)
- . S IENS=+USER_",",USRTIT=$$GET1^DIQ(200,IENS,8,,,"ERR") ; Title ICR 10060
- . S USRMC=$$GET1^DIQ(200,IENS,28,,,"ERR") ;MAIL CODE ICR 10060
- . S USRCLNM=$$CLNAME^USRLM(+CLASS,+$G(NAME01))
- . S ^TMP("USRWHO",$J,"USRWHO2",USER)=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES_U_USRNM_U_USRTIT_U_USRMC
- . S ^TMP("USRWHO",$J,"USRWHO2","B",USRNM,USER)=""
- . S USRCNT=+$G(USRCNT)+1
- I '$D(^TMP("USRWHO",$J,"USRWHO2",0))#2 S ^TMP("USRWHO",$J,"USRWHO2",0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
- S $P(^TMP("USRWHO",$J,"USRWHO2",0),U,3)=USRCNT
- S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
- . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
- . D WHOISTMP(USRSUB,+$G(NAME01)) ; Recurs to find members of subclass
- Q
- ;======================================================================
- WHOIS1(MEMBER,CLASS,NAME01) ; Given a Class, return list of CURRENT members.
- ;Used in CANDEL^USRLM but can't find where CANDEL is used.
- ; WHOIS2^USRLM does the same thing more efficiently. Putting WHOIS here just in case...
- ; 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, not Display name.
- N USER,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRNAME,EFFCTV1,EXPIRES1
- K ^TMP("USRWHOIS",$J)
- S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
- F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
- . S USRDA=""
- . F S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,USRDA)) Q:USRDA="" D
- .. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3) S:EFFCTV="" EFFCTV1="0000000"
- .. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4) S:EXPIRES="" EXPIRES1=9999999
- .. S USRCLNM=$$CLNAME^USRLM(+CLASS,+$G(NAME01))
- .. S USRNAME=$$GET1^DIQ(200,USER,.01)
- .. S ^TMP("USRWHOIS",$J,USRNAME,$S(EFFCTV="":EFFCTV1,1:EFFCTV),$S(EXPIRES="":EXPIRES1,1:EXPIRES))=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES
- .. S USRCNT=+$G(USRCNT)+1
- I $D(^TMP("USRWHOIS",$J)) D
- . S USRNAME="" F S USRNAME=$O(^TMP("USRWHOIS",$J,USRNAME)) Q:USRNAME="" D
- .. S EFFCTV="" F S EFFCTV=$O(^TMP("USRWHOIS",$J,USRNAME,EFFCTV)) Q:EFFCTV="" Q:EFFCTV>DT D
- ... S EXPIRES="" F S EXPIRES=$O(^TMP("USRWHOIS",$J,USRNAME,EFFCTV,EXPIRES),-1) Q:EXPIRES="" Q:EXPIRES<DT D
- .... S @MEMBER@(USRNAME)=$G(^TMP("USRWHOIS",$J,USRNAME,EFFCTV,EXPIRES))
- I '$D(@MEMBER@(0)) S @MEMBER@(0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
- S $P(@MEMBER@(0),U,3)=USRCNT
- S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
- . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
- . D WHOIS1(MEMBER,USRSUB,+$G(NAME01)) ; Recurs to find members of subclass
- K ^TMP("USRWHOIS",$J)
- Q
- PERSNAME(USER) ; Receives pointer to 200, returns name field
- N X S X=$$GET1^DIQ(200,USER,.01) ; ICR 10060
- Q $S($L(X):X,1:"UNKNOWN")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRLM1 3919 printed Feb 18, 2025@23:05:13 Page 2
- USRLM1 ; SLC/MAM - User Class Membership functions and proc's Cont ; 03/04/10
- +1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**33**;Jun 20, 1997;Build 7
- +2 ;======================================================================
- WHOISTMP(CLASS,NAME01) ; Given a Class, return list of CURRENT members into ^TMP
- +1 ; Uses 8930.3 xref ACU
- +2 ; CLASS is pointer to file 8930
- +3 ; MEMBER is name of array (local or global) in which members are
- +4 ; returned in order by user/x-ref by name
- +5 ; main = ^tmp("USRWHO",$j,"USRWHO2",user)
- +6 ; x-ref= ^tmp("USRWHO",$j,"USRWHO2","b",usrnm,user)
- +7 ; -- used by whois2 call
- +8 ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
- +9 NEW USER,USRNM,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRMC,USRTIT,IENS
- +10 SET USER=0
- SET USRCNT=+$PIECE($GET(@MEMBER@(0)),U,3)
- +11 FOR
- SET USER=$ORDER(^USR(8930.3,"ACU",CLASS,USER))
- if +USER'>0
- QUIT
- Begin DoDot:1
- +12 ;User membership DA
- SET USRDA=$ORDER(^USR(8930.3,"ACU",CLASS,USER,0))
- if +USRDA'>0
- QUIT
- +13 SET EFFCTV=$PIECE($GET(^USR(8930.3,+USRDA,0)),U,3)
- +14 SET EXPIRES=$PIECE($GET(^USR(8930.3,+USRDA,0)),U,4)
- +15 SET USRNM=$$PERSNAME(+USER)
- +16 ; Title ICR 10060
- SET IENS=+USER_","
- SET USRTIT=$$GET1^DIQ(200,IENS,8,,,"ERR")
- +17 ;MAIL CODE ICR 10060
- SET USRMC=$$GET1^DIQ(200,IENS,28,,,"ERR")
- +18 SET USRCLNM=$$CLNAME^USRLM(+CLASS,+$GET(NAME01))
- +19 SET ^TMP("USRWHO",$JOB,"USRWHO2",USER)=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES_U_USRNM_U_USRTIT_U_USRMC
- +20 SET ^TMP("USRWHO",$JOB,"USRWHO2","B",USRNM,USER)=""
- +21 SET USRCNT=+$GET(USRCNT)+1
- End DoDot:1
- +22 IF '$DATA(^TMP("USRWHO",$JOB,"USRWHO2",0))#2
- SET ^TMP("USRWHO",$JOB,"USRWHO2",0)=CLASS_U_$PIECE($GET(^USR(8930,+CLASS,0)),U)_U
- +23 SET $PIECE(^TMP("USRWHO",$JOB,"USRWHO2",0),U,3)=USRCNT
- +24 SET USRI=0
- FOR
- SET USRI=$ORDER(^USR(8930,+CLASS,1,USRI))
- if +USRI'>0
- QUIT
- Begin DoDot:1
- +25 NEW USRSUB
- SET USRSUB=+$GET(^USR(8930,+CLASS,1,USRI,0))
- if +USRSUB'>0
- QUIT
- +26 ; Recurs to find members of subclass
- DO WHOISTMP(USRSUB,+$GET(NAME01))
- End DoDot:1
- +27 QUIT
- +28 ;======================================================================
- WHOIS1(MEMBER,CLASS,NAME01) ; Given a Class, return list of CURRENT members.
- +1 ;Used in CANDEL^USRLM but can't find where CANDEL is used.
- +2 ; WHOIS2^USRLM does the same thing more efficiently. Putting WHOIS here just in case...
- +3 ; CLASS is pointer to file 8930
- +4 ; MEMBER is name of array (local or global) in which members are
- +5 ; returned in alphabetical order by name
- +6 ; NAME01 is optional. If NAME01>0 use .01 Class Name, not Display name.
- +7 NEW USER,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRNAME,EFFCTV1,EXPIRES1
- +8 KILL ^TMP("USRWHOIS",$JOB)
- +9 SET USER=0
- SET USRCNT=+$PIECE($GET(@MEMBER@(0)),U,3)
- +10 FOR
- SET USER=$ORDER(^USR(8930.3,"ACU",CLASS,USER))
- if +USER'>0
- QUIT
- Begin DoDot:1
- +11 SET USRDA=""
- +12 FOR
- SET USRDA=$ORDER(^USR(8930.3,"ACU",CLASS,USER,USRDA))
- if USRDA=""
- QUIT
- Begin DoDot:2
- +13 SET EFFCTV=$PIECE($GET(^USR(8930.3,+USRDA,0)),U,3)
- if EFFCTV=""
- SET EFFCTV1="0000000"
- +14 SET EXPIRES=$PIECE($GET(^USR(8930.3,+USRDA,0)),U,4)
- if EXPIRES=""
- SET EXPIRES1=9999999
- +15 SET USRCLNM=$$CLNAME^USRLM(+CLASS,+$GET(NAME01))
- +16 SET USRNAME=$$GET1^DIQ(200,USER,.01)
- +17 SET ^TMP("USRWHOIS",$JOB,USRNAME,$SELECT(EFFCTV="":EFFCTV1,1:EFFCTV),$SELECT(EXPIRES="":EXPIRES1,1:EXPIRES))=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES
- +18 SET USRCNT=+$GET(USRCNT)+1
- End DoDot:2
- End DoDot:1
- +19 IF $DATA(^TMP("USRWHOIS",$JOB))
- Begin DoDot:1
- +20 SET USRNAME=""
- FOR
- SET USRNAME=$ORDER(^TMP("USRWHOIS",$JOB,USRNAME))
- if USRNAME=""
- QUIT
- Begin DoDot:2
- +21 SET EFFCTV=""
- FOR
- SET EFFCTV=$ORDER(^TMP("USRWHOIS",$JOB,USRNAME,EFFCTV))
- if EFFCTV=""
- QUIT
- if EFFCTV>DT
- QUIT
- Begin DoDot:3
- +22 SET EXPIRES=""
- FOR
- SET EXPIRES=$ORDER(^TMP("USRWHOIS",$JOB,USRNAME,EFFCTV,EXPIRES),-1)
- if EXPIRES=""
- QUIT
- if EXPIRES<DT
- QUIT
- Begin DoDot:4
- +23 SET @MEMBER@(USRNAME)=$GET(^TMP("USRWHOIS",$JOB,USRNAME,EFFCTV,EXPIRES))
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 IF '$DATA(@MEMBER@(0))
- SET @MEMBER@(0)=CLASS_U_$PIECE($GET(^USR(8930,+CLASS,0)),U)_U
- +25 SET $PIECE(@MEMBER@(0),U,3)=USRCNT
- +26 SET USRI=0
- FOR
- SET USRI=$ORDER(^USR(8930,+CLASS,1,USRI))
- if +USRI'>0
- QUIT
- Begin DoDot:1
- +27 NEW USRSUB
- SET USRSUB=+$GET(^USR(8930,+CLASS,1,USRI,0))
- if +USRSUB'>0
- QUIT
- +28 ; Recurs to find members of subclass
- DO WHOIS1(MEMBER,USRSUB,+$GET(NAME01))
- End DoDot:1
- +29 KILL ^TMP("USRWHOIS",$JOB)
- +30 QUIT
- PERSNAME(USER) ; Receives pointer to 200, returns name field
- +1 ; ICR 10060
- NEW X
- SET X=$$GET1^DIQ(200,USER,.01)
- +2 QUIT $SELECT($LENGTH(X):X,1:"UNKNOWN")