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

USRLM1.m

Go to the documentation of this file.
  1. 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
  1. ;======================================================================
  1. WHOISTMP(CLASS,NAME01) ; Given a Class, return list of CURRENT members into ^TMP
  1. ; Uses 8930.3 xref ACU
  1. ; CLASS is pointer to file 8930
  1. ; MEMBER is name of array (local or global) in which members are
  1. ; returned in order by user/x-ref by name
  1. ; main = ^tmp("USRWHO",$j,"USRWHO2",user)
  1. ; x-ref= ^tmp("USRWHO",$j,"USRWHO2","b",usrnm,user)
  1. ; -- used by whois2 call
  1. ; NAME01 is optional. If NAME01>0 use .01 Class Name in returned data.
  1. N USER,USRNM,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRMC,USRTIT,IENS
  1. S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
  1. F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
  1. . S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,0)) Q:+USRDA'>0 ;User membership DA
  1. . S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3)
  1. . S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4)
  1. . S USRNM=$$PERSNAME(+USER)
  1. . S IENS=+USER_",",USRTIT=$$GET1^DIQ(200,IENS,8,,,"ERR") ; Title ICR 10060
  1. . S USRMC=$$GET1^DIQ(200,IENS,28,,,"ERR") ;MAIL CODE ICR 10060
  1. . S USRCLNM=$$CLNAME^USRLM(+CLASS,+$G(NAME01))
  1. . S ^TMP("USRWHO",$J,"USRWHO2",USER)=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES_U_USRNM_U_USRTIT_U_USRMC
  1. . S ^TMP("USRWHO",$J,"USRWHO2","B",USRNM,USER)=""
  1. . S USRCNT=+$G(USRCNT)+1
  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
  1. S $P(^TMP("USRWHO",$J,"USRWHO2",0),U,3)=USRCNT
  1. S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
  1. . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
  1. . D WHOISTMP(USRSUB,+$G(NAME01)) ; Recurs to find members of subclass
  1. Q
  1. ;======================================================================
  1. 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.
  1. ; WHOIS2^USRLM does the same thing more efficiently. Putting WHOIS here just in case...
  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, not Display name.
  1. N USER,USRCLNM,USRCNT,USRDA,EFFCTV,EXPIRES,USRI,USRNAME,EFFCTV1,EXPIRES1
  1. K ^TMP("USRWHOIS",$J)
  1. S USER=0,USRCNT=+$P($G(@MEMBER@(0)),U,3)
  1. F S USER=$O(^USR(8930.3,"ACU",CLASS,USER)) Q:+USER'>0 D
  1. . S USRDA=""
  1. . F S USRDA=$O(^USR(8930.3,"ACU",CLASS,USER,USRDA)) Q:USRDA="" D
  1. .. S EFFCTV=$P($G(^USR(8930.3,+USRDA,0)),U,3) S:EFFCTV="" EFFCTV1="0000000"
  1. .. S EXPIRES=$P($G(^USR(8930.3,+USRDA,0)),U,4) S:EXPIRES="" EXPIRES1=9999999
  1. .. S USRCLNM=$$CLNAME^USRLM(+CLASS,+$G(NAME01))
  1. .. S USRNAME=$$GET1^DIQ(200,USER,.01)
  1. .. S ^TMP("USRWHOIS",$J,USRNAME,$S(EFFCTV="":EFFCTV1,1:EFFCTV),$S(EXPIRES="":EXPIRES1,1:EXPIRES))=USER_U_USRDA_U_USRCLNM_U_EFFCTV_U_EXPIRES
  1. .. S USRCNT=+$G(USRCNT)+1
  1. I $D(^TMP("USRWHOIS",$J)) D
  1. . S USRNAME="" F S USRNAME=$O(^TMP("USRWHOIS",$J,USRNAME)) Q:USRNAME="" D
  1. .. S EFFCTV="" F S EFFCTV=$O(^TMP("USRWHOIS",$J,USRNAME,EFFCTV)) Q:EFFCTV="" Q:EFFCTV>DT D
  1. ... S EXPIRES="" F S EXPIRES=$O(^TMP("USRWHOIS",$J,USRNAME,EFFCTV,EXPIRES),-1) Q:EXPIRES="" Q:EXPIRES<DT D
  1. .... S @MEMBER@(USRNAME)=$G(^TMP("USRWHOIS",$J,USRNAME,EFFCTV,EXPIRES))
  1. I '$D(@MEMBER@(0)) S @MEMBER@(0)=CLASS_U_$P($G(^USR(8930,+CLASS,0)),U)_U
  1. S $P(@MEMBER@(0),U,3)=USRCNT
  1. S USRI=0 F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0 D
  1. . N USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
  1. . D WHOIS1(MEMBER,USRSUB,+$G(NAME01)) ; Recurs to find members of subclass
  1. K ^TMP("USRWHOIS",$J)
  1. Q
  1. PERSNAME(USER) ; Receives pointer to 200, returns name field
  1. N X S X=$$GET1^DIQ(200,USER,.01) ; ICR 10060
  1. Q $S($L(X):X,1:"UNKNOWN")