source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSCKEY.m@ 623

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1QAOSCKEY ;HISC/DAD-ALLOCATE/DEALLOCATE CLINICAL REVIEWER KEY ;11/9/92 10:38
2 ;;3.0;Occurrence Screen;;09/14/1993
3 S QAOSCLIN(0)="QAOSCLIN",QAOSCLIN=+$O(^DIC(19.1,"B",QAOSCLIN(0),0))
4 I $P($G(^DIC(19.1,QAOSCLIN,0)),"^")'=QAOSCLIN(0) D G EXIT
5 . W !!?5,"*** The Clinical Reviewer key was not found !! ***",*7
6 . Q
7 K ^TMP($J,"QAOSCLIN ADD"),^TMP($J,"QAOSCLIN DEL") S QAOCOUNT=0
8 W !!,"Checking for current holders of the Clinical Reviewer key"
9 F QAOSDUZ=0:0 S QAOSDUZ=$O(^XUSEC(QAOSCLIN(0),QAOSDUZ)) Q:QAOSDUZ'>0 D
10 . W "." S X=$G(^VA(200,QAOSDUZ,0))
11 . I $P(X,"^")]"" D
12 .. S ^TMP($J,"QAOSCLIN ADD",$P(X,"^"),QAOSDUZ)=""
13 .. S QAOCOUNT=QAOCOUNT+1
14 .. Q
15 . Q
16 W !,QAOCOUNT," found. " W:QAOCOUNT "Type a '?' to list their names."
17ASK ;
18 R !!,"Select CLINICAL REVIEWER: ",X:DTIME S:'$T X="^"
19 G EXIT:$E(X)="^",OK:X=""
20 S QADELETE=($E(X)="-"),X=$S(QADELETE:$E(X,2,999),1:X)
21 I $E(X)="?" D HELP G ASK
22 S DIC="^VA(200,",DIC(0)="EMNQZ" D ^DIC K DIC G:Y'>0 ASK
23 S QAOSDUZ=+Y,QAOSDUZ(0)=$P(Y(0),"^")
24 I QAOSDUZ(0)="" W " ??",*7 G ASK
25 I QADELETE D
26 . I $D(^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ))[0 W " ??",*7 Q
27 . S ^TMP($J,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)=""
28 . K ^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)
29 . Q
30 E D
31 . S ^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)=""
32 . K ^TMP($J,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)
33 . Q
34 G ASK
35OK ;
36 I $O(^TMP($J,"QAOSCLIN ADD",""))="",$O(^TMP($J,"QAOSCLIN DEL",""))="" W !!?3,"*** No Clinical Reviewers selected !! ***",*7 G EXIT
37ASKOK W !!,"Allocate / Deallocate Clinical Reviewer key"
38 S %=2 D YN^DICN G:(%=-1)!(%=2) EXIT
39 I '% W !!?5,"Please answer Y(es) or N(o)" G ASKOK
40DOIT ; Entry point from postinit: convert file #741.3
41 W !!,"Allocating key:"
42 I $O(^TMP($J,"QAOSCLIN ADD",""))]"" D
43 . S QAOSDUZ(0)=""
44 . F S QAOSDUZ(0)=$O(^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0))) Q:QAOSDUZ(0)="" F QAOSDUZ=0:0 S QAOSDUZ=$O(^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)) Q:QAOSDUZ'>0 D
45 .. K DD,DIC,DINUM,DO
46 .. S:$D(^VA(200,QAOSDUZ,51,0))[0 ^(0)="^200.051PA^^"
47 .. S DA(1)=QAOSDUZ,DIC="^VA(200,"_QAOSDUZ_",51,"
48 .. S DIC(0)="LM",DLAYGO=200,(X,DINUM)=QAOSCLIN
49 .. D:$O(^VA(200,QAOSDUZ,51,"B",QAOSCLIN,0))'>0 FILE^DICN
50 .. W !?3,QAOSDUZ(0)
51 .. Q
52 . Q
53 E W !?3,"*** None ***"
54 W !!,"Deallocating key:"
55 I $O(^TMP($J,"QAOSCLIN DEL",""))]"" D
56 . S QAOSDUZ(0)=""
57 . F S QAOSDUZ(0)=$O(^TMP($J,"QAOSCLIN DEL",QAOSDUZ(0))) Q:QAOSDUZ(0)="" F QAOSDUZ=0:0 S QAOSDUZ=$O(^TMP($J,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)) Q:QAOSDUZ'>0 D
58 .. F QAOSD1=0:0 S QAOSD1=$O(^VA(200,QAOSDUZ,51,"B",QAOSCLIN,QAOSD1)) Q:QAOSD1'>0 D
59 ... S DA(1)=QAOSDUZ,DA=QAOSD1,DIDEL=200
60 ... S DIK="^VA(200,"_QAOSDUZ_",51,"
61 ... D ^DIK
62 ... Q
63 .. W !?3,QAOSDUZ(0)
64 .. Q
65 . Q
66 E W !?3,"*** None ***"
67EXIT ;
68 K %,D,DA,DD,DIC,DIDEL,DIK,DINUM,DIR,DLAYGO,DO,DZ,QADELETE
69 K QAOCOUNT,QAOSCLIN,QAOSD1,QAOSDUZ,QAOSLINE,QAOSLIST,X,Y
70 K ^TMP($J,"QAOSCLIN ADD"),^TMP($J,"QAOSCLIN DEL")
71 Q
72HELP ;
73 W !!," Enter the name of a Clinical Reviewer to add to the list."
74 W !," Enter a minus (-) Clinical Reviewer name to remove a name"
75 W " from the list."
76 W !!,"Clinical Reviewers selected for key ALLOCATION:" D HLP("ADD")
77 W !!,"Clinical Reviewers selected for key DEALLOCATION:" D HLP("DEL")
78 Q:X'?1"??".E
79 K DIR S DIR(0)="E" W ! D ^DIR K DIR Q:Y'>0
80 S DIC="^VA(200,",DIC(0)="AEMNQ",D="B",DZ="??" D DQ^DICQ
81 Q
82HLP(QAOSLIST) ; DISPLAY CLINICAL REVIEWERS
83 N DIR,QAOSLINE,QAOSDUZ,X,Y
84 S QAOSLIST="QAOSCLIN "_QAOSLIST
85 I $O(^TMP($J,QAOSLIST,""))]"" D
86 . S QAOSLINE=$Y,Y=1,QAOSDUZ(0)=""
87 . F S QAOSDUZ(0)=$O(^TMP($J,QAOSLIST,QAOSDUZ(0))) Q:(QAOSDUZ(0)="")!(Y'>0) F QAOSDUZ=0:0 S QAOSDUZ=$O(^TMP($J,QAOSLIST,QAOSDUZ(0),QAOSDUZ)) Q:(QAOSDUZ'>0)!(Y'>0) D
88 .. W !?3,QAOSDUZ(0)
89 .. I $Y>(IOSL+QAOSLINE-3),(($O(^TMP($J,QAOSLIST,QAOSDUZ(0)))]"")!($O(^TMP($J,QAOSLIST,QAOSDUZ(0),QAOSDUZ)))) K DIR S DIR(0)="E",QAOSLINE=$Y D ^DIR K DIR
90 .. Q
91 . Q
92 E W !?3,"*** None ***"
93 Q
Note: See TracBrowser for help on using the repository browser.