VAUTOMA ;ALB/MLI - GENERIC ONE, MANY, ALL ROUTINE ; 03/26/2004
;;5.3;Registration;**111,568,1010,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 8/17/2000 added inactivation info to clinic choice list
; 10/19/2000 removed N from DIC(0) so ?? in alpha order
;cmi/anch/maw 05/15/2009 added code to pass in div name for DIC("B") when selecting division
;;MAS VERSION 5.1;
;DIVISION S VAUTVB="VAUTD",DIC="^DG(40.8,",VAUTNI=2,VAUTSTR="division" G FIRST
;CLINIC S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'+$P($G(^(""OOS"")),U,1)&'+$P($G(^(""OOS"")),U,2)&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" G FIRST
; DIC("S") modified in CLINIC call, to exclude Occasion of Service locations. abr - 11/25/96
;
DIVISION ;-- cmi/maw PATCH 1010 modified to get division name
N VADIV,VADIVNM,VADICA
S VADIV=$$DIV^BSDU()
I $G(VADIV) S VADIVNM=$$DIVNM^BSDU(VADIV)
S VAUTVB="VAUTD",DIC="^DG(40.8,",VAUTNI=2,VAUTSTR="division",VAUTNALL=1,DIC("A")=$G(VADIVNM) G FIRST
CLINIC ;S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'$G(^(""OOS""))&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" G FIRST ;IHS/ANMC/LJF 8/17/2000
S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'$G(^(""OOS""))&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" ;IHS/ANMC/LJF 8/17/2000
S DIC("W")=$$INACTMSG^BSDU ;IHS/ANMC/LJF 8/17/2000 added this line
G FIRST ;IHS/ANMC/LJF 8/17/2000
; DIC("S") modified in CLINIC call, to exclude Occasion of Service locations. abr - 11/25/96
;
PATIENT S DIC="^DPT(",VAUTSTR="patient",VAUTVB="VAUTN" G FIRST
WARD S DIC="^DIC(42,",VAUTSTR="ward",VAUTVB="VAUTW",DIC("S")="I $S(VAUTD:1,$D(VAUTD(+$P(^(0),U,11))):1,'+$P(^(0),U,11)&$D(VAUTD(^DG(40.8,+$O(^DG(40.8,0)),0))):1,1:0)" G FIRST
FIRST S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB S (@VAUTVB,Y)=0
S DIC(0)="EQMZ" ;IHS/ANMC/LJF 10/19/2000
REDO ;cmi/maw 5/15/5009 added for default of division logged into
N VADICA S VADICA=$S($G(VADIVNM)]"":VADIVNM_"// ",'$D(VAUTNALL):"ALL// ",1:"") W !,DIC("A")_VADICA R X:DTIME G ERR:(X="^")!'$T D:X["?" QQ S X=$S(X=""&($G(VADIVNM)]""):VADIVNM,1:X) I X="" G:$D(VAUTNALL) ERR S @VAUTVB=1 G QUIT
;W !,DIC("A") W:'$D(VAUTNALL) "ALL// " R X:DTIME G ERR:(X="^")!'$T D:X["?" QQ I X="" G:$D(VAUTNALL) ERR S @VAUTVB=1 G QUIT
S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET
F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T K Y Q:X="" D QQ:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1
G QUIT
SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q
S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1
I VAUTNI=1 S @VAUTVB@($P(Y(0),U))=+Y Q
I VAUTNI=3 S @VAUTVB@($P(Y(0,0),U))=+Y Q
S @VAUTVB@(+Y)=$P(Y(0),U) Q
QQ W !,"ENTER:" W:($D(@(VAUTVB))=1&'$D(VAUTNALL)) !?5,"- Return for all ",VAUTSTR,"s, or" W !?5,"- A ",VAUTSTR," and return when all ",VAUTSTR,"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(@VAUTVB@(0))]"" W !?5,"- An entry preceeded by a minus [-] sign to remove entry from list."
I $O(@VAUTVB@(0))]"" W !,"NOTE, you have already selected:" S VAJ=0 F VAJ1=0:0 S VAJ=$O(@VAUTVB@(VAJ)) Q:VAJ="" W !?8,$S(VAUTNI=1:VAJ,1:@VAUTVB@(VAJ))
Q
ERR S Y=-1
QUIT S:'$D(Y) Y=1 K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNALL,VAUTNI,VAUTSTR,VAUTVB,X Q
VAUTOMA ;ALB/MLI - GENERIC ONE, MANY, ALL ROUTINE ; 03/26/2004
+1 ;;5.3;Registration;**111,568,1010,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 8/17/2000 added inactivation info to clinic choice list
+3 ; 10/19/2000 removed N from DIC(0) so ?? in alpha order
+4 ;cmi/anch/maw 05/15/2009 added code to pass in div name for DIC("B") when selecting division
+5 ;;MAS VERSION 5.1;
+6 ;DIVISION S VAUTVB="VAUTD",DIC="^DG(40.8,",VAUTNI=2,VAUTSTR="division" G FIRST
+7 ;CLINIC S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'+$P($G(^(""OOS"")),U,1)&'+$P($G(^(""OOS"")),U,2)&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" G FIRST
+8 ; DIC("S") modified in CLINIC call, to exclude Occasion of Service locations. abr - 11/25/96
+9 ;
DIVISION ;-- cmi/maw PATCH 1010 modified to get division name
+1 NEW VADIV,VADIVNM,VADICA
+2 SET VADIV=$$DIV^BSDU()
+3 IF $GET(VADIV)
SET VADIVNM=$$DIVNM^BSDU(VADIV)
+4 SET VAUTVB="VAUTD"
SET DIC="^DG(40.8,"
SET VAUTNI=2
SET VAUTSTR="division"
SET VAUTNALL=1
SET DIC("A")=$GET(VADIVNM)
GOTO FIRST
CLINIC ;S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'$G(^(""OOS""))&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" G FIRST ;IHS/ANMC/LJF 8/17/2000
+1 ;IHS/ANMC/LJF 8/17/2000
SET DIC="^SC("
SET DIC("S")="I $P(^(0),U,3)=""C""&'$G(^(""OOS""))&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
SET VAUTSTR="clinic"
SET VAUTVB="VAUTC"
+2 ;IHS/ANMC/LJF 8/17/2000 added this line
SET DIC("W")=$$INACTMSG^BSDU
+3 ;IHS/ANMC/LJF 8/17/2000
GOTO FIRST
+4 ; DIC("S") modified in CLINIC call, to exclude Occasion of Service locations. abr - 11/25/96
+5 ;
PATIENT SET DIC="^DPT("
SET VAUTSTR="patient"
SET VAUTVB="VAUTN"
GOTO FIRST
WARD SET DIC="^DIC(42,"
SET VAUTSTR="ward"
SET VAUTVB="VAUTW"
SET DIC("S")="I $S(VAUTD:1,$D(VAUTD(+$P(^(0),U,11))):1,'+$P(^(0),U,11)&$D(VAUTD(^DG(40.8,+$O(^DG(40.8,0)),0))):1,1:0)"
GOTO FIRST
FIRST SET DIC(0)="EQMNZ"
SET DIC("A")="Select "_VAUTSTR_": "
KILL @VAUTVB
SET (@VAUTVB,Y)=0
+1 ;IHS/ANMC/LJF 10/19/2000
SET DIC(0)="EQMZ"
REDO ;cmi/maw 5/15/5009 added for default of division logged into
+1 NEW VADICA
SET VADICA=$SELECT($GET(VADIVNM)]"":VADIVNM_"// ",'$DATA(VAUTNALL):"ALL// ",1:"")
WRITE !,DIC("A")_VADICA
READ X:DTIME
IF (X="^")!'$TEST
GOTO ERR
IF X["?"
DO QQ
SET X=$SELECT(X=""&($GET(VADIVNM)]""):VADIVNM,1:X)
IF X=""
IF $DATA(VAUTNALL)
GOTO ERR
SET @VAUTVB=1
GOTO QUIT
+2 ;W !,DIC("A") W:'$D(VAUTNALL) "ALL// " R X:DTIME G ERR:(X="^")!'$T D:X["?" QQ I X="" G:$D(VAUTNALL) ERR S @VAUTVB=1 G QUIT
+3 SET DIC("A")="Select another "_VAUTSTR_": "
DO ^DIC
IF Y'>0
GOTO FIRST
DO SET
+4 FOR VAI=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 VAUTX=X
SET X=$EXTRACT(VAUTX,2,999)
DO ^DIC
IF Y>0
DO SET
IF VAX
GOTO REDO
IF 'VAERR
SET VAI=VAI+1
+5 GOTO QUIT
SET SET VAX=0
IF $DATA(VAUTX)
SET J=$SELECT(VAUTNI=2:+Y,1:$PIECE(Y(0),"^"))
KILL VAUTX
SET VAERR=$SELECT($DATA(@VAUTVB@(J)):0,1:1)
WRITE $SELECT('VAERR:"...removed from list...",1:"...not on list...can't remove")
IF VAERR
QUIT
SET VAI=VAI-1
KILL @VAUTVB@(J)
IF $ORDER(@VAUTVB@(0))']""
SET VAX=1
QUIT
+1 SET VAERR=0
IF $SELECT($DATA(@VAUTVB@($PIECE(Y(0),U))):1,$DATA(@VAUTVB@(+Y)):1,1:0)
WRITE !?3,*7,"You have already selected that ",VAUTSTR,". Try again."
SET VAERR=1
+2 IF VAUTNI=1
SET @VAUTVB@($PIECE(Y(0),U))=+Y
QUIT
+3 IF VAUTNI=3
SET @VAUTVB@($PIECE(Y(0,0),U))=+Y
QUIT
+4 SET @VAUTVB@(+Y)=$PIECE(Y(0),U)
QUIT
QQ WRITE !,"ENTER:"
IF ($DATA(@(VAUTVB))=1&'$DATA(VAUTNALL))
WRITE !?5,"- Return for all ",VAUTSTR,"s, or"
WRITE !?5,"- A ",VAUTSTR," and return when all ",VAUTSTR,"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(@VAUTVB@(0))]""
WRITE !?5,"- An entry preceeded by a minus [-] sign to remove entry from list."
+4 IF $ORDER(@VAUTVB@(0))]""
WRITE !,"NOTE, you have already selected:"
SET VAJ=0
FOR VAJ1=0:0
SET VAJ=$ORDER(@VAUTVB@(VAJ))
IF VAJ=""
QUIT
WRITE !?8,$SELECT(VAUTNI=1:VAJ,1:@VAUTVB@(VAJ))
+5 QUIT
ERR SET Y=-1
QUIT IF '$DATA(Y)
SET Y=1
KILL DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNALL,VAUTNI,VAUTSTR,VAUTVB,X
QUIT
