DDBR1 ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS ;06:01 PM 31 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
GOTO N X
GTR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(1408)_" >" W $$WS(.X) D G:X=""!(X=U) OUT ;**
.D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,"","","KPW",.X)
.K DIR0
.Q
I $E(X)="?" S X(1)="* "_$$EZBLD^DIALOG($S(DDBRHTF:1409,1:1409.1))_" *" G GTR ;**
I X S X=X*DDBSRL G LINE
S $E(X)=$TR($E(X),"bclst","BCLST")
I X["S",$TR($P(X,"S",2)," ") S X=$TR($P(X,"S",2)," ")*DDBSRL G LINE
I X["L",$TR($P(X,"L",2)," ") S X=$TR($P(X,"L",2)," ") G LINE
I X["C",'DDBRHTF,$TR($P(X,"C",2)," ") S X=$TR($P(X,"C",2)," ") I X>0&(X<256) S DDBSF=X G COLENT^DDBR0
I $E(X)="T" G TOP^DDBR0
I $E(X)="B" G BOT^DDBR0
G OUT
LINE S DDBL=$S(X'>DDBSRL:0,X>DDBTL:DDBTL,1:X) D PSR^DDBR0()
Q
NOOF N N
S N=1 I $D(DDBFNO) N D,X G FNO
S X(1)=" * ["_$$EZBLD^DIALOG(1406)_"] *" ;**'NO PREVIOUS FIND STRING AVAILABLE'
N Q S N=0 G BPR
FIND N D,Q,X
N N
S N=0
BPR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(8126) W $$WS(.X) D G:X="" OUT ;**
.N Y
.D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,$P($G(DDBFNO),U,3,255),100,"","","KPW",.X,.Y)
.K DIR0
.S:$P($G(Y),U)="U" X=X_"/U"
.Q
S Q=$TR($E(X,$L(X)-1,$L(X)),"u","U")
S D=$S(Q="/U":-1,1:1)
S:D=-1 X=$E(X,1,$L(X)-2)
Q:X=""
I $E(X)="?" S X(1)=" * [ "_$$EZBLD^DIALOG(1407)_" ] *" G BPR ;**
FNO N I,MATCHI,MATCHX
I N S D=$P(DDBFNO,"^",2),X=$P(DDBFNO,"^",3,255)
S X(1)="",X(2)=" * ["_$$EZBLD^DIALOG(1405,X)_"] *" W $$WS(.X) ;**'SEARCHING'
D S:I<0 I=0
.I N&(D=1) S I=DDBL Q
.I N S I=DDBL-(DDBSRL-1) Q
.I D=1 S I=DDBL-DDBSRL Q
.S I=DDBL+1
.Q
D
.N XUC
.S XUC=$$U(X)
.I DDBDM D Q
..I DDBZN D Q
...F S I=$O(^TMP("DDB",$J,I),D) Q:I'>0 I $$U($G(^(I,0)))[XUC S MATCHI=I,MATCHX=^(0) Q
...Q
..F S I=$O(^TMP("DDB",$J,I),D) Q:I'>0 I $$U(^(I))[XUC S MATCHI=I,MATCHX=^(I) Q
..Q
.I DDBZN D Q
..F S I=$O(@DDBSA@(I),D) Q:I'>0 I $$U($G(@DDBSA@(I,0)))[XUC S MATCHI=I,MATCHX=@DDBSA@(I,0) Q
..Q
.F S I=$O(@DDBSA@(I),D) Q:I'>0 I $$U(@DDBSA@(I))[XUC S MATCHI=I,MATCHX=@DDBSA@(I) Q
.Q
I $G(MATCHI) D S DDBFNO=DDBL_"^"_D_"^"_X Q
.S DDBSF=1,DDBST=IOM F Q:$F(MATCHX,X)'>DDBST D
..S DDBSF=$O(@DDBC@(DDBSF)) S:DDBSF="" DDBSF=$O(@DDBC@(""))
..S DDBST=DDBSF+(IOM-1)
..Q
.I I+(DDBSRL)>DDBTL S I=DDBTL-(DDBSRL-1)
.I DDBTL'>DDBSRL S I=1
.S DDBL=I-1 D SDLRH(I,X),RCLSI^DDBR0
.Q
NO S X(1)="",X(2)=" * ["_$$EZBLD^DIALOG($S(N:8006.11,1:8006.1))_" ] *" W $C(7),$$WS(.X) H 3 ;**'NO MATCH FOUND'
D PSRH
Q
OUT D PSR^DDBR0()
Q
PSRH S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
D SDLRH(DDBL+1,X)
Q
SDL ;
SDLRH(L,HLS) 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 $$HL($$HTD^DDBR0(@DDBSA@(L,0),L),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,7)) 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 $$HL($$HTD^DDBR0(@DDBSA@(L),L),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,7)) S DDBL=DDBL+1,L=L+1
.S J=J+1
.Q
Q
HL(X,S,ON,RS,F) S X=$G(X),S=$G(S),F=$G(F)=1
G:F CS
N C,I,P,T,XU,SU,SL,TL,XL
S XU=$$U(X),SU=$$U(S),SL=$L(S),C=$L(XU,SU)-1,T="",XL=0
Q:'C X
F I=1:1:C S P=$F(XU,SU,XL),T=T_$E(X,XL,P-SL-1)_ON_$E(X,P-SL,P-1)_RS,XL=P
S T=T_$E(X,XL,255)
Q T
U(X) Q $$UP^DILIBF(X) ;**CCO/NI UPPER-CASE
CS Q:$L(X,S)'>1 X
N C,I,P,T
S T="",C=$L(X,S)
F I=1:1:C S P=$P(X,S,I),T=T_P_$S(I'=C:ON_S_RS,1:"")
Q T
HELPS N DDBHELPS
S DDBHELPS=$S(DDBFLG["A":83,1:71)+DDBSRL
HELP I $E(DDBSA,1,11)="^DI(.84,920" S DDBL=0 D SDLR^DDBR0(1),RLPIR^DDBR0 Q
N DDBHA S DDBHA=$S(DDBFLG["A":9202,1:9201) Q:'$D(^DI(.84,DDBHA,2)) S DDBHA=$NA(^(2)) I $G(DUZ("LANG"))>1,$D(^(4,DUZ("LANG"),1)) S DDBHA=$NA(^(1)) ;**CCO/NI
I $D(^TMP("DDBLST",$J,"J")) D
.K ^TMP("DDBLST",$J,"JS")
.M ^TMP("DDBLST",$J,"JS")=^TMP("DDBLST",$J,"J")
.K ^TMP("DDBLST",$J,"J")
.Q
D BROWSE^DDBR(DDBHA,"PNH"_$S(DDBFLG["A":"A",1:""),"VA FileMan Help Document",$G(DDBHELPS),"",IOTM-1,IOBM+1)
K ^TMP("DDBLST",$J,"J")
I $D(^TMP("DDBLST",$J,"JS")) M ^TMP("DDBLST",$J,"J")=^TMP("DDBLST",$J,"JS") K ^TMP("DDBLST",$J,"JS")
W @IOSTBM
D PSR^DDBR0(1)
Q
LC(L,C) Q:$G(L)'>0 ""
S C=$G(C,"-")
Q $TR($J("",L)," ",C)
WS(X) S DX=0,DY=$P(DDBSY,";",3)-3 X IOXY
W $P(DDGLGRA,DDGLDEL)
W $TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))
W $P(DDGLGRA,DDGLDEL,2)
W !,$P(DDGLCLR,DDGLDEL),$G(X(1))
W !,$P(DDGLCLR,DDGLDEL),$G(X(2))
W !,$P(DDGLCLR,DDGLDEL),$G(X(3))
S DY=$P(DDBSY,";",3),DX=$L($G(X(2)))+2 X IOXY
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBR1 4904 printed Dec 13, 2024@02:41:43 Page 2
DDBR1 ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS ;06:01 PM 31 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
GOTO NEW X
GTR ;**
SET X(1)=$GET(X(1))
SET X(2)=$$EZBLD^DIALOG(1408)_" >"
WRITE $$WS(.X)
Begin DoDot:1
+1 DO EN^DIR0($PIECE(DDBSY,";",3)-1,$LENGTH($GET(X(2)))+2,30,1,"",100,"","","KPW",.X)
+2 KILL DIR0
+3 QUIT
End DoDot:1
if X=""!(X=U)
GOTO OUT
+4 ;**
IF $EXTRACT(X)="?"
SET X(1)="* "_$$EZBLD^DIALOG($SELECT(DDBRHTF:1409,1:1409.1))_" *"
GOTO GTR
+5 IF X
SET X=X*DDBSRL
GOTO LINE
+6 SET $EXTRACT(X)=$TRANSLATE($EXTRACT(X),"bclst","BCLST")
+7 IF X["S"
IF $TRANSLATE($PIECE(X,"S",2)," ")
SET X=$TRANSLATE($PIECE(X,"S",2)," ")*DDBSRL
GOTO LINE
+8 IF X["L"
IF $TRANSLATE($PIECE(X,"L",2)," ")
SET X=$TRANSLATE($PIECE(X,"L",2)," ")
GOTO LINE
+9 IF X["C"
IF 'DDBRHTF
IF $TRANSLATE($PIECE(X,"C",2)," ")
SET X=$TRANSLATE($PIECE(X,"C",2)," ")
IF X>0&(X<256)
SET DDBSF=X
GOTO COLENT^DDBR0
+10 IF $EXTRACT(X)="T"
GOTO TOP^DDBR0
+11 IF $EXTRACT(X)="B"
GOTO BOT^DDBR0
+12 GOTO OUT
LINE SET DDBL=$SELECT(X'>DDBSRL:0,X>DDBTL:DDBTL,1:X)
DO PSR^DDBR0()
+1 QUIT
NOOF NEW N
+1 SET N=1
IF $DATA(DDBFNO)
NEW D,X
GOTO FNO
+2 ;**'NO PREVIOUS FIND STRING AVAILABLE'
SET X(1)=" * ["_$$EZBLD^DIALOG(1406)_"] *"
+3 NEW Q
SET N=0
GOTO BPR
FIND NEW D,Q,X
+1 NEW N
+2 SET N=0
BPR ;**
SET X(1)=$GET(X(1))
SET X(2)=$$EZBLD^DIALOG(8126)
WRITE $$WS(.X)
Begin DoDot:1
+1 NEW Y
+2 DO EN^DIR0($PIECE(DDBSY,";",3)-1,$LENGTH($GET(X(2)))+2,30,1,$PIECE($GET(DDBFNO),U,3,255),100,"","","KPW",.X,.Y)
+3 KILL DIR0
+4 if $PIECE($GET(Y),U)="U"
SET X=X_"/U"
+5 QUIT
End DoDot:1
if X=""
GOTO OUT
+6 SET Q=$TRANSLATE($EXTRACT(X,$LENGTH(X)-1,$LENGTH(X)),"u","U")
+7 SET D=$SELECT(Q="/U":-1,1:1)
+8 if D=-1
SET X=$EXTRACT(X,1,$LENGTH(X)-2)
+9 if X=""
QUIT
+10 ;**
IF $EXTRACT(X)="?"
SET X(1)=" * [ "_$$EZBLD^DIALOG(1407)_" ] *"
GOTO BPR
FNO NEW I,MATCHI,MATCHX
+1 IF N
SET D=$PIECE(DDBFNO,"^",2)
SET X=$PIECE(DDBFNO,"^",3,255)
+2 ;**'SEARCHING'
SET X(1)=""
SET X(2)=" * ["_$$EZBLD^DIALOG(1405,X)_"] *"
WRITE $$WS(.X)
+3 Begin DoDot:1
+4 IF N&(D=1)
SET I=DDBL
QUIT
+5 IF N
SET I=DDBL-(DDBSRL-1)
QUIT
+6 IF D=1
SET I=DDBL-DDBSRL
QUIT
+7 SET I=DDBL+1
+8 QUIT
End DoDot:1
if I<0
SET I=0
+9 Begin DoDot:1
+10 NEW XUC
+11 SET XUC=$$U(X)
+12 IF DDBDM
Begin DoDot:2
+13 IF DDBZN
Begin DoDot:3
+14 FOR
SET I=$ORDER(^TMP("DDB",$JOB,I),D)
if I'>0
QUIT
IF $$U($GET(^(I,0)))[XUC
SET MATCHI=I
SET MATCHX=^(0)
QUIT
+15 QUIT
End DoDot:3
QUIT
+16 FOR
SET I=$ORDER(^TMP("DDB",$JOB,I),D)
if I'>0
QUIT
IF $$U(^(I))[XUC
SET MATCHI=I
SET MATCHX=^(I)
QUIT
+17 QUIT
End DoDot:2
QUIT
+18 IF DDBZN
Begin DoDot:2
+19 FOR
SET I=$ORDER(@DDBSA@(I),D)
if I'>0
QUIT
IF $$U($GET(@DDBSA@(I,0)))[XUC
SET MATCHI=I
SET MATCHX=@DDBSA@(I,0)
QUIT
+20 QUIT
End DoDot:2
QUIT
+21 FOR
SET I=$ORDER(@DDBSA@(I),D)
if I'>0
QUIT
IF $$U(@DDBSA@(I))[XUC
SET MATCHI=I
SET MATCHX=@DDBSA@(I)
QUIT
+22 QUIT
End DoDot:1
+23 IF $GET(MATCHI)
Begin DoDot:1
+24 SET DDBSF=1
SET DDBST=IOM
FOR
if $FIND(MATCHX,X)'>DDBST
QUIT
Begin DoDot:2
+25 SET DDBSF=$ORDER(@DDBC@(DDBSF))
if DDBSF=""
SET DDBSF=$ORDER(@DDBC@(""))
+26 SET DDBST=DDBSF+(IOM-1)
+27 QUIT
End DoDot:2
+28 IF I+(DDBSRL)>DDBTL
SET I=DDBTL-(DDBSRL-1)
+29 IF DDBTL'>DDBSRL
SET I=1
+30 SET DDBL=I-1
DO SDLRH(I,X)
DO RCLSI^DDBR0
+31 QUIT
End DoDot:1
SET DDBFNO=DDBL_"^"_D_"^"_X
QUIT
NO ;**'NO MATCH FOUND'
SET X(1)=""
SET X(2)=" * ["_$$EZBLD^DIALOG($SELECT(N:8006.11,1:8006.1))_" ] *"
WRITE $CHAR(7),$$WS(.X)
HANG 3
+1 DO PSRH
+2 QUIT
OUT DO PSR^DDBR0()
+1 QUIT
PSRH SET DDBL=$SELECT(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)
+1 DO SDLRH(DDBL+1,X)
+2 QUIT
SDL ;
SDLRH(L,HLS) 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 $$HL($$HTD^DDBR0(@DDBSA@(L,0),L),HLS,$PIECE(DDGLVID,DDGLDEL,6),$PIECE(DDGLVID,DDGLDEL,7))
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 $$HL($$HTD^DDBR0(@DDBSA@(L),L),HLS,$PIECE(DDGLVID,DDGLDEL,6),$PIECE(DDGLVID,DDGLDEL,7))
SET DDBL=DDBL+1
SET L=L+1
+13 SET J=J+1
+14 QUIT
End DoDot:1
+15 QUIT
HL(X,S,ON,RS,F) SET X=$GET(X)
SET S=$GET(S)
SET F=$GET(F)=1
+1 if F
GOTO CS
+2 NEW C,I,P,T,XU,SU,SL,TL,XL
+3 SET XU=$$U(X)
SET SU=$$U(S)
SET SL=$LENGTH(S)
SET C=$LENGTH(XU,SU)-1
SET T=""
SET XL=0
+4 if 'C
QUIT X
+5 FOR I=1:1:C
SET P=$FIND(XU,SU,XL)
SET T=T_$EXTRACT(X,XL,P-SL-1)_ON_$EXTRACT(X,P-SL,P-1)_RS
SET XL=P
+6 SET T=T_$EXTRACT(X,XL,255)
+7 QUIT T
U(X) ;**CCO/NI UPPER-CASE
QUIT $$UP^DILIBF(X)
CS if $LENGTH(X,S)'>1
QUIT X
+1 NEW C,I,P,T
+2 SET T=""
SET C=$LENGTH(X,S)
+3 FOR I=1:1:C
SET P=$PIECE(X,S,I)
SET T=T_P_$SELECT(I'=C:ON_S_RS,1:"")
+4 QUIT T
HELPS NEW DDBHELPS
+1 SET DDBHELPS=$SELECT(DDBFLG["A":83,1:71)+DDBSRL
HELP IF $EXTRACT(DDBSA,1,11)="^DI(.84,920"
SET DDBL=0
DO SDLR^DDBR0(1)
DO RLPIR^DDBR0
QUIT
+1 ;**CCO/NI
NEW DDBHA
SET DDBHA=$SELECT(DDBFLG["A":9202,1:9201)
if '$DATA(^DI(.84,DDBHA,2))
QUIT
SET DDBHA=$NAME(^(2))
IF $GET(DUZ("LANG"))>1
IF $DATA(^(4,DUZ("LANG"),1))
SET DDBHA=$NAME(^(1))
+2 IF $DATA(^TMP("DDBLST",$JOB,"J"))
Begin DoDot:1
+3 KILL ^TMP("DDBLST",$JOB,"JS")
+4 MERGE ^TMP("DDBLST",$JOB,"JS")=^TMP("DDBLST",$JOB,"J")
+5 KILL ^TMP("DDBLST",$JOB,"J")
+6 QUIT
End DoDot:1
+7 DO BROWSE^DDBR(DDBHA,"PNH"_$SELECT(DDBFLG["A":"A",1:""),"VA FileMan Help Document",$GET(DDBHELPS),"",IOTM-1,IOBM+1)
+8 KILL ^TMP("DDBLST",$JOB,"J")
+9 IF $DATA(^TMP("DDBLST",$JOB,"JS"))
MERGE ^TMP("DDBLST",$JOB,"J")=^TMP("DDBLST",$JOB,"JS")
KILL ^TMP("DDBLST",$JOB,"JS")
+10 WRITE @IOSTBM
+11 DO PSR^DDBR0(1)
+12 QUIT
LC(L,C) if $GET(L)'>0
QUIT ""
+1 SET C=$GET(C,"-")
+2 QUIT $TRANSLATE($JUSTIFY("",L)," ",C)
WS(X) SET DX=0
SET DY=$PIECE(DDBSY,";",3)-3
XECUTE IOXY
+1 WRITE $PIECE(DDGLGRA,DDGLDEL)
+2 WRITE $TRANSLATE($JUSTIFY("",IOM)," ",$PIECE(DDGLGRA,DDGLDEL,3))
+3 WRITE $PIECE(DDGLGRA,DDGLDEL,2)
+4 WRITE !,$PIECE(DDGLCLR,DDGLDEL),$GET(X(1))
+5 WRITE !,$PIECE(DDGLCLR,DDGLDEL),$GET(X(2))
+6 WRITE !,$PIECE(DDGLCLR,DDGLDEL),$GET(X(3))
+7 SET DY=$PIECE(DDBSY,";",3)
SET DX=$LENGTH($GET(X(2)))+2
XECUTE IOXY
+8 QUIT ""
