source: WorldVistAEHR/trunk/r/AUTHORIZATION_SUBSCRIPTION-USR/USRULST.m@ 975

Last change on this file since 975 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1USRULST ; SLC/JER - List Class Membership by user ;9/6/01 14:47
2 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,4,9,10,16,17,21,22,28**;Jun 20, 1997
3 ; 30 Jun 00 MA - Added MAIN2 to prevent stack overflow
4 ; 20 Sep 00 MA - Removed MAIN2 and added GETUSER and chg protocol to
5 ; avoid looping through MAIN when doing a "CHANGE VIEW".
6 ; 7 Aug 01 MA - Removed line "S USRDUZ=+Y" from line tag GETUSER()
7 ; 6 Sep 01 MA - Added line "I +Y>0 S USRDUZ=Y" in GETUSER
8 ; to avoid adding USER Classes to the wrong person.
9MAIN ; Control Branching
10 N DIC,X,Y,USRDUZ
11 S DIC=200,DIC(0)="AEMQ",DIC("A")="Select USER: "
12 D ^DIC Q:+Y'>0
13 S USRDUZ=+Y
14 D EN^VALM(USRLTMPL)
15 Q
16GETUSER() ; Get a new user
17 N DIC,X,Y
18 S DIC=200,DIC(0)="AEMQ",DIC("A")="Select USER: "
19 D ^DIC ; If Y is not set then will use current USRDUZ
20 I +Y>0 S USRDUZ=+Y
21 Q USRDUZ
22MAKELIST ; Build review screen list
23 W !,"Searching for the User Classes."
24 D BUILD(USRDUZ)
25 Q
26BUILD(USRDUZ) ; Build List
27 ; DBIA 872 ^ORD(101)
28 N USRCNT,USRNAME,USRPICK
29 S (USRCNT,VALMCNT)=0
30 S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
31 K ^TMP("USRUSER",$J),^TMP("USRUSERIDX",$J),^TMP("USRU",$J)
32 D WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)")
33 S USRNAME=""
34 F S USRNAME=$O(^TMP("USRU",$J,USRNAME),-1) Q:USRNAME="" Q:USRNAME=0 D
35 . N USRDA,USREFF,USREXP,USRMEM,USRREC,USRCLNM
36 . S USRMEM=$G(^TMP("USRU",$J,USRNAME))
37 . S USRDA=+$P(USRMEM,U,2)
38 . S USRCLNM=$P(USRMEM,U,3)
39 . S USREFF=$$DATE^USRLS(+$P(USRMEM,U,4),"MM/DD/YY")
40 . S USREXP=$$DATE^USRLS(+$P(USRMEM,U,5),"MM/DD/YY")
41 . S USRCNT=+$G(USRCNT)+1
42 . S USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
43 . S USRREC=$$SETFLD^VALM1(USRCLNM,USRREC,"CLASS")
44 . S USRREC=$$SETFLD^VALM1(USREFF,USRREC,"EFFECTIVE")
45 . S USRREC=$$SETFLD^VALM1(USREXP,USRREC,"EXPIRES")
46 . S VALMCNT=+$G(VALMCNT)+1
47 . S ^TMP("USRUSER",$J,VALMCNT,0)=USRREC
48 . S ^TMP("USRUSER",$J,"IDX",VALMCNT,USRCNT)=""
49 . S ^TMP("USRUSERIDX",$J,USRCNT)=VALMCNT_U_USRDA W:VALMCNT#10'>0 "."
50 S ^TMP("USRUSER",$J,0)=+$G(USRCNT)_U_$P(^TMP("USRU",$J,0),U,2)
51 S ^TMP("USRUSER",$J,"#")=USRPICK_"^0:"_+$G(USRCNT)
52 I $D(VALMHDR)>9 D HDR
53 I +$G(USRCNT)'>0 D
54 . S ^TMP("USRUSER",$J,1,0)="",VALMCNT=2
55 . S ^TMP("USRUSER",$J,2,0)="No Class Memberships found for "_$P(^TMP("USRU",$J,0),U,2)
56 Q
57HDR ; Initialize header for review screen
58 N BY,USRX,USRCNT,TITLE,USRNAME
59 S USRX=$G(^TMP("USRUSER",$J,0)),USRNAME=$P(USRX,U,2)
60 S TITLE=USRNAME
61 I USRNAME["?SBPN" D
62 . S VALMSG="(?SBPN) missing SIGNATURE BLOCK PRINTED NAME"
63 ;If this user has been terminated change the title to reflect this.
64 I $$ISTERM^USRLM(USRDUZ) S TITLE=TITLE_" (terminated)"
65 S USRCNT=$J(+USRX,4)_" Class"_$S(+USRX=1:"",1:"es")
66 S VALMHDR(1)=$$CENTER^USRLS(TITLE)
67 S VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$L(USRCNT)),$L(USRCNT))
68 Q
69CLEAN ; "Joel...Clean up your mess!"
70 K ^TMP("USRUSER",$J),^TMP("USRUSERIDX",$J),^TMP("USRU",$J)
71 Q
Note: See TracBrowser for help on using the repository browser.