DVBAUDASK2 ;ALB/CP - UTL Reusable prompting subroutines #2 ; 10/26/18 10:02am
;;2.7;AMIE;**256**;;Build 19
; Per VHA Directive 6402 this DVBROUTINE should not be modified6
; $$GET1^DIQ ;......IA # 2056
; GETS^DIQ ;......IA # 2056
; $$UP^XLFSTR ;......IA #10104
; ^%ZOSF("RSEL") ; IA #10096
; ^DIC( ;..... IA # 821
; ^DIC(4 ;..... IA #10090
; ^DISV( ;..... IA # 510
Q
;
ENTRIES(DVBROUTINE,DVBFILENUM) ; DVBPROMPT for which for file entries to include
;
N DVBDEFAULT,DIERR,DVBERRMSG,DVBFILENAME,DVBMAXIMUM
S DVBQUIT=0
;
S DVBDEFAULT=$G(^DISV(DUZ,$T(+0),"DVBENTRY"),1)
I $G(DVBENTRY) S DVBDEFAULT="" ; No DVBDEFAULT when repeatedly executed
S DVBFILENAME=$$GET1^DIQ(1,DVBFILENUM_",",.01) ;DVBFILENAME from ,01 of file 1
I DVBFILENAME="" D S DVBQUIT=1 Q
. S DVBERRMSG="FILENAME for File #"_DVBFILENUM_" does not exist"
. D CENTER^DVBAUDPRT1(DVBERRMSG,1,IOM,1)
. D CONTINUE^DVBAUDPRT1(2,"R")
;
S DVBMAXIMUM=3,DVBQUIT=0
W !
W !,"Which ",DVBFILENAME," file entries"
W !?5,"1) Select a from-to entry range"
W !?5,"2) All entries for a selected package"
W !?5,"3) All entries"
;
S DVBENTRY=$$ASKNUM^DVBAUDASK1(DVBMAXIMUM,DVBDEFAULT)
I "^"[DVBENTRY S DVBQUIT=1 Q
S ^DISV(DUZ,$T(+0),"DVBENTRY")=DVBENTRY
;
K DVBENTRY
Q ; ENTRIES
;
FILERNG ; DVBPROMPT for the beginning & ending file number range
;
N DVBMSG
; ZEXCEPT: DTIME,DVBNUMBEG,DVBNUMEND,DVBQUIT
S DVBQUIT=0
S DVBMSG=" Enter the first number of the numeric number range."
;
NUMVALS1 ;
N DVBNUMBEG,DVBNUMEND
S (DVBNUMBEG,DVBNUMEND)="" ; Initialize from-to range to null.
W !!,"Enter the range of numeric values"
NUMVALS2 ;
S DVBMSG=" Enter the first number of the numeric number range."
W !," Start with: " R DVBNUMBEG:DTIME
I "^"[DVBNUMBEG S DVBQUIT=1 Q
I DVBNUMBEG["?"!(DVBNUMBEG=" ") W !,DVBMSG G NUMVALS2
S DVBNUMBEG=$$UP^XLFSTR(DVBNUMBEG) ; Convert to uppercase format
NUMVALS3 ;
W !," End with: " R DVBNUMEND:DTIME
S DVBMSG=" Enter the last number of the numeric number range."
I DVBNUMEND["?"!(DVBNUMBEG=" ") W !,DVBMSG G NUMVALS3
I DVBNUMEND["^" S DVBQUIT=1 Q
I DVBNUMEND="" G NUMVALS1
S DVBNUMEND=$$UP^XLFSTR(DVBNUMEND) ; Convert to uppercase format
;
I '$$FTVALSOK(DVBNUMBEG,DVBNUMEND)!$G(DVBQUIT) G NUMVALS1
;
Q ; FILERNG
;
FTVALS(DVBFILENAME) ; DVBPROMPT for the beginning & ending free text data
;
N DVBMSG
; ZEXCEPT: DTIME,DVBFTBEG,DVBFTEND,DVBQUIT
;
; Validate the input FILENAME first.
I '$O(^DIC("B",DVBFILENAME,0)) S DVBQUIT=1 G FTVALSX
S DVBMSG=" Enter the complete or partial entry name from the "
S DVBMSG=DVBMSG_DVBFILENAME_" file."
S DVBQUIT=0
;
FTVALS1 ;
S (DVBFTBEG,DVBFTEND)="" ; Initialize output values to null.
W !!,"Enter the range of ",DVBFILENAME," values"
FTVALS2 ;
W !," Start with: " R DVBFTBEG:DTIME
I "^"[DVBFTBEG S DVBQUIT=1 G FTVALSX
I DVBFTBEG["?"!(DVBFTBEG=" ") W !,DVBMSG G FTVALS2
S DVBFTBEG=$$UP^XLFSTR(DVBFTBEG) ; Convert to uppercase format
FTVALS3 ;
W !," End with: " R DVBFTEND:DTIME
I DVBFTEND["?"!(DVBFTBEG=" ") W !,DVBMSG G FTVALS3
I DVBFTEND["^" S DVBQUIT=1 Q
I DVBFTEND="" G FTVALS1
S DVBFTEND=$$UP^XLFSTR(DVBFTEND) ; Convert to uppercase format
;
I '$$FTVALSOK(DVBFTBEG,DVBFTEND)!$G(DVBQUIT)=1 G FTVALS1
;
FTVALSX ; Exit FTVALS subroutine
;
Q ; FTVALS
;
FTVALSOK(DVB2FTBEG,DVB2FTEND) ; Extrinsic function to verify a from-to
;
N DVBRETURN
; ZEXCEPT: DVBQUIT
S DVBRETURN=1
;
I DVB2FTBEG'>0!(DVB2FTEND'>0),DVB2FTBEG]DVB2FTEND D ; Handles a free text range
. I DVB2FTBEG,DVB2FTEND Q:$E(DVB2FTEND)>$E(DVB2FTBEG) ; Quit if numeric end<beg
. I DVB2FTBEG,DVB2FTEND,$L(DVB2FTEND)>$L(DVB2FTBEG) Q
. W $C(7)
. D CENTER^DVBAUDPRT1("Error: 'Start with' value follows 'End with' value",2,80,1)
. S DVBRETURN=0,DVBQUIT=1
;
I DVB2FTBEG>0!(DVB2FTEND>0),DVB2FTEND<DVB2FTBEG D ; Handles a numeric range
. W $C(7)
. D CENTER^DVBAUDPRT1("Error: 'End with' value is less than 'Start with' value",2,80,1)
. S DVBRETURN=0,DVBQUIT=1
;
Q DVBRETURN ; Extrinsic $$FTVALSOK
;
RSEL ; Routine selector with user message when no routine selected.
;
N %JO,%R,%Y
N DVBROUTINE,XRSEL
; ZEXCEPT: IOM,DVBQUIT
;
S DVBQUIT=0
K ^UTILITY($J) ; Start with a fresh ^UTILITY($J) global
S XRSEL=$G(^%ZOSF("RSEL")) I XRSEL="" S DVBQUIT=1 Q
X XRSEL
S DVBROUTINE=$O(^UTILITY($J,"%")) ; % is the 1st valid DVBROUTINE name char
I DVBROUTINE']"" D ;
. D CENTER^DVBAUDPRT1("No valid routines names were selected!",2,IOM,1)
. D CONTINUE^DVBAUDPRT1(2,"R")
. S DVBQUIT=1
;
Q ; RSEL
;
SITE200(DVBRTN,DVBSTANUM,DVBPROMPT) ; DVBPROMPT for 'Which INSTITUTION(S) "
;
N DVBCNT,DVBDEF,DVBFIELDS,DVBIEN4,DVBIENS,DVBINARRAY,DVBMAX,DVBSITE,DVBSUFFIX
; ZEXCEPT: DIERR,DUZ,DVBQUIT,DVBSITE,U
;
K DVBSITE ; Start with a fresh output array
S DVBQUIT=0 ; DVBDEFAULT output quit flag to zero (don't quit)
;
; Quit if required DVBRTN parameter is missing.
;
I $G(DVBRTN)="" S DVBQUIT=1 Q
;
S DVBSTANUM=$G(DVBSTANUM,$$HOSTSITE^DVBAUDSTR1("SN")) ; STATION NUMBER #99
S DVBPROMPT=$G(DVBPROMPT,"Which INSTITUTION(S): ")
;
S DVBDEF=$G(^DISV(DUZ,DVBRTN,DVBSTANUM,"DVBSITE")) ; Set DVBPROMPT DVBDEFAULT
;
S DVBIEN4=$O(^DIC(4,"D",DVBSTANUM,0)),DVBIENS=DVBIEN4_"," I DVBIEN4="" S DVBQUIT=1 Q
;
; NAME (#.01);STATUS (#11);STATION NUMBER (#99);INACTIVE FLAG (#101)
S DVBFIELDS=".01;11;99;101"
D GETS^DIQ(4,DVBIENS,DVBFIELDS,"ER","DVBSITE") I $G(DIERR) S DVBQUIT=1 Q
S DVBQUIT=0 D SCRN200(.DVBSITE,DVBIENS) I DVBQUIT S DVBQUIT=1 Q
S DVBCNT=1
S $P(DVBPROMPT(DVBCNT),U,1)=DVBIEN4
S $P(DVBPROMPT(DVBCNT),U,2)=DVBSITE(4,DVBIENS,"NAME","E")
S $P(DVBPROMPT(DVBCNT),U,3)=$G(DVBSITE(4,DVBIENS,"STATION NUMBER","E"))
;
; For multi-station facilities, loop through all of the STATION
; NUMBER 'D' cross references to retrieve and display
; all of the various facilities with a STATION NUMBER DVBSUFFIX
; for possible input selection.
;
S DVBSUFFIX=DVBSTANUM_" " ; Concatenate ' ' to avoid missing any suffixes
F S DVBSUFFIX=$O(^DIC(4,"D",DVBSUFFIX)) Q:$E(DVBSUFFIX,1,3)]DVBSTANUM!DVBQUIT D ;
. S DVBIEN4=$O(^DIC(4,"D",DVBSUFFIX,0)) Q:'DVBIEN4 S DVBIENS=DVBIEN4_","
. D GETS^DIQ(4,DVBIENS,DVBFIELDS,"ER","DVBSITE") I $G(DIERR) S DVBQUIT=1 Q
. S DVBQUIT=0 D SCRN200(.DVBSITE,DVBIENS) I DVBQUIT S DVBQUIT=0 Q
. I DVBSITE(4,DVBIENS,"INACTIVE FACILITY FLAG","E")'="" Q
. S DVBCNT=DVBCNT+1
. S $P(DVBPROMPT(DVBCNT),U,1)=DVBIEN4
. S $P(DVBPROMPT(DVBCNT),U,2)=DVBSITE(4,DVBIENS,"NAME","E")
. S $P(DVBPROMPT(DVBCNT),U,3)=DVBSITE(4,DVBIENS,"STATION NUMBER","E")
;
S DVBMAX=DVBCNT ; DVBMAXIMUM number for input selection choices
;
; If no previous DVBDEFAULT found, set the DVBDEFAULT to 1-DVBMAX
; and also set the number of list choices in variable DVBSITE("DVBCNT")
;
I DVBDEF="" S DVBDEF="1-"_DVBMAX ; First time DVBDEFAULT response of 1-DVBMAX
S DVBSITE("DVBCNT")=DVBMAX ;.... Number active National Institutions
;
W !!,DVBPROMPT," (Example 1,3 or 1-",DVBMAX,")"
S DVBCNT=0
F S DVBCNT=$O(DVBPROMPT(DVBCNT)) Q:'DVBCNT D ;
. W !?3,$J(DVBCNT,2),") ",$P(DVBPROMPT(DVBCNT),U,2)
. I $P(DVBPROMPT(DVBCNT),U,3)]"" W " (",$P(DVBPROMPT(DVBCNT),U,3),")"
;
S DVBQUIT=0 D ASKLIST^DVBAUDASK1(.DVBSITE,.DVBPROMPT,DVBMAX,DVBDEF) Q:DVBQUIT
;
; Save the user's response which will become the future DVBDEFAULT
;
S ^DISV(DUZ,DVBRTN,DVBSTANUM,"DVBSITE")=DVBSITE
;
Q ; SITE200
;
SCRN200(DVBSITE,DVBIENS) ;Screen site200 (Institution) entry, set DVBQUIT=1 to bypass
; Input:
; DVBSITE ; Required ; Output of GETS^DIQ(4, of SITE200 entry point
; called by reference.
; DVBIENS ; Required ; Internal entry number string for referencing
; an array from the output array element of
; GETS^DIQ of the GETSITE entry point.
;
; Output:
; DVBQUIT ; 0 ; if entry is to be kept.
; 1 ; if entry is to be bypassed because it is not
; a 'National' STATUS or the INACTIVE FACILITY
; FLAG is set.
;
; Intended use:
; Subroutine to support entry point SITE200 and is NOT supported
; as an independent API entry point.
;
; Verify the Institution is a 'National' active 'VAMC'
; ZEXCEPT: DVBIENS,DVBQUIT,DVBSITE
;
S DVBQUIT=0
I DVBSITE(4,DVBIENS,"STATUS","E")'="National" S DVBQUIT=1 ; Node 0 piece 11
I DVBSITE(4,DVBIENS,"INACTIVE FACILITY FLAG","E")'="" S DVBQUIT=1 ; Node 99 piece 4
I DVBQUIT K DVBSITE(4,DVBIENS) ; Kills off array entry.
;
Q ; SCRN200
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAUDASK2 8716 printed Sep 17, 2026@20:27:13 Page 2
DVBAUDASK2 ;ALB/CP - UTL Reusable prompting subroutines #2 ; 10/26/18 10:02am
+1 ;;2.7;AMIE;**256**;;Build 19
+2 ; Per VHA Directive 6402 this DVBROUTINE should not be modified6
+3 ; $$GET1^DIQ ;......IA # 2056
+4 ; GETS^DIQ ;......IA # 2056
+5 ; $$UP^XLFSTR ;......IA #10104
+6 ; ^%ZOSF("RSEL") ; IA #10096
+7 ; ^DIC( ;..... IA # 821
+8 ; ^DIC(4 ;..... IA #10090
+9 ; ^DISV( ;..... IA # 510
+10 QUIT
+11 ;
ENTRIES(DVBROUTINE,DVBFILENUM) ; DVBPROMPT for which for file entries to include
+1 ;
+2 NEW DVBDEFAULT,DIERR,DVBERRMSG,DVBFILENAME,DVBMAXIMUM
+3 SET DVBQUIT=0
+4 ;
+5 SET DVBDEFAULT=$GET(^DISV(DUZ,$TEXT(+0),"DVBENTRY"),1)
+6 ; No DVBDEFAULT when repeatedly executed
IF $GET(DVBENTRY)
SET DVBDEFAULT=""
+7 ;DVBFILENAME from ,01 of file 1
SET DVBFILENAME=$$GET1^DIQ(1,DVBFILENUM_",",.01)
+8 IF DVBFILENAME=""
Begin DoDot:1
+9 SET DVBERRMSG="FILENAME for File #"_DVBFILENUM_" does not exist"
+10 DO CENTER^DVBAUDPRT1(DVBERRMSG,1,IOM,1)
+11 DO CONTINUE^DVBAUDPRT1(2,"R")
End DoDot:1
SET DVBQUIT=1
QUIT
+12 ;
+13 SET DVBMAXIMUM=3
SET DVBQUIT=0
+14 WRITE !
+15 WRITE !,"Which ",DVBFILENAME," file entries"
+16 WRITE !?5,"1) Select a from-to entry range"
+17 WRITE !?5,"2) All entries for a selected package"
+18 WRITE !?5,"3) All entries"
+19 ;
+20 SET DVBENTRY=$$ASKNUM^DVBAUDASK1(DVBMAXIMUM,DVBDEFAULT)
+21 IF "^"[DVBENTRY
SET DVBQUIT=1
QUIT
+22 SET ^DISV(DUZ,$TEXT(+0),"DVBENTRY")=DVBENTRY
+23 ;
+24 KILL DVBENTRY
+25 ; ENTRIES
QUIT
+26 ;
FILERNG ; DVBPROMPT for the beginning & ending file number range
+1 ;
+2 NEW DVBMSG
+3 ; ZEXCEPT: DTIME,DVBNUMBEG,DVBNUMEND,DVBQUIT
+4 SET DVBQUIT=0
+5 SET DVBMSG=" Enter the first number of the numeric number range."
+6 ;
NUMVALS1 ;
+1 NEW DVBNUMBEG,DVBNUMEND
+2 ; Initialize from-to range to null.
SET (DVBNUMBEG,DVBNUMEND)=""
+3 WRITE !!,"Enter the range of numeric values"
NUMVALS2 ;
+1 SET DVBMSG=" Enter the first number of the numeric number range."
+2 WRITE !," Start with: "
READ DVBNUMBEG:DTIME
+3 IF "^"[DVBNUMBEG
SET DVBQUIT=1
QUIT
+4 IF DVBNUMBEG["?"!(DVBNUMBEG=" ")
WRITE !,DVBMSG
GOTO NUMVALS2
+5 ; Convert to uppercase format
SET DVBNUMBEG=$$UP^XLFSTR(DVBNUMBEG)
NUMVALS3 ;
+1 WRITE !," End with: "
READ DVBNUMEND:DTIME
+2 SET DVBMSG=" Enter the last number of the numeric number range."
+3 IF DVBNUMEND["?"!(DVBNUMBEG=" ")
WRITE !,DVBMSG
GOTO NUMVALS3
+4 IF DVBNUMEND["^"
SET DVBQUIT=1
QUIT
+5 IF DVBNUMEND=""
GOTO NUMVALS1
+6 ; Convert to uppercase format
SET DVBNUMEND=$$UP^XLFSTR(DVBNUMEND)
+7 ;
+8 IF '$$FTVALSOK(DVBNUMBEG,DVBNUMEND)!$GET(DVBQUIT)
GOTO NUMVALS1
+9 ;
+10 ; FILERNG
QUIT
+11 ;
FTVALS(DVBFILENAME) ; DVBPROMPT for the beginning & ending free text data
+1 ;
+2 NEW DVBMSG
+3 ; ZEXCEPT: DTIME,DVBFTBEG,DVBFTEND,DVBQUIT
+4 ;
+5 ; Validate the input FILENAME first.
+6 IF '$ORDER(^DIC("B",DVBFILENAME,0))
SET DVBQUIT=1
GOTO FTVALSX
+7 SET DVBMSG=" Enter the complete or partial entry name from the "
+8 SET DVBMSG=DVBMSG_DVBFILENAME_" file."
+9 SET DVBQUIT=0
+10 ;
FTVALS1 ;
+1 ; Initialize output values to null.
SET (DVBFTBEG,DVBFTEND)=""
+2 WRITE !!,"Enter the range of ",DVBFILENAME," values"
FTVALS2 ;
+1 WRITE !," Start with: "
READ DVBFTBEG:DTIME
+2 IF "^"[DVBFTBEG
SET DVBQUIT=1
GOTO FTVALSX
+3 IF DVBFTBEG["?"!(DVBFTBEG=" ")
WRITE !,DVBMSG
GOTO FTVALS2
+4 ; Convert to uppercase format
SET DVBFTBEG=$$UP^XLFSTR(DVBFTBEG)
FTVALS3 ;
+1 WRITE !," End with: "
READ DVBFTEND:DTIME
+2 IF DVBFTEND["?"!(DVBFTBEG=" ")
WRITE !,DVBMSG
GOTO FTVALS3
+3 IF DVBFTEND["^"
SET DVBQUIT=1
QUIT
+4 IF DVBFTEND=""
GOTO FTVALS1
+5 ; Convert to uppercase format
SET DVBFTEND=$$UP^XLFSTR(DVBFTEND)
+6 ;
+7 IF '$$FTVALSOK(DVBFTBEG,DVBFTEND)!$GET(DVBQUIT)=1
GOTO FTVALS1
+8 ;
FTVALSX ; Exit FTVALS subroutine
+1 ;
+2 ; FTVALS
QUIT
+3 ;
FTVALSOK(DVB2FTBEG,DVB2FTEND) ; Extrinsic function to verify a from-to
+1 ;
+2 NEW DVBRETURN
+3 ; ZEXCEPT: DVBQUIT
+4 SET DVBRETURN=1
+5 ;
+6 ; Handles a free text range
IF DVB2FTBEG'>0!(DVB2FTEND'>0)
IF DVB2FTBEG]DVB2FTEND
Begin DoDot:1
+7 ; Quit if numeric end<beg
IF DVB2FTBEG
IF DVB2FTEND
if $EXTRACT(DVB2FTEND)>$EXTRACT(DVB2FTBEG)
QUIT
+8 IF DVB2FTBEG
IF DVB2FTEND
IF $LENGTH(DVB2FTEND)>$LENGTH(DVB2FTBEG)
QUIT
+9 WRITE $CHAR(7)
+10 DO CENTER^DVBAUDPRT1("Error: 'Start with' value follows 'End with' value",2,80,1)
+11 SET DVBRETURN=0
SET DVBQUIT=1
End DoDot:1
+12 ;
+13 ; Handles a numeric range
IF DVB2FTBEG>0!(DVB2FTEND>0)
IF DVB2FTEND<DVB2FTBEG
Begin DoDot:1
+14 WRITE $CHAR(7)
+15 DO CENTER^DVBAUDPRT1("Error: 'End with' value is less than 'Start with' value",2,80,1)
+16 SET DVBRETURN=0
SET DVBQUIT=1
End DoDot:1
+17 ;
+18 ; Extrinsic $$FTVALSOK
QUIT DVBRETURN
+19 ;
RSEL ; Routine selector with user message when no routine selected.
+1 ;
+2 NEW %JO,%R,%Y
+3 NEW DVBROUTINE,XRSEL
+4 ; ZEXCEPT: IOM,DVBQUIT
+5 ;
+6 SET DVBQUIT=0
+7 ; Start with a fresh ^UTILITY($J) global
KILL ^UTILITY($JOB)
+8 SET XRSEL=$GET(^%ZOSF("RSEL"))
IF XRSEL=""
SET DVBQUIT=1
QUIT
+9 XECUTE XRSEL
+10 ; % is the 1st valid DVBROUTINE name char
SET DVBROUTINE=$ORDER(^UTILITY($JOB,"%"))
+11 ;
IF DVBROUTINE']""
Begin DoDot:1
+12 DO CENTER^DVBAUDPRT1("No valid routines names were selected!",2,IOM,1)
+13 DO CONTINUE^DVBAUDPRT1(2,"R")
+14 SET DVBQUIT=1
End DoDot:1
+15 ;
+16 ; RSEL
QUIT
+17 ;
SITE200(DVBRTN,DVBSTANUM,DVBPROMPT) ; DVBPROMPT for 'Which INSTITUTION(S) "
+1 ;
+2 NEW DVBCNT,DVBDEF,DVBFIELDS,DVBIEN4,DVBIENS,DVBINARRAY,DVBMAX,DVBSITE,DVBSUFFIX
+3 ; ZEXCEPT: DIERR,DUZ,DVBQUIT,DVBSITE,U
+4 ;
+5 ; Start with a fresh output array
KILL DVBSITE
+6 ; DVBDEFAULT output quit flag to zero (don't quit)
SET DVBQUIT=0
+7 ;
+8 ; Quit if required DVBRTN parameter is missing.
+9 ;
+10 IF $GET(DVBRTN)=""
SET DVBQUIT=1
QUIT
+11 ;
+12 ; STATION NUMBER #99
SET DVBSTANUM=$GET(DVBSTANUM,$$HOSTSITE^DVBAUDSTR1("SN"))
+13 SET DVBPROMPT=$GET(DVBPROMPT,"Which INSTITUTION(S): ")
+14 ;
+15 ; Set DVBPROMPT DVBDEFAULT
SET DVBDEF=$GET(^DISV(DUZ,DVBRTN,DVBSTANUM,"DVBSITE"))
+16 ;
+17 SET DVBIEN4=$ORDER(^DIC(4,"D",DVBSTANUM,0))
SET DVBIENS=DVBIEN4_","
IF DVBIEN4=""
SET DVBQUIT=1
QUIT
+18 ;
+19 ; NAME (#.01);STATUS (#11);STATION NUMBER (#99);INACTIVE FLAG (#101)
+20 SET DVBFIELDS=".01;11;99;101"
+21 DO GETS^DIQ(4,DVBIENS,DVBFIELDS,"ER","DVBSITE")
IF $GET(DIERR)
SET DVBQUIT=1
QUIT
+22 SET DVBQUIT=0
DO SCRN200(.DVBSITE,DVBIENS)
IF DVBQUIT
SET DVBQUIT=1
QUIT
+23 SET DVBCNT=1
+24 SET $PIECE(DVBPROMPT(DVBCNT),U,1)=DVBIEN4
+25 SET $PIECE(DVBPROMPT(DVBCNT),U,2)=DVBSITE(4,DVBIENS,"NAME","E")
+26 SET $PIECE(DVBPROMPT(DVBCNT),U,3)=$GET(DVBSITE(4,DVBIENS,"STATION NUMBER","E"))
+27 ;
+28 ; For multi-station facilities, loop through all of the STATION
+29 ; NUMBER 'D' cross references to retrieve and display
+30 ; all of the various facilities with a STATION NUMBER DVBSUFFIX
+31 ; for possible input selection.
+32 ;
+33 ; Concatenate ' ' to avoid missing any suffixes
SET DVBSUFFIX=DVBSTANUM_" "
+34 ;
FOR
SET DVBSUFFIX=$ORDER(^DIC(4,"D",DVBSUFFIX))
if $EXTRACT(DVBSUFFIX,1,3)]DVBSTANUM!DVBQUIT
QUIT
Begin DoDot:1
+35 SET DVBIEN4=$ORDER(^DIC(4,"D",DVBSUFFIX,0))
if 'DVBIEN4
QUIT
SET DVBIENS=DVBIEN4_","
+36 DO GETS^DIQ(4,DVBIENS,DVBFIELDS,"ER","DVBSITE")
IF $GET(DIERR)
SET DVBQUIT=1
QUIT
+37 SET DVBQUIT=0
DO SCRN200(.DVBSITE,DVBIENS)
IF DVBQUIT
SET DVBQUIT=0
QUIT
+38 IF DVBSITE(4,DVBIENS,"INACTIVE FACILITY FLAG","E")'=""
QUIT
+39 SET DVBCNT=DVBCNT+1
+40 SET $PIECE(DVBPROMPT(DVBCNT),U,1)=DVBIEN4
+41 SET $PIECE(DVBPROMPT(DVBCNT),U,2)=DVBSITE(4,DVBIENS,"NAME","E")
+42 SET $PIECE(DVBPROMPT(DVBCNT),U,3)=DVBSITE(4,DVBIENS,"STATION NUMBER","E")
End DoDot:1
+43 ;
+44 ; DVBMAXIMUM number for input selection choices
SET DVBMAX=DVBCNT
+45 ;
+46 ; If no previous DVBDEFAULT found, set the DVBDEFAULT to 1-DVBMAX
+47 ; and also set the number of list choices in variable DVBSITE("DVBCNT")
+48 ;
+49 ; First time DVBDEFAULT response of 1-DVBMAX
IF DVBDEF=""
SET DVBDEF="1-"_DVBMAX
+50 ;.... Number active National Institutions
SET DVBSITE("DVBCNT")=DVBMAX
+51 ;
+52 WRITE !!,DVBPROMPT," (Example 1,3 or 1-",DVBMAX,")"
+53 SET DVBCNT=0
+54 ;
FOR
SET DVBCNT=$ORDER(DVBPROMPT(DVBCNT))
if 'DVBCNT
QUIT
Begin DoDot:1
+55 WRITE !?3,$JUSTIFY(DVBCNT,2),") ",$PIECE(DVBPROMPT(DVBCNT),U,2)
+56 IF $PIECE(DVBPROMPT(DVBCNT),U,3)]""
WRITE " (",$PIECE(DVBPROMPT(DVBCNT),U,3),")"
End DoDot:1
+57 ;
+58 SET DVBQUIT=0
DO ASKLIST^DVBAUDASK1(.DVBSITE,.DVBPROMPT,DVBMAX,DVBDEF)
if DVBQUIT
QUIT
+59 ;
+60 ; Save the user's response which will become the future DVBDEFAULT
+61 ;
+62 SET ^DISV(DUZ,DVBRTN,DVBSTANUM,"DVBSITE")=DVBSITE
+63 ;
+64 ; SITE200
QUIT
+65 ;
SCRN200(DVBSITE,DVBIENS) ;Screen site200 (Institution) entry, set DVBQUIT=1 to bypass
+1 ; Input:
+2 ; DVBSITE ; Required ; Output of GETS^DIQ(4, of SITE200 entry point
+3 ; called by reference.
+4 ; DVBIENS ; Required ; Internal entry number string for referencing
+5 ; an array from the output array element of
+6 ; GETS^DIQ of the GETSITE entry point.
+7 ;
+8 ; Output:
+9 ; DVBQUIT ; 0 ; if entry is to be kept.
+10 ; 1 ; if entry is to be bypassed because it is not
+11 ; a 'National' STATUS or the INACTIVE FACILITY
+12 ; FLAG is set.
+13 ;
+14 ; Intended use:
+15 ; Subroutine to support entry point SITE200 and is NOT supported
+16 ; as an independent API entry point.
+17 ;
+18 ; Verify the Institution is a 'National' active 'VAMC'
+19 ; ZEXCEPT: DVBIENS,DVBQUIT,DVBSITE
+20 ;
+21 SET DVBQUIT=0
+22 ; Node 0 piece 11
IF DVBSITE(4,DVBIENS,"STATUS","E")'="National"
SET DVBQUIT=1
+23 ; Node 99 piece 4
IF DVBSITE(4,DVBIENS,"INACTIVE FACILITY FLAG","E")'=""
SET DVBQUIT=1
+24 ; Kills off array entry.
IF DVBQUIT
KILL DVBSITE(4,DVBIENS)
+25 ;
+26 ; SCRN200
QUIT
