- 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
