- DDBR0 ;SFISC/DCL-VA FILEMAN BROWSER FUNCTIONS ;04:01 PM 26 Aug 2002
- ;;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.
- ;
- Q
- PU N I,J,K S I=DDBL-DDBSRL,J=I-(DDBSRL-1),K=DDBL
- S DX=$P(DDBSX,";"),DY=$P(DDBSY,";",2)
- I DDBZN D D:K'=DDBL RLPI Q
- .F I=I:-1:J Q:'$D(@DDBSA@(I,0)) D
- ..X IOXY
- ..W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I)
- ..S DDBL=DDBL-1
- F I=I:-1:J Q:I'>0!('$D(@DDBSA@(I))) D
- .X IOXY
- .W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I)
- .S DDBL=DDBL-1
- D:K'=DDBL RLPI
- Q
- PD N I,J,K S I=DDBL+1,J=DDBL+DDBSRL,K=DDBL
- S DX=0,DY=$P(DDBSY,";",3)
- X IOXY
- I DDBZN D D:K'=DDBL RLPI Q
- .F I=I:1:J Q:'$D(@DDBSA@(I,0)) W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) S DDBL=DDBL+1
- .Q
- F I=I:1:J Q:'$D(@DDBSA@(I)) W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) S DDBL=DDBL+1
- D:K'=DDBL RLPI
- Q
- LU N I S I=DDBL-DDBSRL
- S DX=0,DY=$P(DDBSY,";",2)
- X IOXY
- I DDBZN Q:'$D(@DDBSA@(I,0)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) D RLPIR Q
- I I>0,$D(@DDBSA@(I)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) D RLPIR Q
- Q
- LD S DX=0,DY=$P(DDBSY,";",3)
- X IOXY
- I DDBZN,$D(@DDBSA@(DDBL+1,0)) D Q
- .S DDBL=DDBL+1
- .W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL,0),DDBL)
- .D RLPIR
- .Q
- I 'DDBZN,$D(@DDBSA@(DDBL+1)) D Q
- .S DDBL=DDBL+1
- .W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL),DDBL)
- .D RLPIR
- .Q
- Q
- COL(N) N X
- S X=$O(@DDBC@(DDBSF),N) Q:X'>0
- S DDBSF=X
- COLENT S DDBST=DDBSF+(IOM-1),DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
- D SDLR(DDBL+1),COLR
- I DDBHDRC D ENCHDR^DDBR4
- Q
- COLJ N X
- COLA S X(2)="Col> " W $$WS^DDBR1(.X) D G:X=""!(X=U) OUT
- .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X)
- .K DIR0
- .Q
- I $E(X)="?" G COLERR
- I X<1!(X>255) W $C(7) G COLERR
- S DDBSF=X G COLENT
- Q
- COLERR S X(1)=" * [ "_$$EZBLD^DIALOG(836)_" ] *" ;**'Enter a number between 1 and 255'
- G COLA
- OUT D PSR^DDBR0()
- Q
- RLE Q:$G(DDBRHTF) S DDBSF=1 G COLENT
- RRE Q:$G(DDBRHTF) S DDBSF=$O(@DDBC@(""),-1) G COLENT
- ;
- ONLINE Q
- RR I DDBRHTF D JUMP^DDBRAHTJ(1) Q
- D COL(1)
- Q
- RL I DDBRHTF D JUMP^DDBRAHTJ(-1) Q
- D COL(-1)
- Q
- TOP S DDBL=0 D SDLR(1),RLPIR
- Q
- BOT I DDBTL>DDBSRL S DDBL=DDBTL-DDBSRL D SDLR(DDBL+1),RLPIR
- Q
- EXIT S DDBRE="^"
- Q
- TO S DDBTO=DDBTO+1,DDBE=-1 S:DDBTO'<($G(DTIME,300)\5) DDBE="^"
- Q
- RCLSI D RLPIR,COLR
- Q
- PSR(PSR) S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
- D:$G(PSR) HFR D SDLR(DDBL+1),RLPIR,COLR
- Q
- SDL ;
- SDLR(L) N I,J,SFR,STO
- S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L
- S DY=SFR X IOXY
- I DDBZN F I=SFR:1:STO D
- .W:I'=SFR !
- .W $P(DDGLCLR,DDGLDEL)
- .I J=L,$D(@DDBSA@(L)) W $$HTD(@DDBSA@(L,0),L) S DDBL=DDBL+1,L=L+1
- .S J=J+1
- .Q
- I 'DDBZN F I=SFR:1:STO D
- .W:I'=SFR !
- .W $P(DDGLCLR,DDGLDEL)
- .I J=L,$D(@DDBSA@(L)) W $$HTD(@DDBSA@(L),L) S DDBL=DDBL+1,L=L+1
- .S J=J+1
- .Q
- Q
- HFR N FTR S FTR=1
- HDR S DX=0
- S DY=$P(DDBSY,";")
- X IOXY
- W $P(DDGLVID,DDGLDEL,6)
- W DDBHDR
- W $P(DDGLVID,DDGLDEL,10)
- G:$G(FTR) FTR
- Q
- FTR I DDBFLGS Q
- W $P(DDGLVID,DDGLDEL,6)
- I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4)
- S DY=$P(DDBSY,";",4)
- X IOXY
- W DDBFTR
- S DX=$P(DDBSX,";",3)
- X IOXY
- W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)," of ",DDBTL
- S DX=$P(DDBSX,";",4)
- X IOXY
- W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)," of ",DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
- S DX=$P(DDBSX,";",2)
- X IOXY
- W:'DDBRHTF $J(DDBSF,4)
- I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10)
- W $P(DDGLVID,DDGLDEL,10)
- Q
- RLPI ;
- RLPIR I DDBFLGS Q
- S DX=$P(DDBSX,";",3),DY=$P(DDBSY,";",4)
- I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4)
- W $P(DDGLVID,DDGLDEL,6)
- X IOXY
- W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)
- S DX=$P(DDBSX,";",4)
- X IOXY
- W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)
- I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10)
- W $P(DDGLVID,DDGLDEL,10)
- Q
- COLR I DDBFLGS!(DDBRHTF) Q
- S DX=$P(DDBSX,";",2),DY=$P(DDBSY,";",4)
- X IOXY
- I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4)
- W $P(DDGLVID,DDGLDEL,6)
- W $J(DDBSF,4)
- I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10)
- W $P(DDGLVID,DDGLDEL,10)
- Q
- ;
- HTD(X,WPIEN) ;
- Q:'DDBRHTF $E(X,DDBSF,DDBST)
- Q:$L(X,"$.")'>2 X
- S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","")
- S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3))
- Q X
- ;
- HT(Y,D,C1,C2) ;
- Q:$L(Y,D)'>2 Y
- N YL,I,Y1
- S YL=$L(Y,D),Y1=""
- F I=1:1:YL D
- .S:I#2 Y1=Y1_$P(Y,D,I)
- .I '(I#2),+$G(DDBRHT)=WPIEN,$P(DDBRHT,DDGLDEL,4)=DDBSA,$P(DDBRHT,DDGLDEL,2)=$P(Y,D,I) D Q
- ..S Y1=Y1_C1_$P(DDGLVID,DDGLDEL,4)_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_$P(DDGLVID,DDGLDEL,5)_C2
- ..Q
- .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2
- .Q
- Q Y1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBR0 4917 printed Jan 18, 2025@03:42:41 Page 2
- DDBR0 ;SFISC/DCL-VA FILEMAN BROWSER FUNCTIONS ;04:01 PM 26 Aug 2002
- +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 QUIT
- PU NEW I,J,K
- SET I=DDBL-DDBSRL
- SET J=I-(DDBSRL-1)
- SET K=DDBL
- +1 SET DX=$PIECE(DDBSX,";")
- SET DY=$PIECE(DDBSY,";",2)
- +2 IF DDBZN
- Begin DoDot:1
- +3 FOR I=I:-1:J
- if '$DATA(@DDBSA@(I,0))
- QUIT
- Begin DoDot:2
- +4 XECUTE IOXY
- +5 WRITE IORI,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I)
- +6 SET DDBL=DDBL-1
- End DoDot:2
- End DoDot:1
- if K'=DDBL
- DO RLPI
- QUIT
- +7 FOR I=I:-1:J
- if I'>0!('$DATA(@DDBSA@(I)))
- QUIT
- Begin DoDot:1
- +8 XECUTE IOXY
- +9 WRITE IORI,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I)
- +10 SET DDBL=DDBL-1
- End DoDot:1
- +11 if K'=DDBL
- DO RLPI
- +12 QUIT
- PD NEW I,J,K
- SET I=DDBL+1
- SET J=DDBL+DDBSRL
- SET K=DDBL
- +1 SET DX=0
- SET DY=$PIECE(DDBSY,";",3)
- +2 XECUTE IOXY
- +3 IF DDBZN
- Begin DoDot:1
- +4 FOR I=I:1:J
- if '$DATA(@DDBSA@(I,0))
- QUIT
- WRITE !,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I)
- SET DDBL=DDBL+1
- +5 QUIT
- End DoDot:1
- if K'=DDBL
- DO RLPI
- QUIT
- +6 FOR I=I:1:J
- if '$DATA(@DDBSA@(I))
- QUIT
- WRITE !,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I)
- SET DDBL=DDBL+1
- +7 if K'=DDBL
- DO RLPI
- +8 QUIT
- LU NEW I
- SET I=DDBL-DDBSRL
- +1 SET DX=0
- SET DY=$PIECE(DDBSY,";",2)
- +2 XECUTE IOXY
- +3 IF DDBZN
- if '$DATA(@DDBSA@(I,0))
- QUIT
- SET DDBL=DDBL-1
- WRITE IORI,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I)
- DO RLPIR
- QUIT
- +4 IF I>0
- IF $DATA(@DDBSA@(I))
- SET DDBL=DDBL-1
- WRITE IORI,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I)
- DO RLPIR
- QUIT
- +5 QUIT
- LD SET DX=0
- SET DY=$PIECE(DDBSY,";",3)
- +1 XECUTE IOXY
- +2 IF DDBZN
- IF $DATA(@DDBSA@(DDBL+1,0))
- Begin DoDot:1
- +3 SET DDBL=DDBL+1
- +4 WRITE !,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL,0),DDBL)
- +5 DO RLPIR
- +6 QUIT
- End DoDot:1
- QUIT
- +7 IF 'DDBZN
- IF $DATA(@DDBSA@(DDBL+1))
- Begin DoDot:1
- +8 SET DDBL=DDBL+1
- +9 WRITE !,$PIECE(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL),DDBL)
- +10 DO RLPIR
- +11 QUIT
- End DoDot:1
- QUIT
- +12 QUIT
- COL(N) NEW X
- +1 SET X=$ORDER(@DDBC@(DDBSF),N)
- if X'>0
- QUIT
- +2 SET DDBSF=X
- COLENT SET DDBST=DDBSF+(IOM-1)
- SET DDBL=$SELECT(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
- +1 DO SDLR(DDBL+1)
- DO COLR
- +2 IF DDBHDRC
- DO ENCHDR^DDBR4
- +3 QUIT
- COLJ NEW X
- COLA SET X(2)="Col> "
- WRITE $$WS^DDBR1(.X)
- Begin DoDot:1
- +1 DO EN^DIR0($PIECE(DDBSY,";",3)-1,$LENGTH($GET(X(2)))+2,30,1,"",100,1,"","KPW",.X)
- +2 KILL DIR0
- +3 QUIT
- End DoDot:1
- if X=""!(X=U)
- GOTO OUT
- +4 IF $EXTRACT(X)="?"
- GOTO COLERR
- +5 IF X<1!(X>255)
- WRITE $CHAR(7)
- GOTO COLERR
- +6 SET DDBSF=X
- GOTO COLENT
- +7 QUIT
- COLERR ;**'Enter a number between 1 and 255'
- SET X(1)=" * [ "_$$EZBLD^DIALOG(836)_" ] *"
- +1 GOTO COLA
- OUT DO PSR^DDBR0()
- +1 QUIT
- RLE if $GET(DDBRHTF)
- QUIT
- SET DDBSF=1
- GOTO COLENT
- RRE if $GET(DDBRHTF)
- QUIT
- SET DDBSF=$ORDER(@DDBC@(""),-1)
- GOTO COLENT
- +1 ;
- ONLINE QUIT
- RR IF DDBRHTF
- DO JUMP^DDBRAHTJ(1)
- QUIT
- +1 DO COL(1)
- +2 QUIT
- RL IF DDBRHTF
- DO JUMP^DDBRAHTJ(-1)
- QUIT
- +1 DO COL(-1)
- +2 QUIT
- TOP SET DDBL=0
- DO SDLR(1)
- DO RLPIR
- +1 QUIT
- BOT IF DDBTL>DDBSRL
- SET DDBL=DDBTL-DDBSRL
- DO SDLR(DDBL+1)
- DO RLPIR
- +1 QUIT
- EXIT SET DDBRE="^"
- +1 QUIT
- TO SET DDBTO=DDBTO+1
- SET DDBE=-1
- if DDBTO'<($GET(DTIME,300)\5)
- SET DDBE="^"
- +1 QUIT
- RCLSI DO RLPIR
- DO COLR
- +1 QUIT
- PSR(PSR) SET DDBL=$SELECT(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
- +1 if $GET(PSR)
- DO HFR
- DO SDLR(DDBL+1)
- DO RLPIR
- DO COLR
- +2 QUIT
- SDL ;
- SDLR(L) NEW I,J,SFR,STO
- +1 SET DX=0
- SET SFR=$PIECE(DDBSY,";",2)
- SET STO=$PIECE(DDBSY,";",3)
- SET J=L
- +2 SET DY=SFR
- XECUTE IOXY
- +3 IF DDBZN
- FOR I=SFR:1:STO
- Begin DoDot:1
- +4 if I'=SFR
- WRITE !
- +5 WRITE $PIECE(DDGLCLR,DDGLDEL)
- +6 IF J=L
- IF $DATA(@DDBSA@(L))
- WRITE $$HTD(@DDBSA@(L,0),L)
- SET DDBL=DDBL+1
- SET L=L+1
- +7 SET J=J+1
- +8 QUIT
- End DoDot:1
- +9 IF 'DDBZN
- FOR I=SFR:1:STO
- Begin DoDot:1
- +10 if I'=SFR
- WRITE !
- +11 WRITE $PIECE(DDGLCLR,DDGLDEL)
- +12 IF J=L
- IF $DATA(@DDBSA@(L))
- WRITE $$HTD(@DDBSA@(L),L)
- SET DDBL=DDBL+1
- SET L=L+1
- +13 SET J=J+1
- +14 QUIT
- End DoDot:1
- +15 QUIT
- HFR NEW FTR
- SET FTR=1
- HDR SET DX=0
- +1 SET DY=$PIECE(DDBSY,";")
- +2 XECUTE IOXY
- +3 WRITE $PIECE(DDGLVID,DDGLDEL,6)
- +4 WRITE DDBHDR
- +5 WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +6 if $GET(FTR)
- GOTO FTR
- +7 QUIT
- FTR IF DDBFLGS
- QUIT
- +1 WRITE $PIECE(DDGLVID,DDGLDEL,6)
- +2 IF DDBRSA=1
- WRITE $PIECE(DDGLVID,DDGLDEL,4)
- +3 SET DY=$PIECE(DDBSY,";",4)
- +4 XECUTE IOXY
- +5 WRITE DDBFTR
- +6 SET DX=$PIECE(DDBSX,";",3)
- +7 XECUTE IOXY
- +8 WRITE $JUSTIFY($SELECT(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)," of ",DDBTL
- +9 SET DX=$PIECE(DDBSX,";",4)
- +10 XECUTE IOXY
- +11 WRITE $JUSTIFY($SELECT(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)," of ",DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
- +12 SET DX=$PIECE(DDBSX,";",2)
- +13 XECUTE IOXY
- +14 if 'DDBRHTF
- WRITE $JUSTIFY(DDBSF,4)
- +15 IF DDBRSA=1
- WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +16 WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +17 QUIT
- RLPI ;
- RLPIR IF DDBFLGS
- QUIT
- +1 SET DX=$PIECE(DDBSX,";",3)
- SET DY=$PIECE(DDBSY,";",4)
- +2 IF DDBRSA=1
- WRITE $PIECE(DDGLVID,DDGLDEL,4)
- +3 WRITE $PIECE(DDGLVID,DDGLDEL,6)
- +4 XECUTE IOXY
- +5 WRITE $JUSTIFY($SELECT(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)
- +6 SET DX=$PIECE(DDBSX,";",4)
- +7 XECUTE IOXY
- +8 WRITE $JUSTIFY($SELECT(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)
- +9 IF DDBRSA=1
- WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +10 WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +11 QUIT
- COLR IF DDBFLGS!(DDBRHTF)
- QUIT
- +1 SET DX=$PIECE(DDBSX,";",2)
- SET DY=$PIECE(DDBSY,";",4)
- +2 XECUTE IOXY
- +3 IF DDBRSA=1
- WRITE $PIECE(DDGLVID,DDGLDEL,4)
- +4 WRITE $PIECE(DDGLVID,DDGLDEL,6)
- +5 WRITE $JUSTIFY(DDBSF,4)
- +6 IF DDBRSA=1
- WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +7 WRITE $PIECE(DDGLVID,DDGLDEL,10)
- +8 QUIT
- +9 ;
- HTD(X,WPIEN) ;
- +1 if 'DDBRHTF
- QUIT $EXTRACT(X,DDBSF,DDBST)
- +2 if $LENGTH(X,"$.")'>2
- QUIT X
- +3 if $LENGTH(X,"$.$")>2
- SET X=$$HT(X,"$.$","","")
- +4 if $LENGTH(X,"$.%")>2
- SET X=$$HT(X,"$.%",$PIECE(DDGLVID,DDGLDEL),$PIECE(DDGLVID,DDGLDEL,3))
- +5 QUIT X
- +6 ;
- HT(Y,D,C1,C2) ;
- +1 if $LENGTH(Y,D)'>2
- QUIT Y
- +2 NEW YL,I,Y1
- +3 SET YL=$LENGTH(Y,D)
- SET Y1=""
- +4 FOR I=1:1:YL
- Begin DoDot:1
- +5 if I#2
- SET Y1=Y1_$PIECE(Y,D,I)
- +6 IF '(I#2)
- IF +$GET(DDBRHT)=WPIEN
- IF $PIECE(DDBRHT,DDGLDEL,4)=DDBSA
- IF $PIECE(DDBRHT,DDGLDEL,2)=$PIECE(Y,D,I)
- Begin DoDot:2
- +7 SET Y1=Y1_C1_$PIECE(DDGLVID,DDGLDEL,4)_$PIECE($PIECE(Y,D,I),"^",$SELECT($PIECE(Y,D,I)["$CREF$":$LENGTH($PIECE(Y,D,I),"^"),1:2),255)_$PIECE(DDGLVID,DDGLDEL,5)_C2
- +8 QUIT
- End DoDot:2
- QUIT
- +9 if '(I#2)
- SET Y1=Y1_C1_$PIECE($PIECE(Y,D,I),"^",$SELECT($PIECE(Y,D,I)["$CREF$":$LENGTH($PIECE(Y,D,I),"^"),1:2),255)_C2
- +10 QUIT
- End DoDot:1
- +11 QUIT Y1