source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACKEY.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1QACKEY ;HISC/DAD,CEW - Allocate/Deallocate Patient Representative key ;2/10/95 09:42
2 ;;2.0;Patient Representative;;07/25/1995
3 K DIC S DIC="^DIC(19.1,",DIC(0)="AEMNQZ"
4 S DIC("S")="I $E($P(^(0),U,1),1,3)=""QAC"""
5 S DIC("A")="Select the key you want to allocate/deallocate: "
6 S DIC("W")="W "" "",$P(^(0),U,2)"
7 D ^DIC K DIC G:Y'>0 EXIT S QACKEY(0)=$P(Y,U,2),QACKEY=+Y
8 S QACKEY(1)=$P(Y(0),U,2)
9 K ^TMP($J,"QACKEY ADD"),^TMP($J,"QACKEY DEL") S QACCOUNT=0
10 W !!,"Checking for current holders of the ",QACKEY(1)
11 F QACDUZ=0:0 S QACDUZ=$O(^XUSEC(QACKEY(0),QACDUZ)) Q:QACDUZ'>0 D
12 . W "." S X=$G(^VA(200,QACDUZ,0))
13 . I $P(X,"^")]"" D
14 .. S ^TMP($J,"QACKEY ADD",$P(X,"^"),QACDUZ)=""
15 .. S QACCOUNT=QACCOUNT+1
16 .. Q
17 . Q
18 W !,QACCOUNT," found. " W:QACCOUNT "Type a '?' to list their names."
19ASK ;
20 R !!,"Select PATIENT REPRESENTATIVE: ",X:DTIME S:'$T X="^"
21 G EXIT:$E(X)="^",OK:X=""
22 S QADELETE=($E(X)="-"),X=$S(QADELETE:$E(X,2,999),1:X)
23 I $E(X)="?" D HELP G ASK
24 S DIC="^VA(200,",DIC(0)="EMNQZ" D ^DIC K DIC G:Y'>0 ASK
25 S QACDUZ=+Y,QACDUZ(0)=$P(Y(0),"^")
26 I QACDUZ(0)="" W " ??",*7 G ASK
27 I QADELETE D
28 . I $D(^TMP($J,"QACKEY ADD",QACDUZ(0),QACDUZ))[0 W " ??",*7 Q
29 . S ^TMP($J,"QACKEY DEL",QACDUZ(0),QACDUZ)=""
30 . K ^TMP($J,"QACKEY ADD",QACDUZ(0),QACDUZ)
31 . Q
32 E D
33 . S ^TMP($J,"QACKEY ADD",QACDUZ(0),QACDUZ)=""
34 . K ^TMP($J,"QACKEY DEL",QACDUZ(0),QACDUZ)
35 . Q
36 G ASK
37OK ;
38 I $O(^TMP($J,"QACKEY ADD",""))="",$O(^TMP($J,"QACKEY DEL",""))="" W !!?3,"*** No Patient Reps. selected !! ***",*7 G EXIT
39ASKOK W !!,"Allocate / Deallocate ",QACKEY(1)
40 S %=2 D YN^DICN G:(%=-1)!(%=2) EXIT
41 I '% W !!?5,"Please answer Y(es) or N(o)" G ASKOK
42DOIT ;
43 W !!,"Allocating key:"
44 I $O(^TMP($J,"QACKEY ADD",""))]"" D
45 . S QACDUZ(0)=""
46 . F S QACDUZ(0)=$O(^TMP($J,"QACKEY ADD",QACDUZ(0))) Q:QACDUZ(0)="" F QACDUZ=0:0 S QACDUZ=$O(^TMP($J,"QACKEY ADD",QACDUZ(0),QACDUZ)) Q:QACDUZ'>0 D
47 .. K DD,DIC,DINUM,DO
48 .. S:$D(^VA(200,QACDUZ,51,0))[0 ^(0)="^200.051PA^^"
49 .. S DA(1)=QACDUZ,DIC="^VA(200,"_QACDUZ_",51,"
50 .. S DIC(0)="LM",DLAYGO=200,(X,DINUM)=QACKEY
51 .. D:$O(^VA(200,QACDUZ,51,"B",QACKEY,0))'>0 FILE^DICN
52 .. W !?3,QACDUZ(0)
53 .. Q
54 . Q
55 E W !?3,"*** None ***"
56 W !!,"Deallocating key:"
57 I $O(^TMP($J,"QACKEY DEL",""))]"" D
58 . S QACDUZ(0)=""
59 . F S QACDUZ(0)=$O(^TMP($J,"QACKEY DEL",QACDUZ(0))) Q:QACDUZ(0)="" F QACDUZ=0:0 S QACDUZ=$O(^TMP($J,"QACKEY DEL",QACDUZ(0),QACDUZ)) Q:QACDUZ'>0 D
60 .. F QACSD1=0:0 S QACSD1=$O(^VA(200,QACDUZ,51,"B",QACKEY,QACSD1)) Q:QACSD1'>0 D
61 ... S DA(1)=QACDUZ,DA=QACSD1,DIDEL=200
62 ... S DIK="^VA(200,"_QACDUZ_",51,"
63 ... D ^DIK
64 ... Q
65 .. W !?3,QACDUZ(0)
66 .. Q
67 . Q
68 E W !?3,"*** None ***"
69EXIT ;
70 K %,D,DA,DD,DIC,DIDEL,DIK,DINUM,DIR,DLAYGO,DO,DZ,QADELETE
71 K QACCOUNT,QACKEY,QACSD1,QACDUZ,QACLINE,QACLIST,X,Y
72 K ^TMP($J,"QACKEY ADD"),^TMP($J,"QACKEY DEL")
73 Q
74HELP ;
75 W !!," Enter the name of a Patient Representative to add to the list."
76 W !," Enter a minus (-) Patient Representative name to remove a name"
77 W " from the list."
78 W !!,"Patient Reps. selected for key ALLOCATION:" D HLP("ADD")
79 W !!,"Patient Reps. selected for key DEALLOCATION:" D HLP("DEL")
80 Q:X'?1"??".E
81 K DIR S DIR(0)="E" W ! D ^DIR K DIR Q:Y'>0
82 S DIC="^VA(200,",DIC(0)="AEMNQ",D="B",DZ="??" D DQ^DICQ
83 Q
84HLP(QACLIST) ; Display Patient Representatives
85 N DIR,QACLINE,QACDUZ,X,Y
86 S QACLIST="QACKEY "_QACLIST
87 I $O(^TMP($J,QACLIST,""))]"" D
88 . S QACLINE=$Y,Y=1,QACDUZ(0)=""
89 . F S QACDUZ(0)=$O(^TMP($J,QACLIST,QACDUZ(0))) Q:(QACDUZ(0)="")!(Y'>0) F QACDUZ=0:0 S QACDUZ=$O(^TMP($J,QACLIST,QACDUZ(0),QACDUZ)) Q:(QACDUZ'>0)!(Y'>0) D
90 .. W !?3,QACDUZ(0)
91 .. I $Y>(IOSL+QACLINE-3),(($O(^TMP($J,QACLIST,QACDUZ(0)))]"")!($O(^TMP($J,QACLIST,QACDUZ(0),QACDUZ)))) K DIR S DIR(0)="E",QACLINE=$Y D ^DIR K DIR
92 .. Q
93 . Q
94 E W !?3,"*** None ***"
95 Q
Note: See TracBrowser for help on using the repository browser.