QAOSCKEY ;HISC/DAD-ALLOCATE/DEALLOCATE CLINICAL REVIEWER KEY ;11/9/92 10:38
;;3.0;Occurrence Screen;;09/14/1993
S QAOSCLIN(0)="QAOSCLIN",QAOSCLIN=+$O(^DIC(19.1,"B",QAOSCLIN(0),0))
I $P($G(^DIC(19.1,QAOSCLIN,0)),"^")'=QAOSCLIN(0) D G EXIT
. W !!?5,"*** The Clinical Reviewer key was not found !! ***",*7
. Q
K ^TMP($J,"QAOSCLIN ADD"),^TMP($J,"QAOSCLIN DEL") S QAOCOUNT=0
W !!,"Checking for current holders of the Clinical Reviewer key"
F QAOSDUZ=0:0 S QAOSDUZ=$O(^XUSEC(QAOSCLIN(0),QAOSDUZ)) Q:QAOSDUZ'>0 D
. W "." S X=$G(^VA(200,QAOSDUZ,0))
. I $P(X,"^")]"" D
.. S ^TMP($J,"QAOSCLIN ADD",$P(X,"^"),QAOSDUZ)=""
.. S QAOCOUNT=QAOCOUNT+1
.. Q
. Q
W !,QAOCOUNT," found. " W:QAOCOUNT "Type a '?' to list their names."
ASK ;
R !!,"Select CLINICAL REVIEWER: ",X:DTIME S:'$T X="^"
G EXIT:$E(X)="^",OK:X=""
S QADELETE=($E(X)="-"),X=$S(QADELETE:$E(X,2,999),1:X)
I $E(X)="?" D HELP G ASK
S DIC="^VA(200,",DIC(0)="EMNQZ" D ^DIC K DIC G:Y'>0 ASK
S QAOSDUZ=+Y,QAOSDUZ(0)=$P(Y(0),"^")
I QAOSDUZ(0)="" W " ??",*7 G ASK
I QADELETE D
. I $D(^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ))[0 W " ??",*7 Q
. S ^TMP($J,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)=""
. K ^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)
. Q
E D
. S ^TMP($J,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)=""
. K ^TMP($J,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)
. Q
G ASK
OK ;
I $O(^TMP($J,"QAOSCLIN ADD",""))="",$O(^TMP($J,"QAOSCLIN DEL",""))="" W !!?3,"*** No Clinical Reviewers selected !! ***",*7 G EXIT
ASKOK W !!,"Allocate / Deallocate Clinical Reviewer key"
S %=2 D YN^DICN G:(%=-1)!(%=2) EXIT
I '% W !!?5,"Please answer Y(es) or N(o)" G ASKOK
DOIT ; Entry point from postinit: convert file #741.3
W !!,"Allocating key:"
I $O(^TMP($J,"QAOSCLIN ADD",""))]"" D
. S QAOSDUZ(0)=""
. 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
.. K DD,DIC,DINUM,DO
.. S:$D(^VA(200,QAOSDUZ,51,0))[0 ^(0)="^200.051PA^^"
.. S DA(1)=QAOSDUZ,DIC="^VA(200,"_QAOSDUZ_",51,"
.. S DIC(0)="LM",DLAYGO=200,(X,DINUM)=QAOSCLIN
.. D:$O(^VA(200,QAOSDUZ,51,"B",QAOSCLIN,0))'>0 FILE^DICN
.. W !?3,QAOSDUZ(0)
.. Q
. Q
E W !?3,"*** None ***"
W !!,"Deallocating key:"
I $O(^TMP($J,"QAOSCLIN DEL",""))]"" D
. S QAOSDUZ(0)=""
. 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
.. F QAOSD1=0:0 S QAOSD1=$O(^VA(200,QAOSDUZ,51,"B",QAOSCLIN,QAOSD1)) Q:QAOSD1'>0 D
... S DA(1)=QAOSDUZ,DA=QAOSD1,DIDEL=200
... S DIK="^VA(200,"_QAOSDUZ_",51,"
... D ^DIK
... Q
.. W !?3,QAOSDUZ(0)
.. Q
. Q
E W !?3,"*** None ***"
EXIT ;
K %,D,DA,DD,DIC,DIDEL,DIK,DINUM,DIR,DLAYGO,DO,DZ,QADELETE
K QAOCOUNT,QAOSCLIN,QAOSD1,QAOSDUZ,QAOSLINE,QAOSLIST,X,Y
K ^TMP($J,"QAOSCLIN ADD"),^TMP($J,"QAOSCLIN DEL")
Q
HELP ;
W !!," Enter the name of a Clinical Reviewer to add to the list."
W !," Enter a minus (-) Clinical Reviewer name to remove a name"
W " from the list."
W !!,"Clinical Reviewers selected for key ALLOCATION:" D HLP("ADD")
W !!,"Clinical Reviewers selected for key DEALLOCATION:" D HLP("DEL")
Q:X'?1"??".E
K DIR S DIR(0)="E" W ! D ^DIR K DIR Q:Y'>0
S DIC="^VA(200,",DIC(0)="AEMNQ",D="B",DZ="??" D DQ^DICQ
Q
HLP(QAOSLIST) ; DISPLAY CLINICAL REVIEWERS
N DIR,QAOSLINE,QAOSDUZ,X,Y
S QAOSLIST="QAOSCLIN "_QAOSLIST
I $O(^TMP($J,QAOSLIST,""))]"" D
. S QAOSLINE=$Y,Y=1,QAOSDUZ(0)=""
. 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
.. W !?3,QAOSDUZ(0)
.. 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
.. Q
. Q
E W !?3,"*** None ***"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSCKEY 3931 printed Sep 23, 2025@19:57:31 Page 2
QAOSCKEY ;HISC/DAD-ALLOCATE/DEALLOCATE CLINICAL REVIEWER KEY ;11/9/92 10:38
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 SET QAOSCLIN(0)="QAOSCLIN"
SET QAOSCLIN=+$ORDER(^DIC(19.1,"B",QAOSCLIN(0),0))
+3 IF $PIECE($GET(^DIC(19.1,QAOSCLIN,0)),"^")'=QAOSCLIN(0)
Begin DoDot:1
+4 WRITE !!?5,"*** The Clinical Reviewer key was not found !! ***",*7
+5 QUIT
End DoDot:1
GOTO EXIT
+6 KILL ^TMP($JOB,"QAOSCLIN ADD"),^TMP($JOB,"QAOSCLIN DEL")
SET QAOCOUNT=0
+7 WRITE !!,"Checking for current holders of the Clinical Reviewer key"
+8 FOR QAOSDUZ=0:0
SET QAOSDUZ=$ORDER(^XUSEC(QAOSCLIN(0),QAOSDUZ))
if QAOSDUZ'>0
QUIT
Begin DoDot:1
+9 WRITE "."
SET X=$GET(^VA(200,QAOSDUZ,0))
+10 IF $PIECE(X,"^")]""
Begin DoDot:2
+11 SET ^TMP($JOB,"QAOSCLIN ADD",$PIECE(X,"^"),QAOSDUZ)=""
+12 SET QAOCOUNT=QAOCOUNT+1
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 WRITE !,QAOCOUNT," found. "
if QAOCOUNT
WRITE "Type a '?' to list their names."
ASK ;
+1 READ !!,"Select CLINICAL REVIEWER: ",X:DTIME
if '$TEST
SET X="^"
+2 if $EXTRACT(X)="^"
GOTO EXIT
if X=""
GOTO OK
+3 SET QADELETE=($EXTRACT(X)="-")
SET X=$SELECT(QADELETE:$EXTRACT(X,2,999),1:X)
+4 IF $EXTRACT(X)="?"
DO HELP
GOTO ASK
+5 SET DIC="^VA(200,"
SET DIC(0)="EMNQZ"
DO ^DIC
KILL DIC
if Y'>0
GOTO ASK
+6 SET QAOSDUZ=+Y
SET QAOSDUZ(0)=$PIECE(Y(0),"^")
+7 IF QAOSDUZ(0)=""
WRITE " ??",*7
GOTO ASK
+8 IF QADELETE
Begin DoDot:1
+9 IF $DATA(^TMP($JOB,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ))[0
WRITE " ??",*7
QUIT
+10 SET ^TMP($JOB,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)=""
+11 KILL ^TMP($JOB,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)
+12 QUIT
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET ^TMP($JOB,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ)=""
+15 KILL ^TMP($JOB,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ)
+16 QUIT
End DoDot:1
+17 GOTO ASK
OK ;
+1 IF $ORDER(^TMP($JOB,"QAOSCLIN ADD",""))=""
IF $ORDER(^TMP($JOB,"QAOSCLIN DEL",""))=""
WRITE !!?3,"*** No Clinical Reviewers selected !! ***",*7
GOTO EXIT
ASKOK WRITE !!,"Allocate / Deallocate Clinical Reviewer key"
+1 SET %=2
DO YN^DICN
if (%=-1)!(%=2)
GOTO EXIT
+2 IF '%
WRITE !!?5,"Please answer Y(es) or N(o)"
GOTO ASKOK
DOIT ; Entry point from postinit: convert file #741.3
+1 WRITE !!,"Allocating key:"
+2 IF $ORDER(^TMP($JOB,"QAOSCLIN ADD",""))]""
Begin DoDot:1
+3 SET QAOSDUZ(0)=""
+4 FOR
SET QAOSDUZ(0)=$ORDER(^TMP($JOB,"QAOSCLIN ADD",QAOSDUZ(0)))
if QAOSDUZ(0)=""
QUIT
FOR QAOSDUZ=0:0
SET QAOSDUZ=$ORDER(^TMP($JOB,"QAOSCLIN ADD",QAOSDUZ(0),QAOSDUZ))
if QAOSDUZ'>0
QUIT
Begin DoDot:2
+5 KILL DD,DIC,DINUM,DO
+6 if $DATA(^VA(200,QAOSDUZ,51,0))[0
SET ^(0)="^200.051PA^^"
+7 SET DA(1)=QAOSDUZ
SET DIC="^VA(200,"_QAOSDUZ_",51,"
+8 SET DIC(0)="LM"
SET DLAYGO=200
SET (X,DINUM)=QAOSCLIN
+9 if $ORDER(^VA(200,QAOSDUZ,51,"B",QAOSCLIN,0))'>0
DO FILE^DICN
+10 WRITE !?3,QAOSDUZ(0)
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF '$TEST
WRITE !?3,"*** None ***"
+14 WRITE !!,"Deallocating key:"
+15 IF $ORDER(^TMP($JOB,"QAOSCLIN DEL",""))]""
Begin DoDot:1
+16 SET QAOSDUZ(0)=""
+17 FOR
SET QAOSDUZ(0)=$ORDER(^TMP($JOB,"QAOSCLIN DEL",QAOSDUZ(0)))
if QAOSDUZ(0)=""
QUIT
FOR QAOSDUZ=0:0
SET QAOSDUZ=$ORDER(^TMP($JOB,"QAOSCLIN DEL",QAOSDUZ(0),QAOSDUZ))
if QAOSDUZ'>0
QUIT
Begin DoDot:2
+18 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^VA(200,QAOSDUZ,51,"B",QAOSCLIN,QAOSD1))
if QAOSD1'>0
QUIT
Begin DoDot:3
+19 SET DA(1)=QAOSDUZ
SET DA=QAOSD1
SET DIDEL=200
+20 SET DIK="^VA(200,"_QAOSDUZ_",51,"
+21 DO ^DIK
+22 QUIT
End DoDot:3
+23 WRITE !?3,QAOSDUZ(0)
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 IF '$TEST
WRITE !?3,"*** None ***"
EXIT ;
+1 KILL %,D,DA,DD,DIC,DIDEL,DIK,DINUM,DIR,DLAYGO,DO,DZ,QADELETE
+2 KILL QAOCOUNT,QAOSCLIN,QAOSD1,QAOSDUZ,QAOSLINE,QAOSLIST,X,Y
+3 KILL ^TMP($JOB,"QAOSCLIN ADD"),^TMP($JOB,"QAOSCLIN DEL")
+4 QUIT
HELP ;
+1 WRITE !!," Enter the name of a Clinical Reviewer to add to the list."
+2 WRITE !," Enter a minus (-) Clinical Reviewer name to remove a name"
+3 WRITE " from the list."
+4 WRITE !!,"Clinical Reviewers selected for key ALLOCATION:"
DO HLP("ADD")
+5 WRITE !!,"Clinical Reviewers selected for key DEALLOCATION:"
DO HLP("DEL")
+6 if X'?1"??".E
QUIT
+7 KILL DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if Y'>0
QUIT
+8 SET DIC="^VA(200,"
SET DIC(0)="AEMNQ"
SET D="B"
SET DZ="??"
DO DQ^DICQ
+9 QUIT
HLP(QAOSLIST) ; DISPLAY CLINICAL REVIEWERS
+1 NEW DIR,QAOSLINE,QAOSDUZ,X,Y
+2 SET QAOSLIST="QAOSCLIN "_QAOSLIST
+3 IF $ORDER(^TMP($JOB,QAOSLIST,""))]""
Begin DoDot:1
+4 SET QAOSLINE=$Y
SET Y=1
SET QAOSDUZ(0)=""
+5 FOR
SET QAOSDUZ(0)=$ORDER(^TMP($JOB,QAOSLIST,QAOSDUZ(0)))
if (QAOSDUZ(0)="")!(Y'>0)
QUIT
FOR QAOSDUZ=0:0
SET QAOSDUZ=$ORDER(^TMP($JOB,QAOSLIST,QAOSDUZ(0),QAOSDUZ))
if (QAOSDUZ'>0)!(Y'>0)
QUIT
Begin DoDot:2
+6 WRITE !?3,QAOSDUZ(0)
+7 IF $Y>(IOSL+QAOSLINE-3)
IF (($ORDER(^TMP($JOB,QAOSLIST,QAOSDUZ(0)))]"")!($ORDER(^TMP($JOB,QAOSLIST,QAOSDUZ(0),QAOSDUZ))))
KILL DIR
SET DIR(0)="E"
SET QAOSLINE=$Y
DO ^DIR
KILL DIR
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 IF '$TEST
WRITE !?3,"*** None ***"
+11 QUIT
