source: WorldVistAEHR/trunk/r/PROBLEM_LIST-GMPL/GMPLBLD3.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: 4.2 KB
Line 
1GMPLBLD3 ; SLC/MKB -- Bld PL Selection Lists cont ;3/12/03 13:40
2 ;;2.0;Problem List;**28**;Aug 25, 1994
3 ;
4 ; This routine invokes IA #3991
5 ;
6ASSIGN ; Assign list to clinic, users: Expects GMPLSLST
7 N DIE,DA,DR D FULL^VALM1 G:+$G(GMPLSLST)'>0 ASQ
8 I '$$VALLIST^GMPLBLD2(+GMPLSLST) D G ASQ
9 . W !!,$C(7),"This Selection List contains problems with inactive ICD9 codes associated with"
10 . W !,"them. The codes must be edited and corrected before the list can be assigned",!,"to users or clinics."
11 . W !!,"If you have edited the list during this session to correct inactive codes, "
12 . W !,"save the list prior to attempting to assign it."
13 . N DIR,DUOUT,DTOUT,DIRUT
14 . S DIR(0)="E" D ^DIR
15 . Q
16 ;
17 W !!,"You may assign this list to a clinic as its default selection list,"
18 W !,"as well as to individual users as a preferred selection list.",!
19 S DA=+GMPLSLST,DR=.03,DIE="^GMPL(125," D ^DIE Q:$D(DTOUT)!($D(DUOUT))
20 D USERS("1") ; assign
21ASQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
22 Q
23 ;
24USERS(ADD) ; -- select user(s) to de-/assign list
25 N DIR,DIC,DIE,DR,DA,X,Y,GMPLUSER,GMPLI
26 Q:+$G(GMPLSLST)'>0 S GMPLUSER=""
27 S DIC="^VA(200,",DIC(0)="EQM",DIC("A")="Select USER: "
28 F D READ Q:+Y'>0 S GMPLUSER=GMPLUSER_U_+Y,DIC("A")="ANOTHER ONE: "
29 I '$L(GMPLUSER) W !!,"No users selected.",! Q
30 S DIR(0)="YA",DIR("A")="Are you ready? ",DIR("B")="NO"
31 S DIR("?",1)="Enter YES to "_$S(ADD:"assign",1:"remove")_" the "_$P(GMPLSLST,U,2)_" list "_$S(ADD:"to the",1:"from the")
32 S DIR("?")=($L(GMPLUSER,U)-1)_" user(s) selected; enter NO to exit."
33 D ^DIR Q:'Y
34USR W !,$S(ADD:"Assigning ",1:"Removing ")_$P(GMPLSLST,U,2)_" list ..."
35 S DIE="^VA(200,",DR="125.1///"_$S(ADD:"/"_(+GMPLSLST),1:"@")
36 F GMPLI=1:1:$L(GMPLUSER,U) S DA=$P(GMPLUSER,U,GMPLI) I DA D
37 . W !?4,$P($G(^VA(200,DA,0)),U) D ^DIE
38 W !!,"DONE."
39 Q
40 ;
41READ ; prompt for username, respond
42 W !,DIC("A") R X:DTIME I '$T!("^"[X) S Y=-1 Q
43 I X="?" W !!,"Enter the name of the user you wish this list to be "_$S(ADD:"assigned to;",1:"removed from;"),!,"enter '??' to see users currently assigned this list, or '???' to see",!,"all users on this system.",! G READ
44 I X?1"??".E D G READ
45 . I X="??" S DIC("S")="I $P($G(^(125)),U,2)="_+GMPLSLST W !!,"Users currently assigned "_$P(GMPLSLST,U,2)_" list:"
46 . S D="B",DZ="??" D DQ^DICQ K D,DZ,DIC("S")
47 D ^DIC G:Y'>0 READ
48 Q
49 ;
50DELETE ; Delete Selection List
51 N DIR,DIK,DA,X,Y,VIEW,USER,GMPCOUNT,GMPQUIT,GMPLSLST
52 S GMPCOUNT=0,GMPLSLST=$$LIST^GMPLBLD2("") Q:GMPLSLST="^"
53 W !!,"Checking the New Person file for use of this list ..."
54 F USER=0:0 S USER=$O(^VA(200,USER)) Q:USER'>0 D
55 . S VIEW=$P($G(^VA(200,USER,125)),U,2) Q:'VIEW Q:VIEW'=+GMPLSLST
56 . S GMPCOUNT=GMPCOUNT+1 W "."
57 I GMPCOUNT W $C(7),!!,GMPCOUNT_" user(s) are currently assigned this list!",!,"CANNOT DELETE",! Q
58 W !,"0 users found."
59DEL1 S DIR(0)="Y",DIR("B")="NO"
60 S DIR("A")="Are you sure you want to delete this list"
61 S DIR("?",1)="Enter YES if you wish to completely remove this list; press <return>",DIR("?")="to leave this list unchanged and exit this option."
62 W $C(7),! D ^DIR Q:'Y
63 W !!,"Deleting "_$P(GMPLSLST,U,2)_" selection list ..."
64 S DIK="^GMPL(125.1,",DA=0 ; list contents
65 F S DA=$O(^GMPL(125.1,"B",+GMPLSLST,DA)) Q:DA'>0 D ^DIK W "."
66 S DA=+GMPLSLST,DIK="^GMPL(125," D ^DIK W "." ; list
67 W !,"DONE.",!
68 Q
69 ;
70MENU ; -- init variables and list array for GMPL LIST MENU list template
71 ; Expects GMPLSLST=selection list
72 N GSEQ,PSEQ,GCNT,PCNT,GROUP,HDR,IFN,LCNT,ITEM,TEXT,CODE
73 S (GSEQ,GCNT,LCNT)=0 K ^TMP("GMPLMENU",$J)
74 W !!,"Retrieving list of "_$P(GMPLSLST,U,2)_" problems ..."
75 F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D
76 . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
77 . S ITEM=$G(^GMPL(125.1,IFN,0)),GROUP=$P(ITEM,U,3),HDR=$P(ITEM,U,4,5)
78 . S GCNT=GCNT+1,(PSEQ,PCNT)=0,^TMP("GMPLMENU",$J,GCNT,0)=HDR
79 . F S PSEQ=$O(^GMPL(125.12,"C",+GROUP,PSEQ)) Q:PSEQ'>0 D
80 . . S IFN=$O(^GMPL(125.12,"C",+GROUP,PSEQ,0)) Q:IFN'>0
81 . . S ITEM=$G(^GMPL(125.12,IFN,0)),TEXT=$P(ITEM,U,4),CODE=$P(ITEM,U,5)
82 . . I $L(CODE),'$$STATCHK^ICDAPIU(CODE,DT) Q ; screen inactive codes
83 . . S PCNT=PCNT+1,^TMP("GMPLMENU",$J,GCNT,PCNT)=$P(ITEM,U,3,5)
84 I '$D(^TMP("GMPLMENU",$J)) W !!,"No items available. Returning to Problem List ..." H 2 S VALMBCK="Q",VALMQUIT=1 Q
85 D BUILD^GMPLMENU
86 Q
Note: See TracBrowser for help on using the repository browser.