- 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 Feb 19, 2025@00:08:49 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