- 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 Feb 18, 2025@23:47:41 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
