DVBAUDASK1 ;ALB/CP - UTL Reusable prompting subroutines #1 ; 10/11/18 8:08am
;;2.7;AMIE;**256**;;Build 19
; Per VHA Directive 6402 this routine should not be modified
; ^DIR ; IA #10006
; ^DISV( ; IA # 510
Q
;
ASKLIST(DVBOUTPUT,DVBINPUT,DVBMAXNUM,DVBDEF) ; DVBPROMPT the user to 'Select NUMBER(S): '.
;
N @($$DIR^DVBAUDNEW1())
N DVBCODE,DVBNUM,DVBPCE,DVBVALUE
; ZEXCEPT: DIR,DVBQUIT,U,X,Y
;
K DVBOUTPUT ; Refresh DVBOUTPUT array
S DVBQUIT=0 ;. Initialize DVBOUTPUT status flag to successful
;
S DIR(0)="LAO^1:"_DVBMAXNUM ;....... User may select list or range
S DIR("A")="Select NUMBER(S): " ; Set text of DVBPROMPT
I $G(DVBDEF)]"" S DIR("B")=DVBDEF ;.... Optionally set DVBPROMPT default DVBVALUE
D ^DIR ;......................... DVBPROMPT user
;
S DVBOUTPUT=X ;................... Return user's selection in DVBOUTPUT
S DVBOUTPUT("DVBCNT")=DVBMAXNUM ;....... Number of choices in DVBPROMPT list
I "^"[X SET DVBQUIT=1 Q ;........ Set status to unsuccessful on '^'
;
S DVBNUM=""
F DVBPCE=1:1 S DVBNUM=$P(Y,",",DVBPCE) Q:'DVBNUM D ;
. S DVBCODE=$P(DVBINPUT(DVBNUM),U,1),DVBVALUE=$P(DVBINPUT(DVBNUM),U,2)
. S DVBOUTPUT(DVBCODE)=DVBVALUE
;
I '$O(DVBOUTPUT(""))']"" SET DVBQUIT=1 Q ; No choice made by user
;
Q ; ASKLIST
;
ASKNUM(DVBMAXNUM,DVBDEF,DVBPROMPT,DVBLINEFEED) ; Extrinsic to DVBPROMPT from 1 to DVBMAXNUM
;
N DVBCNT,DVBRESPONSE
; ZEXCEPT: DTIME
;
S DVBMAXNUM=$G(DVBMAXNUM) ; There is not a default maximum number set
S DVBDEF=$G(DVBDEF) ; There is no default DVBRESPONSE to the DVBPROMPT, unless the default is passed.
S DVBPROMPT=$G(DVBPROMPT,"Select NUMBER")
S DVBPROMPT=DVBPROMPT_$S(DVBMAXNUM<2:": ",1:"(1-"_DVBMAXNUM_"): ")
S DVBLINEFEED=$G(DVBLINEFEED,1)
F DVBCNT=1:1:DVBLINEFEED W ! ; Issue number of linefeeds based on DVBLINEFEED variable
;
ASKNUM1 ; Return to this label upon receiving an incorrect DVBRESPONSE
;
W DVBPROMPT I DVBDEF]"" W DVBDEF_"// "
R DVBRESPONSE:DTIME I DVBRESPONSE="",DVBDEF="" S DVBRESPONSE="^"
S:$T DVBRESPONSE="^"
I DVBDEF]"",DVBRESPONSE="" S DVBRESPONSE=DVBDEF
I "^"[DVBRESPONSE Q DVBRESPONSE
I DVBRESPONSE'?1.20N!(DVBRESPONSE<1)!((DVBRESPONSE>DVBMAXNUM)&(DVBMAXNUM>1)) D G ASKNUM1
. Q:DVBMAXNUM'>1
. I DVBMAXNUM>1 D Q ;
. . W $C(7)," Enter a number from 1 to "_$FN(DVBMAXNUM,",")_" or '^' to exit."
. . W !
. W $C(7)," Enter a positive integer (1, 2, etc.); or '^' to exit.",!
;
Q DVBRESPONSE ; ASKNUM
;
ASKPKG(DVBPROMPT) ; DVBPROMPT for 2-7 character Package NAMESPACE
;
N DVBASCII,DVBPOS
;
ASKPKG1 ; Return to this label upon receiving an incorrect DVBRESPONSE
;
S DVBQUIT=0 ; Initialize quit status flag to 0 (or do not quit)
S DVBPROMPT=$G(DVBPROMPT,"Which 2-7 character Package NAMESPACE: ")
;
W !!,DVBPROMPT
; If user times out or enters a '^' to exit, set DVBQUIT=1
R DVBPKG:DTIME I '$T!("^"[DVBPKG) S DVBQUIT=1 Q
;
F DVBPOS=1:1 Q:DVBPOS>$L(DVBPKG)!DVBQUIT D ;
. I DVBPOS=1,"%ABCDEFGHIJKLMNOPQRSTUVWXYZ"'[$E(DVBPKG) D Q
. . S DVBQUIT=1 ; 1st character must be % or alphabetic
. S DVBASCII=$A($E(DVBPKG,DVBPOS,DVBPOS)) ; DVBASCII character representation
. I "0123456789"'[$E(DVBPKG,DVBPOS,DVBPOS),DVBASCII>96,DVBASCII<123 D ;
. . S DVBQUIT=1 ; Non-alphabetic or numeric char. found
;
I DVBPKG["?"!(DVBPKG="")!($L(DVBPKG)<2)!($L(DVBPKG)>7) D ;
. S DVBQUIT=1 ; Namespace must be 2 to 7 characters
;
I DVBQUIT D ERRMSG1,ERRMSG2 G ASKPKG1
;
Q ; ASKPKG
;
ASKYESNO(DVBPROMPT,DVBDEF) ; Extrinsic, DVBPROMPT for YES, NO DVBRESPONSE
;
N @($$DIR^DVBAUDNEW1())
; ZEXCEPT: DIR,Y
;
S DVBPROMPT=$G(DVBPROMPT) ; Default DVBRESPONSE to "NO" if not passed
S DVBDEF=$G(DVBDEF,"NO")
;
S (DIR("?"),DIR("??"))="Enter 'Y' (for YES), 'N' (for NO), or '^' (to exit)"
S DIR(0)="Y",DIR("A")=DVBPROMPT
I DVBDEF]"" S DIR("B")=DVBDEF
;
D ^DIR
;
I "^"[Y!(Y["^") Q "^"
I Y=1 Q "Y"
I Y=0 Q "N"
;
Q "N" ; ASKYESNO
;
ERRMSG1 ; Package NAMESPACE requirements were NOT met.
;
I DVBPKG'["?" W " ??"
W !!?6,"Enter the first 2 to 7 characters of the Package NAMESPACE, or"
W !?6,"enter an '^' to exit.",!
W !?6,"The first character must be an alphabetic or % character, followed by"
W !?6,"any alphanumeric combination, however, all alphabetic characters"
W !?6,"must be in uppercase with no lowercase characters allowed."
;
Q ; ERRMSG1
;
ERRMSG2 ; <CAPS LOCK> key if not on.
;
D CENTER^DVBAUDPRT1("Make sure your <CAPS LOCK> key is on.",2,IOM,1)
;
Q ; ERRMSG2
;
GETKEYWD(DVBMINLEN,DVBMAXLEN) ; DVBPROMPT for KEYWORD
;
N DVBPOS,DVBKEYWRD
; ZEXCEPT: DTIME,IOM,DVBKEYWRD,DVBQUIT
;
W !
GETKEY1 ; Return to this label upon receiving an incorrect DVBRESPONSE
;
W !,"Select a KEYWORD (from "_DVBMINLEN_" to "_DVBMAXLEN_" characters): "
S DVBQUIT=0 ; Do not quit when returning to the calling module
;
R DVBKEYWRD:DTIME S:'$T DVBKEYWRD="^"
I DVBKEYWRD="" S DVBQUIT=1 Q ; No keyword found
I DVBKEYWRD["^" S DVBQUIT=1 Q ;User entered an '^'
I $L(DVBKEYWRD)<DVBMINLEN!($L(DVBKEYWRD)>DVBMAXLEN) W " ??" G GETKEY1
F DVBPOS=1:1:$L(DVBKEYWRD) D I DVBQUIT G GETKEY1
. ; Verify that the Keyword is in uppercase format.
. I $A($E(DVBKEYWRD,DVBPOS,DVBPOS))>96,$A($E(DVBKEYWRD,DVBPOS,DVBPOS))<123 D ;
. . N DVBMSG
. . S DVBMSG="Make sure <Caps Lock> key in on and re-enter your keyword"
. . D CENTER^DVBAUDPRT1(DVBMSG,1,IOM,1)
. . S DVBQUIT=1 ; Keyword entered is not all uppercase chars.
;
Q ; GETKEYWD
;
GETSORT(DVBRTN,DVBINPUT,DVBDEF) ; Get sorting criteria (generic subroutine call)
;
N DVBCNT,DVBPOS,DVBRESPONSE,DVBSORT
;
I $G(DVBDEF)>0,$D(DVBINPUT(DVBDEF)) S DVBDEF=DVBDEF ;Allows override of ^DISV global
E S DVBDEF=$G(^DISV(DUZ,DVBRTN,"DVBSORT"),1)
S DVBQUIT=0 ; Do not quit when returning to the calling module
;
W !
W !,"Sort by"
F DVBCNT=1:1 Q:'$D(DVBINPUT(DVBCNT)) D ;
. S DVBPOS=$S($L(DVBCNT)>9:$L(DVBCNT),1:2) ; Horizontal print position
. W !?DVBPOS,$J(DVBCNT,2),") ",DVBINPUT(DVBCNT)
S DVBCNT=DVBCNT-1
;
S DVBRESPONSE=$$ASKNUM(DVBCNT,DVBDEF) I DVBRESPONSE="" S DVBRESPONSE=DVBDEF
I DVBRESPONSE["^" S DVBQUIT=1 Q ; User entered an '^'
;
;S DVBRTN=DVBRESPONSE
S ^DISV(DUZ,DVBRTN,"DVBSORT")=DVBRESPONSE
;
Q ; GETSORT
;
USRLIMIT(DVBRTN) ; Include (active users, inactive users, or both active and
;
N DVBDEF
;
S DVBDEF=$G(^DISV(DUZ,DVBRTN,"DVBULIMIT"),1) ; Default DVBRESPONSE to DVBPROMPT
;
W !
W !,"Include"
W !?4,"1) Both active and inactive users"
W !?4,"2) Only active users"
W !?4,"3) Only inactive users"
;
S DVBULIMIT=$$ASKNUM(3,DVBDEF)
I DVBULIMIT="^" SET DVBQUIT=1 Q ; User entered an '^'
;
S ^DISV(DUZ,DVBRTN,"DVBULIMIT")=DVBULIMIT
S DVBQUIT=0 ; Do not quit when returning to the calling module
;
Q ; USRLIMIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAUDASK1 6862 printed Sep 17, 2026@20:27:12 Page 2
DVBAUDASK1 ;ALB/CP - UTL Reusable prompting subroutines #1 ; 10/11/18 8:08am
+1 ;;2.7;AMIE;**256**;;Build 19
+2 ; Per VHA Directive 6402 this routine should not be modified
+3 ; ^DIR ; IA #10006
+4 ; ^DISV( ; IA # 510
+5 QUIT
+6 ;
ASKLIST(DVBOUTPUT,DVBINPUT,DVBMAXNUM,DVBDEF) ; DVBPROMPT the user to 'Select NUMBER(S): '.
+1 ;
+2 NEW @($$DIR^DVBAUDNEW1())
+3 NEW DVBCODE,DVBNUM,DVBPCE,DVBVALUE
+4 ; ZEXCEPT: DIR,DVBQUIT,U,X,Y
+5 ;
+6 ; Refresh DVBOUTPUT array
KILL DVBOUTPUT
+7 ;. Initialize DVBOUTPUT status flag to successful
SET DVBQUIT=0
+8 ;
+9 ;....... User may select list or range
SET DIR(0)="LAO^1:"_DVBMAXNUM
+10 ; Set text of DVBPROMPT
SET DIR("A")="Select NUMBER(S): "
+11 ;.... Optionally set DVBPROMPT default DVBVALUE
IF $GET(DVBDEF)]""
SET DIR("B")=DVBDEF
+12 ;......................... DVBPROMPT user
DO ^DIR
+13 ;
+14 ;................... Return user's selection in DVBOUTPUT
SET DVBOUTPUT=X
+15 ;....... Number of choices in DVBPROMPT list
SET DVBOUTPUT("DVBCNT")=DVBMAXNUM
+16 ;........ Set status to unsuccessful on '^'
IF "^"[X
SET DVBQUIT=1
QUIT
+17 ;
+18 SET DVBNUM=""
+19 ;
FOR DVBPCE=1:1
SET DVBNUM=$PIECE(Y,",",DVBPCE)
if 'DVBNUM
QUIT
Begin DoDot:1
+20 SET DVBCODE=$PIECE(DVBINPUT(DVBNUM),U,1)
SET DVBVALUE=$PIECE(DVBINPUT(DVBNUM),U,2)
+21 SET DVBOUTPUT(DVBCODE)=DVBVALUE
End DoDot:1
+22 ;
+23 ; No choice made by user
IF '$ORDER(DVBOUTPUT(""))']""
SET DVBQUIT=1
QUIT
+24 ;
+25 ; ASKLIST
QUIT
+26 ;
ASKNUM(DVBMAXNUM,DVBDEF,DVBPROMPT,DVBLINEFEED) ; Extrinsic to DVBPROMPT from 1 to DVBMAXNUM
+1 ;
+2 NEW DVBCNT,DVBRESPONSE
+3 ; ZEXCEPT: DTIME
+4 ;
+5 ; There is not a default maximum number set
SET DVBMAXNUM=$GET(DVBMAXNUM)
+6 ; There is no default DVBRESPONSE to the DVBPROMPT, unless the default is passed.
SET DVBDEF=$GET(DVBDEF)
+7 SET DVBPROMPT=$GET(DVBPROMPT,"Select NUMBER")
+8 SET DVBPROMPT=DVBPROMPT_$SELECT(DVBMAXNUM<2:": ",1:"(1-"_DVBMAXNUM_"): ")
+9 SET DVBLINEFEED=$GET(DVBLINEFEED,1)
+10 ; Issue number of linefeeds based on DVBLINEFEED variable
FOR DVBCNT=1:1:DVBLINEFEED
WRITE !
+11 ;
ASKNUM1 ; Return to this label upon receiving an incorrect DVBRESPONSE
+1 ;
+2 WRITE DVBPROMPT
IF DVBDEF]""
WRITE DVBDEF_"// "
+3 READ DVBRESPONSE:DTIME
IF DVBRESPONSE=""
IF DVBDEF=""
SET DVBRESPONSE="^"
+4 if $TEST
SET DVBRESPONSE="^"
+5 IF DVBDEF]""
IF DVBRESPONSE=""
SET DVBRESPONSE=DVBDEF
+6 IF "^"[DVBRESPONSE
QUIT DVBRESPONSE
+7 IF DVBRESPONSE'?1.20N!(DVBRESPONSE<1)!((DVBRESPONSE>DVBMAXNUM)&(DVBMAXNUM>1))
Begin DoDot:1
+8 if DVBMAXNUM'>1
QUIT
+9 ;
IF DVBMAXNUM>1
Begin DoDot:2
+10 WRITE $CHAR(7)," Enter a number from 1 to "_$FNUMBER(DVBMAXNUM,",")_" or '^' to exit."
+11 WRITE !
End DoDot:2
QUIT
+12 WRITE $CHAR(7)," Enter a positive integer (1, 2, etc.); or '^' to exit.",!
End DoDot:1
GOTO ASKNUM1
+13 ;
+14 ; ASKNUM
QUIT DVBRESPONSE
+15 ;
ASKPKG(DVBPROMPT) ; DVBPROMPT for 2-7 character Package NAMESPACE
+1 ;
+2 NEW DVBASCII,DVBPOS
+3 ;
ASKPKG1 ; Return to this label upon receiving an incorrect DVBRESPONSE
+1 ;
+2 ; Initialize quit status flag to 0 (or do not quit)
SET DVBQUIT=0
+3 SET DVBPROMPT=$GET(DVBPROMPT,"Which 2-7 character Package NAMESPACE: ")
+4 ;
+5 WRITE !!,DVBPROMPT
+6 ; If user times out or enters a '^' to exit, set DVBQUIT=1
+7 READ DVBPKG:DTIME
IF '$TEST!("^"[DVBPKG)
SET DVBQUIT=1
QUIT
+8 ;
+9 ;
FOR DVBPOS=1:1
if DVBPOS>$LENGTH(DVBPKG)!DVBQUIT
QUIT
Begin DoDot:1
+10 IF DVBPOS=1
IF "%ABCDEFGHIJKLMNOPQRSTUVWXYZ"'[$EXTRACT(DVBPKG)
Begin DoDot:2
+11 ; 1st character must be % or alphabetic
SET DVBQUIT=1
End DoDot:2
QUIT
+12 ; DVBASCII character representation
SET DVBASCII=$ASCII($EXTRACT(DVBPKG,DVBPOS,DVBPOS))
+13 ;
IF "0123456789"'[$EXTRACT(DVBPKG,DVBPOS,DVBPOS)
IF DVBASCII>96
IF DVBASCII<123
Begin DoDot:2
+14 ; Non-alphabetic or numeric char. found
SET DVBQUIT=1
End DoDot:2
End DoDot:1
+15 ;
+16 ;
IF DVBPKG["?"!(DVBPKG="")!($LENGTH(DVBPKG)<2)!($LENGTH(DVBPKG)>7)
Begin DoDot:1
+17 ; Namespace must be 2 to 7 characters
SET DVBQUIT=1
End DoDot:1
+18 ;
+19 IF DVBQUIT
DO ERRMSG1
DO ERRMSG2
GOTO ASKPKG1
+20 ;
+21 ; ASKPKG
QUIT
+22 ;
ASKYESNO(DVBPROMPT,DVBDEF) ; Extrinsic, DVBPROMPT for YES, NO DVBRESPONSE
+1 ;
+2 NEW @($$DIR^DVBAUDNEW1())
+3 ; ZEXCEPT: DIR,Y
+4 ;
+5 ; Default DVBRESPONSE to "NO" if not passed
SET DVBPROMPT=$GET(DVBPROMPT)
+6 SET DVBDEF=$GET(DVBDEF,"NO")
+7 ;
+8 SET (DIR("?"),DIR("??"))="Enter 'Y' (for YES), 'N' (for NO), or '^' (to exit)"
+9 SET DIR(0)="Y"
SET DIR("A")=DVBPROMPT
+10 IF DVBDEF]""
SET DIR("B")=DVBDEF
+11 ;
+12 DO ^DIR
+13 ;
+14 IF "^"[Y!(Y["^")
QUIT "^"
+15 IF Y=1
QUIT "Y"
+16 IF Y=0
QUIT "N"
+17 ;
+18 ; ASKYESNO
QUIT "N"
+19 ;
ERRMSG1 ; Package NAMESPACE requirements were NOT met.
+1 ;
+2 IF DVBPKG'["?"
WRITE " ??"
+3 WRITE !!?6,"Enter the first 2 to 7 characters of the Package NAMESPACE, or"
+4 WRITE !?6,"enter an '^' to exit.",!
+5 WRITE !?6,"The first character must be an alphabetic or % character, followed by"
+6 WRITE !?6,"any alphanumeric combination, however, all alphabetic characters"
+7 WRITE !?6,"must be in uppercase with no lowercase characters allowed."
+8 ;
+9 ; ERRMSG1
QUIT
+10 ;
ERRMSG2 ; <CAPS LOCK> key if not on.
+1 ;
+2 DO CENTER^DVBAUDPRT1("Make sure your <CAPS LOCK> key is on.",2,IOM,1)
+3 ;
+4 ; ERRMSG2
QUIT
+5 ;
GETKEYWD(DVBMINLEN,DVBMAXLEN) ; DVBPROMPT for KEYWORD
+1 ;
+2 NEW DVBPOS,DVBKEYWRD
+3 ; ZEXCEPT: DTIME,IOM,DVBKEYWRD,DVBQUIT
+4 ;
+5 WRITE !
GETKEY1 ; Return to this label upon receiving an incorrect DVBRESPONSE
+1 ;
+2 WRITE !,"Select a KEYWORD (from "_DVBMINLEN_" to "_DVBMAXLEN_" characters): "
+3 ; Do not quit when returning to the calling module
SET DVBQUIT=0
+4 ;
+5 READ DVBKEYWRD:DTIME
if '$TEST
SET DVBKEYWRD="^"
+6 ; No keyword found
IF DVBKEYWRD=""
SET DVBQUIT=1
QUIT
+7 ;User entered an '^'
IF DVBKEYWRD["^"
SET DVBQUIT=1
QUIT
+8 IF $LENGTH(DVBKEYWRD)<DVBMINLEN!($LENGTH(DVBKEYWRD)>DVBMAXLEN)
WRITE " ??"
GOTO GETKEY1
+9 FOR DVBPOS=1:1:$LENGTH(DVBKEYWRD)
Begin DoDot:1
+10 ; Verify that the Keyword is in uppercase format.
+11 ;
IF $ASCII($EXTRACT(DVBKEYWRD,DVBPOS,DVBPOS))>96
IF $ASCII($EXTRACT(DVBKEYWRD,DVBPOS,DVBPOS))<123
Begin DoDot:2
+12 NEW DVBMSG
+13 SET DVBMSG="Make sure <Caps Lock> key in on and re-enter your keyword"
+14 DO CENTER^DVBAUDPRT1(DVBMSG,1,IOM,1)
+15 ; Keyword entered is not all uppercase chars.
SET DVBQUIT=1
End DoDot:2
End DoDot:1
IF DVBQUIT
GOTO GETKEY1
+16 ;
+17 ; GETKEYWD
QUIT
+18 ;
GETSORT(DVBRTN,DVBINPUT,DVBDEF) ; Get sorting criteria (generic subroutine call)
+1 ;
+2 NEW DVBCNT,DVBPOS,DVBRESPONSE,DVBSORT
+3 ;
+4 ;Allows override of ^DISV global
IF $GET(DVBDEF)>0
IF $DATA(DVBINPUT(DVBDEF))
SET DVBDEF=DVBDEF
+5 IF '$TEST
SET DVBDEF=$GET(^DISV(DUZ,DVBRTN,"DVBSORT"),1)
+6 ; Do not quit when returning to the calling module
SET DVBQUIT=0
+7 ;
+8 WRITE !
+9 WRITE !,"Sort by"
+10 ;
FOR DVBCNT=1:1
if '$DATA(DVBINPUT(DVBCNT))
QUIT
Begin DoDot:1
+11 ; Horizontal print position
SET DVBPOS=$SELECT($LENGTH(DVBCNT)>9:$LENGTH(DVBCNT),1:2)
+12 WRITE !?DVBPOS,$JUSTIFY(DVBCNT,2),") ",DVBINPUT(DVBCNT)
End DoDot:1
+13 SET DVBCNT=DVBCNT-1
+14 ;
+15 SET DVBRESPONSE=$$ASKNUM(DVBCNT,DVBDEF)
IF DVBRESPONSE=""
SET DVBRESPONSE=DVBDEF
+16 ; User entered an '^'
IF DVBRESPONSE["^"
SET DVBQUIT=1
QUIT
+17 ;
+18 ;S DVBRTN=DVBRESPONSE
+19 SET ^DISV(DUZ,DVBRTN,"DVBSORT")=DVBRESPONSE
+20 ;
+21 ; GETSORT
QUIT
+22 ;
USRLIMIT(DVBRTN) ; Include (active users, inactive users, or both active and
+1 ;
+2 NEW DVBDEF
+3 ;
+4 ; Default DVBRESPONSE to DVBPROMPT
SET DVBDEF=$GET(^DISV(DUZ,DVBRTN,"DVBULIMIT"),1)
+5 ;
+6 WRITE !
+7 WRITE !,"Include"
+8 WRITE !?4,"1) Both active and inactive users"
+9 WRITE !?4,"2) Only active users"
+10 WRITE !?4,"3) Only inactive users"
+11 ;
+12 SET DVBULIMIT=$$ASKNUM(3,DVBDEF)
+13 ; User entered an '^'
IF DVBULIMIT="^"
SET DVBQUIT=1
QUIT
+14 ;
+15 SET ^DISV(DUZ,DVBRTN,"DVBULIMIT")=DVBULIMIT
+16 ; Do not quit when returning to the calling module
SET DVBQUIT=0
+17 ;
+18 ; USRLIMIT
QUIT
