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
