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 Dec 13, 2024@01:38:50 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")
