DDGLBXA1 ;SFISC/MKO-SINGLE SELECTION LIST BOX ;11:33 AM 26 Apr 1996
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
N DDGLQT,Y
D CUP(DDGLLINE,1)
;
S DDGLQT=0
F S Y=$$READ D Q:DDGLQT
. I Y'[U,$T(@Y)="" W $C(7) Q
. D @Y
. D:$G(DDGLKEY("KMAP","KD"))]"" @DDGLKEY("KMAP","KD")
;
S:$P(DDGLQT,U,2,999)]"" DDGLOUT("C")=$P(DDGLQT,U,2,999)
Q
;
UP ;Move up
I DDGLLINE>1 D
. D CUP(DDGLLINE,1)
. W $E(DDGLSEL,1,DDGLNC)
. S DDGLLINE=DDGLLINE-1
. S DDGLSEL=DDGLITEM(DDGLLINE)
. ;
. D CUP(DDGLLINE,1)
. W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10)
;
E D
. N DDGLE
. D SHIFTDN(1,.DDGLE) Q:$G(DDGLE)
. S DDGLSEL=DDGLITEM(1)
. D DISP(DDGLSEL)
Q
;
DN ;Move down
I DDGLLINE<DDGLNL D
. Q:DDGLITEM(DDGLLINE+1)=""
. D CUP(DDGLLINE,1)
. W $E(DDGLSEL,1,DDGLNC)
. S DDGLLINE=DDGLLINE+1
. S DDGLSEL=DDGLITEM(DDGLLINE)
. ;
. D CUP(DDGLLINE,1)
. W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10)
;
E D
. N DDGLE
. D SHIFTUP(1,.DDGLE) Q:$G(DDGLE)
. S DDGLSEL=DDGLITEM(DDGLNL)
. D DISP(DDGLSEL)
Q
;
PUP ;Page up in list
I DDGLLINE>1 D
. D CUP(DDGLLINE,1)
. W $E(DDGLSEL,1,DDGLNC)
. S DDGLLINE=1,DDGLSEL=DDGLITEM(1)
. D CUP(1,1)
. W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10)
;
E D
. N DDGLE
. D SHIFTDN(DDGLNL,.DDGLE) Q:$G(DDGLE)
. S DDGLSEL=DDGLITEM(1)
. D DISP(DDGLSEL)
Q
;
PDN ;Page down in list
I DDGLLINE<DDGLNL D
. D CUP(DDGLLINE,1)
. W $E(DDGLSEL,1,DDGLNC)
. F DDGLLINE=DDGLNL:-1:1 Q:DDGLITEM(DDGLLINE)]""
. S DDGLSEL=DDGLITEM(DDGLLINE)
. D CUP(DDGLLINE,1)
. W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10)
;
E D
. N DDGLE
. D SHIFTUP(DDGLNL,.DDGLE) Q:$G(DDGLE)
. S DDGLSEL=DDGLITEM(DDGLNL)
. D DISP(DDGLSEL)
Q
;
TOP ;Move to top of list
N DDGLFRST,DDGLI,DDGLT
;
;Check whether first item in list is the first displayed
S DDGLFRST=$O(@DDGLGLO@(""))
I DDGLFRST=DDGLITEM(1) D:DDGLLINE>1 PUP Q
;
;Fill DDGLITEM array
S DDGLT=DDGLFRST
F DDGLI=1:1:DDGLNL D
. S DDGLITEM(DDGLI)=DDGLT
. S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT))
;
S DDGLLINE=1,DDGLSEL=DDGLITEM(1)
D DISP(DDGLSEL)
Q
;
BOT ;Move to bottom of list
N DDGLAST,DDGLI,DDGLT,DDGLIND
;
;Set DDGLIND = index of last non-null DDGLITEM
F DDGLIND=DDGLNL:-1:1 Q:DDGLITEM(DDGLIND)]""
;
S DDGLAST=$O(@DDGLGLO@(""),-1)
I DDGLAST=DDGLITEM(DDGLIND) D:DDGLLINE<DDGLIND PDN Q
;
;Fill DDGLITEM array
S DDGLT=DDGLAST
F DDGLI=DDGLNL:-1:1 D
. S DDGLITEM(DDGLI)=DDGLT
. S DDGLT=$O(@DDGLGLO@(DDGLT),-1)
;
S DDGLLINE=DDGLNL,DDGLSEL=DDGLITEM(DDGLNL)
D DISP(DDGLSEL)
Q
;
SEL ;Select item
K DDGLOUT
S DDGLOUT=$O(@DDGLGLO@(DDGLSEL,"")),DDGLOUT(0)=DDGLSEL
S DDGLOUT("C")="SEL"
S DDGLQT=1
Q
;
QT ;Quit
K DDGLOUT
S DDGLOUT=-1,DDGLOUT(0)="",DDGLOUT("C")="QT"
S DDGLQT=1
Q
;
TO ;Timeout
D:$G(DDGLKEY("KMAP","TO"))]"" @DDGLKEY("KMAP","TO")
K DDGLOUT
S DDGLOUT=-1,DDGLOUT(0)="",DDGLOUT("C")="TO"
S DDGLQT=1
Q
;
READ() ;Read next key and return mnemonic
N S,Y
F R *Y:DTIME D C Q:Y'=-1
Q Y
;
C I Y<0 S Y="TO" Q
S S=""
C1 S S=S_$C(Y)
I DDGLKEY("KMAP","IN")'[(U_S) D I Y=-1 W $C(7) D FLUSH Q
. I $C(Y)'?1L S Y=-1 Q
. S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGLKEY("KMAP","IN")'[(U_S_U) Y=-1
;
I DDGLKEY("KMAP","IN")[(U_S_U),S'=$C(27) S Y=$P(DDGLKEY("KMAP","OUT"),";",$L($P(DDGLKEY("KMAP","IN"),U_S_U),U)) Q
R *Y:5 G:Y'=-1 C1
W $C(7)
Q
;
SHIFTDN(DDGLN,DDGLE) ;Shift DDGLITEM array down DDGLN times
;Out: DDGLE = 1, if no more items above
;
N DDGLI,DDGLT,DDGLA
S DDGLE=0
S DDGLT=DDGLITEM(1) I DDGLT="" S DDGLE=1 Q
;
F DDGLI=-1:-1:-DDGLN S DDGLT=$O(@DDGLGLO@(DDGLT),-1) Q:DDGLT="" D
. S DDGLA(DDGLI)=DDGLT
S:DDGLT="" DDGLI=DDGLI+1
I DDGLI=0 S DDGLE=1 Q
S DDGLN=-DDGLI
;
F DDGLI=DDGLNL:-1:DDGLN+1 S DDGLITEM(DDGLI)=DDGLITEM(DDGLI-DDGLN)
F DDGLI=DDGLN:-1:1 S DDGLITEM(DDGLI)=DDGLA(DDGLI-DDGLN-1)
Q
;
SHIFTUP(DDGLN,DDGLE) ;Shift DDGLITEM array down DDGLN times
;Out: DDGLE = 1, if no more items above
;
N DDGLI,DDGLT,DDGLA
S DDGLE=0
S DDGLT=DDGLITEM(DDGLNL) I DDGLT="" S DDGLE=1 Q
;
F DDGLI=1:1:DDGLN S DDGLT=$O(@DDGLGLO@(DDGLT)) Q:DDGLT="" D
. S DDGLA(DDGLI)=DDGLT
S:DDGLT="" DDGLI=DDGLI-1
I DDGLI=0 S DDGLE=1 Q
S DDGLN=DDGLI
;
F DDGLI=1:1:DDGLNL-DDGLN S DDGLITEM(DDGLI)=DDGLITEM(DDGLI+DDGLN)
F DDGLI=DDGLNL-DDGLN+1:1:DDGLNL S DDGLITEM(DDGLI)=DDGLA(DDGLI-DDGLNL+DDGLN)
Q
;
DISP(DDGLSEL) ;Display the list
;In: DDGLSEL = text of selected item
;
N DDGLI,DDGLT
F DDGLI=1:1:DDGLNL D
. D CUP(DDGLI,1)
. S DDGLT=$E(DDGLITEM(DDGLI),1,DDGLNC)
. S DDGLT=$S(DDGLT=DDGLSEL:$P(DDGLVID,DDGLDEL,6)_DDGLT_$P(DDGLVID,DDGLDEL,10),1:DDGLT)_$J("",DDGLNC-$L(DDGLT))
. W DDGLT
Q
;
FLUSH ;Flush read buffer
N DDGLX
F R *DDGLX:0 E Q
Q
;
CUP(Y,X) ;Position cursor relative to list coords
S DY=DDGLROW+Y,DX=DDGLCOL+X+1 X IOXY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGLBXA1 5231 printed Jan 18, 2025@03:43:32 Page 2
DDGLBXA1 ;SFISC/MKO-SINGLE SELECTION LIST BOX ;11:33 AM 26 Apr 1996
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 NEW DDGLQT,Y
+8 DO CUP(DDGLLINE,1)
+9 ;
+10 SET DDGLQT=0
+11 FOR
SET Y=$$READ
Begin DoDot:1
+12 IF Y'[U
IF $TEXT(@Y)=""
WRITE $CHAR(7)
QUIT
+13 DO @Y
+14 if $GET(DDGLKEY("KMAP","KD"))]""
DO @DDGLKEY("KMAP","KD")
End DoDot:1
if DDGLQT
QUIT
+15 ;
+16 if $PIECE(DDGLQT,U,2,999)]""
SET DDGLOUT("C")=$PIECE(DDGLQT,U,2,999)
+17 QUIT
+18 ;
UP ;Move up
+1 IF DDGLLINE>1
Begin DoDot:1
+2 DO CUP(DDGLLINE,1)
+3 WRITE $EXTRACT(DDGLSEL,1,DDGLNC)
+4 SET DDGLLINE=DDGLLINE-1
+5 SET DDGLSEL=DDGLITEM(DDGLLINE)
+6 ;
+7 DO CUP(DDGLLINE,1)
+8 WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(DDGLSEL,1,DDGLNC)_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+9 ;
+10 IF '$TEST
Begin DoDot:1
+11 NEW DDGLE
+12 DO SHIFTDN(1,.DDGLE)
if $GET(DDGLE)
QUIT
+13 SET DDGLSEL=DDGLITEM(1)
+14 DO DISP(DDGLSEL)
End DoDot:1
+15 QUIT
+16 ;
DN ;Move down
+1 IF DDGLLINE<DDGLNL
Begin DoDot:1
+2 if DDGLITEM(DDGLLINE+1)=""
QUIT
+3 DO CUP(DDGLLINE,1)
+4 WRITE $EXTRACT(DDGLSEL,1,DDGLNC)
+5 SET DDGLLINE=DDGLLINE+1
+6 SET DDGLSEL=DDGLITEM(DDGLLINE)
+7 ;
+8 DO CUP(DDGLLINE,1)
+9 WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(DDGLSEL,1,DDGLNC)_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+10 ;
+11 IF '$TEST
Begin DoDot:1
+12 NEW DDGLE
+13 DO SHIFTUP(1,.DDGLE)
if $GET(DDGLE)
QUIT
+14 SET DDGLSEL=DDGLITEM(DDGLNL)
+15 DO DISP(DDGLSEL)
End DoDot:1
+16 QUIT
+17 ;
PUP ;Page up in list
+1 IF DDGLLINE>1
Begin DoDot:1
+2 DO CUP(DDGLLINE,1)
+3 WRITE $EXTRACT(DDGLSEL,1,DDGLNC)
+4 SET DDGLLINE=1
SET DDGLSEL=DDGLITEM(1)
+5 DO CUP(1,1)
+6 WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(DDGLSEL,1,DDGLNC)_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+7 ;
+8 IF '$TEST
Begin DoDot:1
+9 NEW DDGLE
+10 DO SHIFTDN(DDGLNL,.DDGLE)
if $GET(DDGLE)
QUIT
+11 SET DDGLSEL=DDGLITEM(1)
+12 DO DISP(DDGLSEL)
End DoDot:1
+13 QUIT
+14 ;
PDN ;Page down in list
+1 IF DDGLLINE<DDGLNL
Begin DoDot:1
+2 DO CUP(DDGLLINE,1)
+3 WRITE $EXTRACT(DDGLSEL,1,DDGLNC)
+4 FOR DDGLLINE=DDGLNL:-1:1
if DDGLITEM(DDGLLINE)]""
QUIT
+5 SET DDGLSEL=DDGLITEM(DDGLLINE)
+6 DO CUP(DDGLLINE,1)
+7 WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(DDGLSEL,1,DDGLNC)_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+8 ;
+9 IF '$TEST
Begin DoDot:1
+10 NEW DDGLE
+11 DO SHIFTUP(DDGLNL,.DDGLE)
if $GET(DDGLE)
QUIT
+12 SET DDGLSEL=DDGLITEM(DDGLNL)
+13 DO DISP(DDGLSEL)
End DoDot:1
+14 QUIT
+15 ;
TOP ;Move to top of list
+1 NEW DDGLFRST,DDGLI,DDGLT
+2 ;
+3 ;Check whether first item in list is the first displayed
+4 SET DDGLFRST=$ORDER(@DDGLGLO@(""))
+5 IF DDGLFRST=DDGLITEM(1)
if DDGLLINE>1
DO PUP
QUIT
+6 ;
+7 ;Fill DDGLITEM array
+8 SET DDGLT=DDGLFRST
+9 FOR DDGLI=1:1:DDGLNL
Begin DoDot:1
+10 SET DDGLITEM(DDGLI)=DDGLT
+11 if DDGLT]""
SET DDGLT=$ORDER(@DDGLGLO@(DDGLT))
End DoDot:1
+12 ;
+13 SET DDGLLINE=1
SET DDGLSEL=DDGLITEM(1)
+14 DO DISP(DDGLSEL)
+15 QUIT
+16 ;
BOT ;Move to bottom of list
+1 NEW DDGLAST,DDGLI,DDGLT,DDGLIND
+2 ;
+3 ;Set DDGLIND = index of last non-null DDGLITEM
+4 FOR DDGLIND=DDGLNL:-1:1
if DDGLITEM(DDGLIND)]""
QUIT
+5 ;
+6 SET DDGLAST=$ORDER(@DDGLGLO@(""),-1)
+7 IF DDGLAST=DDGLITEM(DDGLIND)
if DDGLLINE<DDGLIND
DO PDN
QUIT
+8 ;
+9 ;Fill DDGLITEM array
+10 SET DDGLT=DDGLAST
+11 FOR DDGLI=DDGLNL:-1:1
Begin DoDot:1
+12 SET DDGLITEM(DDGLI)=DDGLT
+13 SET DDGLT=$ORDER(@DDGLGLO@(DDGLT),-1)
End DoDot:1
+14 ;
+15 SET DDGLLINE=DDGLNL
SET DDGLSEL=DDGLITEM(DDGLNL)
+16 DO DISP(DDGLSEL)
+17 QUIT
+18 ;
SEL ;Select item
+1 KILL DDGLOUT
+2 SET DDGLOUT=$ORDER(@DDGLGLO@(DDGLSEL,""))
SET DDGLOUT(0)=DDGLSEL
+3 SET DDGLOUT("C")="SEL"
+4 SET DDGLQT=1
+5 QUIT
+6 ;
QT ;Quit
+1 KILL DDGLOUT
+2 SET DDGLOUT=-1
SET DDGLOUT(0)=""
SET DDGLOUT("C")="QT"
+3 SET DDGLQT=1
+4 QUIT
+5 ;
TO ;Timeout
+1 if $GET(DDGLKEY("KMAP","TO"))]""
DO @DDGLKEY("KMAP","TO")
+2 KILL DDGLOUT
+3 SET DDGLOUT=-1
SET DDGLOUT(0)=""
SET DDGLOUT("C")="TO"
+4 SET DDGLQT=1
+5 QUIT
+6 ;
READ() ;Read next key and return mnemonic
+1 NEW S,Y
+2 FOR
READ *Y:DTIME
DO C
if Y'=-1
QUIT
+3 QUIT Y
+4 ;
C IF Y<0
SET Y="TO"
QUIT
+1 SET S=""
C1 SET S=S_$CHAR(Y)
+1 IF DDGLKEY("KMAP","IN")'[(U_S)
Begin DoDot:1
+2 IF $CHAR(Y)'?1L
SET Y=-1
QUIT
+3 SET S=$EXTRACT(S,1,$LENGTH(S)-1)_$CHAR(Y-32)
if DDGLKEY("KMAP","IN")'[(U_S_U)
SET Y=-1
End DoDot:1
IF Y=-1
WRITE $CHAR(7)
DO FLUSH
QUIT
+4 ;
+5 IF DDGLKEY("KMAP","IN")[(U_S_U)
IF S'=$CHAR(27)
SET Y=$PIECE(DDGLKEY("KMAP","OUT"),";",$LENGTH($PIECE(DDGLKEY("KMAP","IN"),U_S_U),U))
QUIT
+6 READ *Y:5
if Y'=-1
GOTO C1
+7 WRITE $CHAR(7)
+8 QUIT
+9 ;
SHIFTDN(DDGLN,DDGLE) ;Shift DDGLITEM array down DDGLN times
+1 ;Out: DDGLE = 1, if no more items above
+2 ;
+3 NEW DDGLI,DDGLT,DDGLA
+4 SET DDGLE=0
+5 SET DDGLT=DDGLITEM(1)
IF DDGLT=""
SET DDGLE=1
QUIT
+6 ;
+7 FOR DDGLI=-1:-1:-DDGLN
SET DDGLT=$ORDER(@DDGLGLO@(DDGLT),-1)
if DDGLT=""
QUIT
Begin DoDot:1
+8 SET DDGLA(DDGLI)=DDGLT
End DoDot:1
+9 if DDGLT=""
SET DDGLI=DDGLI+1
+10 IF DDGLI=0
SET DDGLE=1
QUIT
+11 SET DDGLN=-DDGLI
+12 ;
+13 FOR DDGLI=DDGLNL:-1:DDGLN+1
SET DDGLITEM(DDGLI)=DDGLITEM(DDGLI-DDGLN)
+14 FOR DDGLI=DDGLN:-1:1
SET DDGLITEM(DDGLI)=DDGLA(DDGLI-DDGLN-1)
+15 QUIT
+16 ;
SHIFTUP(DDGLN,DDGLE) ;Shift DDGLITEM array down DDGLN times
+1 ;Out: DDGLE = 1, if no more items above
+2 ;
+3 NEW DDGLI,DDGLT,DDGLA
+4 SET DDGLE=0
+5 SET DDGLT=DDGLITEM(DDGLNL)
IF DDGLT=""
SET DDGLE=1
QUIT
+6 ;
+7 FOR DDGLI=1:1:DDGLN
SET DDGLT=$ORDER(@DDGLGLO@(DDGLT))
if DDGLT=""
QUIT
Begin DoDot:1
+8 SET DDGLA(DDGLI)=DDGLT
End DoDot:1
+9 if DDGLT=""
SET DDGLI=DDGLI-1
+10 IF DDGLI=0
SET DDGLE=1
QUIT
+11 SET DDGLN=DDGLI
+12 ;
+13 FOR DDGLI=1:1:DDGLNL-DDGLN
SET DDGLITEM(DDGLI)=DDGLITEM(DDGLI+DDGLN)
+14 FOR DDGLI=DDGLNL-DDGLN+1:1:DDGLNL
SET DDGLITEM(DDGLI)=DDGLA(DDGLI-DDGLNL+DDGLN)
+15 QUIT
+16 ;
DISP(DDGLSEL) ;Display the list
+1 ;In: DDGLSEL = text of selected item
+2 ;
+3 NEW DDGLI,DDGLT
+4 FOR DDGLI=1:1:DDGLNL
Begin DoDot:1
+5 DO CUP(DDGLI,1)
+6 SET DDGLT=$EXTRACT(DDGLITEM(DDGLI),1,DDGLNC)
+7 SET DDGLT=$SELECT(DDGLT=DDGLSEL:$PIECE(DDGLVID,DDGLDEL,6)_DDGLT_$PIECE(DDGLVID,DDGLDEL,10),1:DDGLT)_$JUSTIFY("",DDGLNC-$LENGTH(DDGLT))
+8 WRITE DDGLT
End DoDot:1
+9 QUIT
+10 ;
FLUSH ;Flush read buffer
+1 NEW DDGLX
+2 FOR
READ *DDGLX:0
IF '$TEST
QUIT
+3 QUIT
+4 ;
CUP(Y,X) ;Position cursor relative to list coords
+1 SET DY=DDGLROW+Y
SET DX=DDGLCOL+X+1
XECUTE IOXY
+2 QUIT
