IBDVAUT1 ;ALB/CS/SS - ICD-9 LOOKUP UTILITY ; 06/18/2012
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
EN1(IBDUTVB,IBDAUTNI,IBDUTSTR,IBDUTNALL) ;
FIRST ;
S DIC(0)="EQMNZI",DIC("A")="Select "_IBDUTSTR_": " K @IBDUTVB S (@IBDUTVB,Y)=0
REDO W !,DIC("A") W:'$D(IBDUTNALL) "ALL// " R X:DTIME G ERR:(X="^")!'$T D:X["?" QQ I X="" G:$D(IBDUTNALL) ERR S @IBDUTVB=1 G QUIT
S DIC("A")="Select another "_IBDUTSTR_": " D ^DIC G:Y'>0 FIRST D SET
F IBDAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T K Y Q:X="" D QQ:X["?" S:$E(X)="-" IBDUTX=X,X=$E(IBDUTX,2,999) D ^DIC I Y>0 D SET G:IBDAX REDO S:'IBDAERR IBDAI=IBDAI+1
G QUIT
SET ;
S IBDAX=0
I $D(IBDUTX) S J=$S(IBDAUTNI=2:+Y,1:$P(Y(0),"^")) K IBDUTX S IBDAERR=$S($D(@IBDUTVB@(J)):0,1:1) D Q:IBDAERR S IBDAI=IBDAI-1 K @IBDUTVB@(J) S:$O(@IBDUTVB@(0))']"" IBDAX=1 Q
. W $S('IBDAERR:"...removed from list...",1:"...not on list...can't remove")
S IBDAERR=0 I $S($D(@IBDUTVB@($P(Y(0),U))):1,$D(@IBDUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",IBDUTSTR,". Try again." S IBDAERR=1
I IBDAUTNI=1 S @IBDUTVB@($P(Y(0),U))=+Y Q
I IBDAUTNI=3 S @IBDUTVB@($P(Y(0,0),U))=+Y Q
S @IBDUTVB@(+Y)=$P(Y(0),U) Q
QQ W !,"ENTER:" W:($D(@(IBDUTVB))=1&'$D(IBDUTNALL)) !?5,"- Return for all ",IBDUTSTR,"s, or" W !?5,"- A ",IBDUTSTR," and return when all ",IBDUTSTR,"s have been selected--limit 20"
W !?5,"Imprecise selections will yield an additional prompt."
W !?5,"(e.g. When a user enters 'A', all items beginning with 'A' are displayed.)"
I $O(@IBDUTVB@(0))]"" W !?5,"- An entry preceded by a minus [-] sign to remove entry from list."
I $O(@IBDUTVB@(0))]"" W !,"NOTE, you have already selected:" S IBDAJ=0 F IBDAJ1=0:0 S IBDAJ=$O(@IBDUTVB@(IBDAJ)) Q:IBDAJ="" W !?8,$S(IBDAUTNI=1:IBDAJ,1:@IBDUTVB@(IBDAJ))
Q
ERR S Y=-1
QUIT S:'$D(Y) Y=1 K DIC,J,IBDAERR,IBDAI,IBDAJ,IBDAJ1,IBDAX,IBDUTNALL,IBDAUTNI,IBDUTSTR,IBDUTVB,X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDVAUT1 1921 printed Oct 16, 2024@18:54:49 Page 2
IBDVAUT1 ;ALB/CS/SS - ICD-9 LOOKUP UTILITY ; 06/18/2012
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
EN1(IBDUTVB,IBDAUTNI,IBDUTSTR,IBDUTNALL) ;
FIRST ;
+1 SET DIC(0)="EQMNZI"
SET DIC("A")="Select "_IBDUTSTR_": "
KILL @IBDUTVB
SET (@IBDUTVB,Y)=0
REDO WRITE !,DIC("A")
if '$DATA(IBDUTNALL)
WRITE "ALL// "
READ X:DTIME
if (X="^")!'$TEST
GOTO ERR
if X["?"
DO QQ
IF X=""
if $DATA(IBDUTNALL)
GOTO ERR
SET @IBDUTVB=1
GOTO QUIT
+1 SET DIC("A")="Select another "_IBDUTSTR_": "
DO ^DIC
if Y'>0
GOTO FIRST
DO SET
+2 FOR IBDAI=1:0:19
WRITE !,DIC("A")
READ X:DTIME
if (X="^")!'$TEST
GOTO ERR
KILL Y
if X=""
QUIT
if X["?"
DO QQ
if $EXTRACT(X)="-"
SET IBDUTX=X
SET X=$EXTRACT(IBDUTX,2,999)
DO ^DIC
IF Y>0
DO SET
if IBDAX
GOTO REDO
if 'IBDAERR
SET IBDAI=IBDAI+1
+3 GOTO QUIT
SET ;
+1 SET IBDAX=0
+2 IF $DATA(IBDUTX)
SET J=$SELECT(IBDAUTNI=2:+Y,1:$PIECE(Y(0),"^"))
KILL IBDUTX
SET IBDAERR=$SELECT($DATA(@IBDUTVB@(J)):0,1:1)
Begin DoDot:1
+3 WRITE $SELECT('IBDAERR:"...removed from list...",1:"...not on list...can't remove")
End DoDot:1
if IBDAERR
QUIT
SET IBDAI=IBDAI-1
KILL @IBDUTVB@(J)
if $ORDER(@IBDUTVB@(0))']""
SET IBDAX=1
QUIT
+4 SET IBDAERR=0
IF $SELECT($DATA(@IBDUTVB@($PIECE(Y(0),U))):1,$DATA(@IBDUTVB@(+Y)):1,1:0)
WRITE !?3,*7,"You have already selected that ",IBDUTSTR,". Try again."
SET IBDAERR=1
+5 IF IBDAUTNI=1
SET @IBDUTVB@($PIECE(Y(0),U))=+Y
QUIT
+6 IF IBDAUTNI=3
SET @IBDUTVB@($PIECE(Y(0,0),U))=+Y
QUIT
+7 SET @IBDUTVB@(+Y)=$PIECE(Y(0),U)
QUIT
QQ WRITE !,"ENTER:"
if ($DATA(@(IBDUTVB))=1&'$DATA(IBDUTNALL))
WRITE !?5,"- Return for all ",IBDUTSTR,"s, or"
WRITE !?5,"- A ",IBDUTSTR," and return when all ",IBDUTSTR,"s have been selected--limit 20"
+1 WRITE !?5,"Imprecise selections will yield an additional prompt."
+2 WRITE !?5,"(e.g. When a user enters 'A', all items beginning with 'A' are displayed.)"
+3 IF $ORDER(@IBDUTVB@(0))]""
WRITE !?5,"- An entry preceded by a minus [-] sign to remove entry from list."
+4 IF $ORDER(@IBDUTVB@(0))]""
WRITE !,"NOTE, you have already selected:"
SET IBDAJ=0
FOR IBDAJ1=0:0
SET IBDAJ=$ORDER(@IBDUTVB@(IBDAJ))
if IBDAJ=""
QUIT
WRITE !?8,$SELECT(IBDAUTNI=1:IBDAJ,1:@IBDUTVB@(IBDAJ))
+5 QUIT
ERR SET Y=-1
QUIT if '$DATA(Y)
SET Y=1
KILL DIC,J,IBDAERR,IBDAI,IBDAJ,IBDAJ1,IBDAX,IBDUTNALL,IBDAUTNI,IBDUTSTR,IBDUTVB,X
QUIT
