- 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 Jan 18, 2025@03:42:42 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 ""