BPSOSU4 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;03/07/08 10:38
;;1.0;E CLAIMS MGMT ENGINE;**1,7**;JUN 2004;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;----------------------------------------------------------------------
;Standard List PROMPT:
;
;Parameters:
; TYPE - S or M (single or multiple selection)
; LROOT - List global root (eg: "^LIST($J,")
; AROOT - Answer global root (eg: "^LISTANS($J,")
; STITLE - Screen Title
; .PROMPT - List PROMPT Array
; OPTIONAL - 1 or 0 (optional or required)
; PGLEN - Page length
; TIMEOUT - Number of seconds
;
;Returns:
; <null> - Unable to process list
; <Ans> - For TYPE="S", item selected
; <^> - Up-arrow entered
; <^^> - Two up-arrows entered
; <-1> - Timeout occurred
;
;----------------------------------------------------------------------
LIST(TYPE,LROOT,AROOT,STITLE,PROMPT,OPTIONAL,PGLEN,TIMEOUT) ;EP
;
;Manage local variables
N CPAGE,NPAGES,START,END,ANS,NLINES,CHEAD1,CHEAD2,I,CMD
;
Q:$G(TYPE)="" ""
Q:$G(LROOT)="" ""
Q:$G(AROOT)="" ""
;
S STITLE=$G(STITLE)
S OPTIONAL=+$G(OPTIONAL)
S:$G(PGLEN)="" PGLEN=10
S:$G(TIMEOUT)="" TIMEOUT=$G(DTIME)
;
D INIT
LP1 D DPAGE
S ANS=$$PROMPT()
I ANS="?" D DHELP G LP1
Q:(TYPE="M")&('OPTIONAL)&(ANS="^")&($D(@($E(AROOT,1,$L(AROOT)-1)_")"))'=0) ANS
Q:OPTIONAL&(ANS="^") ANS
Q:ANS="^^" ANS
Q:ANS="TIMEOUT" -1
I ANS="" D NEXTPG G LP1
I $E(ANS,1)="P" D JUMPPG G LP1
;
I TYPE="S"&(+ANS<1!(+ANS>END)) G LP1
I TYPE="S"&(+ANS>0&(+ANS'>END)) S @(AROOT_(+ANS)_")")="" Q ANS
I TYPE="M" F I=1:1:$L(ANS,",") D
.S CMD=$P(ANS,",",I)
.I CMD?1N.N D MARK(CMD) Q
.I CMD?1"-".N D UNMARK($P(CMD,"-",2)) Q
.I CMD?1N.N1"-"1N.N D RMARK(CMD) Q
.I CMD?1"-"1N.N1"-"1N.N D RUNMARK(CMD) Q
G LP1
;----------------------------------------------------------------------
W @IOF,!
D:STITLE'="" WCENTER^BPSOSU9(STITLE,IOM)
D:STITLE'="" WCENTER^BPSOSU9($TR($J("",$L(STITLE))," ","-"),IOM)
;
;DISPLAY PROMPT LINEs
S LINE=0
F D Q:LINE=""
.S LINE=$O(PROMPT(LINE))
.Q:LINE=""
.W:LINE=1 !!
.W PROMPT(LINE),!
;
W:$G(CHEAD1)'="" !,?9,CHEAD1,!
W:$G(CHEAD2)'="" ?9,CHEAD2
Q
;----------------------------------------------------------------------
INIT N CNSPACES,CNAMES,CDEF,INDEX,COLUMNS
S NLINES=+$G(@(LROOT_"0)")) I 'NLINES D Q
. D IMPOSS^BPSOSUE("P","TI","0 lines indicated in "_LROOT,,"INIT",$T(+0))
S NPAGES=((NLINES-1)\PGLEN)+1
S CPAGE=1
S COLUMNS=$G(@(LROOT_"""Column HEADERs"""_")"))
D:COLUMNS'=""
.S (CHEAD1,CHEAD2)=""
.S CNSPACES=$P(COLUMNS,"|",1)
.S CNAMES=$P(COLUMNS,"|",2)
.F INDEX=1:1:$L(CNAMES,",") D
..S CDEF=$P(CNAMES,",",INDEX)
..S CHEAD1=CHEAD1_$S(INDEX=1:"",1:$J("",CNSPACES))_$$LJBF^BPSOSU9($P(CDEF,":",1),$P(CDEF,":",2))
..S CHEAD2=CHEAD2_$S(INDEX=1:"",1:$J("",CNSPACES))_$TR($J("",$P(CDEF,":",2))," ","-")
Q
;----------------------------------------------------------------------
MARK(X) ;
Q:X<1!(X>NLINES)
S @(AROOT_X_")")=""
Q
;----------------------------------------------------------------------
RMARK(X) ;
N START,END,INDEX
S START=$P(X,"-",1)
S END=$P(X,"-",2)
F INDEX=START:1:END D MARK(INDEX)
Q
;----------------------------------------------------------------------
UNMARK(X) ;
Q:X<1!(X>NLINES)
K @(AROOT_X_")")
Q
;----------------------------------------------------------------------
RUNMARK(X) ;
N START,END,INDEX
S START=$P(X,"-",2)
S END=$P(X,"-",3)
F INDEX=START:1:END D UNMARK(INDEX)
Q
;----------------------------------------------------------------------
DPAGE N LNUM
D HEADER
W !
S START=((CPAGE-1)*PGLEN)+1
S END=START+PGLEN-1
S:END>NLINES END=NLINES
F LNUM=START:1:END D
.W $S($D(@(AROOT_LNUM_")")):"*",1:" ")
.W $J(LNUM,5)," - "
.W $G(@(LROOT_LNUM_","_"""E"""_")")),!
Q
;----------------------------------------------------------------------
PROMPT() ;
W:TYPE="S" !,"[Page "_CPAGE_" of "_NPAGES_"] Commands: #, P#, <Enter>, ^, ^^ or ?",!
W:TYPE="M" !,"[Page "_CPAGE_" of "_NPAGES_"] Commands: #, -#, #-#, -#-#, P#, <Enter>, ^, ^^ or ?",!
W "Select Item #: "
R ANS:TIMEOUT
I '$T S ANS="TIMEOUT"
Q ANS
;----------------------------------------------------------------------
NEXTPG S CPAGE=CPAGE+1
S:CPAGE>NPAGES CPAGE=NPAGES
Q
;----------------------------------------------------------------------
JUMPPG N NUM
Q:$E(ANS,1)'="P"
S NUM=+$P(ANS,"P",2)
Q:NUM<1!(NUM>NPAGES)
S CPAGE=NUM
Q
;----------------------------------------------------------------------
DHELP ;
N X
W !!,"Enter one of the following commands:",!!
W ?10,"#",?20,"- Selects entry number # from the list",!
W:TYPE="M" ?10,"-#",?20,"- Deselects entry number # from the list",!
W:TYPE="M" ?10,"#-#",?20,"- Selects the range of entries # thru #",!
W:TYPE="M" ?10,"-#-#",?20,"- Deselects the range of entries # thru #",!
W:TYPE="M"!(TYPE="S"&(OPTIONAL)) ?10,"^",?20,"- Exit the list",!
W ?10,"P#",?20,"- Jumps to page number #",!
W ?10,"<Enter>",?20,"- DISPLAYs next page",!
W ?10,"^^",?20,"- Aborts and returns to menu",!
W ?10,"?",?20,"- DISPLAYs this help text",!!
D PRESSANY^BPSOSU5(0,TIMEOUT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSU4 5280 printed Sep 23, 2025@19:28:25 Page 2
BPSOSU4 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;03/07/08 10:38
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,7**;JUN 2004;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;----------------------------------------------------------------------
+5 ;Standard List PROMPT:
+6 ;
+7 ;Parameters:
+8 ; TYPE - S or M (single or multiple selection)
+9 ; LROOT - List global root (eg: "^LIST($J,")
+10 ; AROOT - Answer global root (eg: "^LISTANS($J,")
+11 ; STITLE - Screen Title
+12 ; .PROMPT - List PROMPT Array
+13 ; OPTIONAL - 1 or 0 (optional or required)
+14 ; PGLEN - Page length
+15 ; TIMEOUT - Number of seconds
+16 ;
+17 ;Returns:
+18 ; <null> - Unable to process list
+19 ; <Ans> - For TYPE="S", item selected
+20 ; <^> - Up-arrow entered
+21 ; <^^> - Two up-arrows entered
+22 ; <-1> - Timeout occurred
+23 ;
+24 ;----------------------------------------------------------------------
LIST(TYPE,LROOT,AROOT,STITLE,PROMPT,OPTIONAL,PGLEN,TIMEOUT) ;EP
+1 ;
+2 ;Manage local variables
+3 NEW CPAGE,NPAGES,START,END,ANS,NLINES,CHEAD1,CHEAD2,I,CMD
+4 ;
+5 if $GET(TYPE)=""
QUIT ""
+6 if $GET(LROOT)=""
QUIT ""
+7 if $GET(AROOT)=""
QUIT ""
+8 ;
+9 SET STITLE=$GET(STITLE)
+10 SET OPTIONAL=+$GET(OPTIONAL)
+11 if $GET(PGLEN)=""
SET PGLEN=10
+12 if $GET(TIMEOUT)=""
SET TIMEOUT=$GET(DTIME)
+13 ;
+14 DO INIT
LP1 DO DPAGE
+1 SET ANS=$$PROMPT()
+2 IF ANS="?"
DO DHELP
GOTO LP1
+3 if (TYPE="M")&('OPTIONAL)&(ANS="^")&($DATA(@($EXTRACT(AROOT,1,$LENGTH(AROOT)-1)_")"))'=0)
QUIT ANS
+4 if OPTIONAL&(ANS="^")
QUIT ANS
+5 if ANS="^^"
QUIT ANS
+6 if ANS="TIMEOUT"
QUIT -1
+7 IF ANS=""
DO NEXTPG
GOTO LP1
+8 IF $EXTRACT(ANS,1)="P"
DO JUMPPG
GOTO LP1
+9 ;
+10 IF TYPE="S"&(+ANS<1!(+ANS>END))
GOTO LP1
+11 IF TYPE="S"&(+ANS>0&(+ANS'>END))
SET @(AROOT_(+ANS)_")")=""
QUIT ANS
+12 IF TYPE="M"
FOR I=1:1:$LENGTH(ANS,",")
Begin DoDot:1
+13 SET CMD=$PIECE(ANS,",",I)
+14 IF CMD?1N.N
DO MARK(CMD)
QUIT
+15 IF CMD?1"-".N
DO UNMARK($PIECE(CMD,"-",2))
QUIT
+16 IF CMD?1N.N1"-"1N.N
DO RMARK(CMD)
QUIT
+17 IF CMD?1"-"1N.N1"-"1N.N
DO RUNMARK(CMD)
QUIT
End DoDot:1
+18 GOTO LP1
+19 ;----------------------------------------------------------------------
+1 WRITE @IOF,!
+2 if STITLE'=""
DO WCENTER^BPSOSU9(STITLE,IOM)
+3 if STITLE'=""
DO WCENTER^BPSOSU9($TRANSLATE($JUSTIFY("",$LENGTH(STITLE))," ","-"),IOM)
+4 ;
+5 ;DISPLAY PROMPT LINEs
+6 SET LINE=0
+7 FOR
Begin DoDot:1
+8 SET LINE=$ORDER(PROMPT(LINE))
+9 if LINE=""
QUIT
+10 if LINE=1
WRITE !!
+11 WRITE PROMPT(LINE),!
End DoDot:1
if LINE=""
QUIT
+12 ;
+13 if $GET(CHEAD1)'=""
WRITE !,?9,CHEAD1,!
+14 if $GET(CHEAD2)'=""
WRITE ?9,CHEAD2
+15 QUIT
+16 ;----------------------------------------------------------------------
INIT NEW CNSPACES,CNAMES,CDEF,INDEX,COLUMNS
+1 SET NLINES=+$GET(@(LROOT_"0)"))
IF 'NLINES
Begin DoDot:1
+2 DO IMPOSS^BPSOSUE("P","TI","0 lines indicated in "_LROOT,,"INIT",$TEXT(+0))
End DoDot:1
QUIT
+3 SET NPAGES=((NLINES-1)\PGLEN)+1
+4 SET CPAGE=1
+5 SET COLUMNS=$GET(@(LROOT_"""Column HEADERs"""_")"))
+6 if COLUMNS'=""
Begin DoDot:1
+7 SET (CHEAD1,CHEAD2)=""
+8 SET CNSPACES=$PIECE(COLUMNS,"|",1)
+9 SET CNAMES=$PIECE(COLUMNS,"|",2)
+10 FOR INDEX=1:1:$LENGTH(CNAMES,",")
Begin DoDot:2
+11 SET CDEF=$PIECE(CNAMES,",",INDEX)
+12 SET CHEAD1=CHEAD1_$SELECT(INDEX=1:"",1:$JUSTIFY("",CNSPACES))_$$LJBF^BPSOSU9($PIECE(CDEF,":",1),$PIECE(CDEF,":",2))
+13 SET CHEAD2=CHEAD2_$SELECT(INDEX=1:"",1:$JUSTIFY("",CNSPACES))_$TRANSLATE($JUSTIFY("",$PIECE(CDEF,":",2))," ","-")
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;----------------------------------------------------------------------
MARK(X) ;
+1 if X<1!(X>NLINES)
QUIT
+2 SET @(AROOT_X_")")=""
+3 QUIT
+4 ;----------------------------------------------------------------------
RMARK(X) ;
+1 NEW START,END,INDEX
+2 SET START=$PIECE(X,"-",1)
+3 SET END=$PIECE(X,"-",2)
+4 FOR INDEX=START:1:END
DO MARK(INDEX)
+5 QUIT
+6 ;----------------------------------------------------------------------
UNMARK(X) ;
+1 if X<1!(X>NLINES)
QUIT
+2 KILL @(AROOT_X_")")
+3 QUIT
+4 ;----------------------------------------------------------------------
RUNMARK(X) ;
+1 NEW START,END,INDEX
+2 SET START=$PIECE(X,"-",2)
+3 SET END=$PIECE(X,"-",3)
+4 FOR INDEX=START:1:END
DO UNMARK(INDEX)
+5 QUIT
+6 ;----------------------------------------------------------------------
DPAGE NEW LNUM
+1 DO HEADER
+2 WRITE !
+3 SET START=((CPAGE-1)*PGLEN)+1
+4 SET END=START+PGLEN-1
+5 if END>NLINES
SET END=NLINES
+6 FOR LNUM=START:1:END
Begin DoDot:1
+7 WRITE $SELECT($DATA(@(AROOT_LNUM_")")):"*",1:" ")
+8 WRITE $JUSTIFY(LNUM,5)," - "
+9 WRITE $GET(@(LROOT_LNUM_","_"""E"""_")")),!
End DoDot:1
+10 QUIT
+11 ;----------------------------------------------------------------------
PROMPT() ;
+1 if TYPE="S"
WRITE !,"[Page "_CPAGE_" of "_NPAGES_"] Commands: #, P#, <Enter>, ^, ^^ or ?",!
+2 if TYPE="M"
WRITE !,"[Page "_CPAGE_" of "_NPAGES_"] Commands: #, -#, #-#, -#-#, P#, <Enter>, ^, ^^ or ?",!
+3 WRITE "Select Item #: "
+4 READ ANS:TIMEOUT
+5 IF '$TEST
SET ANS="TIMEOUT"
+6 QUIT ANS
+7 ;----------------------------------------------------------------------
NEXTPG SET CPAGE=CPAGE+1
+1 if CPAGE>NPAGES
SET CPAGE=NPAGES
+2 QUIT
+3 ;----------------------------------------------------------------------
JUMPPG NEW NUM
+1 if $EXTRACT(ANS,1)'="P"
QUIT
+2 SET NUM=+$PIECE(ANS,"P",2)
+3 if NUM<1!(NUM>NPAGES)
QUIT
+4 SET CPAGE=NUM
+5 QUIT
+6 ;----------------------------------------------------------------------
DHELP ;
+1 NEW X
+2 WRITE !!,"Enter one of the following commands:",!!
+3 WRITE ?10,"#",?20,"- Selects entry number # from the list",!
+4 if TYPE="M"
WRITE ?10,"-#",?20,"- Deselects entry number # from the list",!
+5 if TYPE="M"
WRITE ?10,"#-#",?20,"- Selects the range of entries # thru #",!
+6 if TYPE="M"
WRITE ?10,"-#-#",?20,"- Deselects the range of entries # thru #",!
+7 if TYPE="M"!(TYPE="S"&(OPTIONAL))
WRITE ?10,"^",?20,"- Exit the list",!
+8 WRITE ?10,"P#",?20,"- Jumps to page number #",!
+9 WRITE ?10,"<Enter>",?20,"- DISPLAYs next page",!
+10 WRITE ?10,"^^",?20,"- Aborts and returns to menu",!
+11 WRITE ?10,"?",?20,"- DISPLAYs this help text",!!
+12 DO PRESSANY^BPSOSU5(0,TIMEOUT)
+13 QUIT
