DDBR2 ;SFISC/DCL-VA FILEMAN BROWSER ;2JAN2012
;;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
SWITCH(DDBLST,DDBRET) ;Switch to another document in list or FileMan Database
I $E(DDBSA,1,11)="^DI(.84,920" D EXIT^DDBR0 Q ;!(DDBSA="^XTMP(""DDBDOC"")") Q
I DDBSA=$NA(^TMP("DDWB",$J)) G EXIT^DDBR0:$G(DDBRET)["R",SWITCH^DDBRWB Q
N DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN
S DILN=DDBRSA(DDBRSA,"DDBSRL")-2
S:$G(DDBLST)="" DDBLST="^TMP(""DDBLST"",$J)" S DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
I DDBFLG["R",'$D(@DDBLST) D SFR() G PS
I DDBFLG["A" D SFR() G PS
I $G(DDBRET)["R" D G:$G(Y) PS Q
.Q:DDBPSA'>0
.Q:'$D(@DDBLST@("APSA",DDBPSA)) S X=^(DDBPSA) S:$D(@DDBLST@("A",X)) Y=^(X)
.I $G(Y) S DDBPSA=DDBPSA-1 N DDBPSA D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y)
.Q
BRMC D BRM
I $D(@DDBLST) D
.I $O(@DDBLST@(" "),-1)=1,$G(@DDBLST@(1,"DDBSA"))=DDBSA Q
.;W "Current list: ",!
.S DDBZ=$G(@DDBLST@("A",DDBSA),0)
.;S X=0 F S X=$O(@DDBLST@(X)) Q:X'>0 W:X'=DDBZ !,$J(X,3)," ",$E(@DDBLST@(X,0),1,75)
.W !
.K DIR0
CUR .I DDBFLG'["R" S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8142),DIR("B")="YES" D ^DIR Q:$D(DIRUT)!(Y'>0) ;"Do you wish to select from current list"
.S DIC=$$OREF^DIQGU(DDBLST),DIC(0)="EMQ",DIC("S")="I +Y'=DDBZ",DIC("W")="W:$E(^(0))=U ^(0)",X="??" D ^DIC ;K DIC("S") Q:Y'>0
.S DIC(0)="AEMQ"
.D ^DIC K DIC("S") Q:Y'>0
.D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y)
.S DIROUT=1
N DDBLNA
S:DDBFLG["R" DIROUT=1
I '$D(DIROUT) D LIST^DDBR3(.DDBLNA)
I $G(DDBLNA,-1)=-1 G PS
I $G(DDBLNA(6))=DDBSA G PS ;if current document selected again
I $G(DDBLNA(6))]"",$D(@DDBLST@("APSA",DDBSA)) G PS ;if already in list
NO I DDBLNA'>0 W $C(7),!!,$$EZBLD^DIALOG(1404),DDBLNA(5) H 3 ;**
D:DDBLNA>0 SAVEDDB(DDBLST,DDBLN),WP(.DDBLNA)
PS D PSR^DDBR0(1)
Q
;
WP(DDBX) ;
S DDBSA=DDBX(6)
S DDBPMSG=DDBX(5)
S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM)
S DDBTL=$P(@DDBSA@(0),"^",3)
S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
S DDBZN=1
S DDBDM=0
S DDBSF=1
S DDBST=IOM
S DDBC="^TMP(""DDBC"",""DDBC"",$J)"
I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)=""
S DDBL=0
Q
;
SAVEDDB(DDBLIST,IEN,NSAPSA) ;Save local varialbes into ^TMP("DDBLIST",$J,IEN)
;DDBS array to save list
;IEN internal entry
;NSAPSA Not Set "APSA" x-ref if undefined, pass 1 to not set NSAPSA (optional - default is to set "APSA")
S NSAPSA=+$G(NSAPSA)
N I,X
F I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@DDBLIST@(IEN,X)=@X
;I $D(DDBFNO) S @DDBLIST@(IEN,DDBFNO)=DDBFNO ;decided to keep it the same throughout the browse session (Next Find String)
S @DDBLIST@(IEN,0)=DDBPMSG
S:'$D(@DDBLIST@(0)) ^(0)="CURRENT LIST^1"
S:'$D(@DDBLIST@("A",DDBSA)) @DDBLIST@("A",DDBSA)=IEN
S:'$D(@DDBLIST@("B",DDBPMSG,IEN)) @DDBLIST@("B",DDBPMSG,IEN)=""
I $G(DDBRET)["R",DDBRPE=DDBRE Q
Q:NSAPSA
S X=$O(@DDBLST@("APSA"," "),-1)+1
I $G(@DDBLIST@("APSA",X-1))=DDBSA S DDBPSA=X-1 Q
S @DDBLIST@("APSA",X)=DDBSA,DDBPSA=X
Q
;
USAVEDDB(DDBLIST,IEN) ;Unsave varialbes in ^TMP("DDBLIST",$J,IEN) to locals
;DDBS array to save list
;IEN internal entry
N I,X
F I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@X=@DDBLIST@(IEN,X)
S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
;I $D(@DDBLIST@(IEN,"DDBFNO")) S DDBFNO=@DDBLIST@(IEN,"DDBFNO")
Q
;
;
CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width
Q:X="" $G(T)
N HW
S W=$G(W,79),HW=W\2
S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
;
BRM ;BROWSE MANAGER SCREEN
N DX,DY,X
S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR("BROWSE SWITCH MANAGER",$J("",IOM+1),IOM)
X IOXY
W $P(DDGLVID,DDGLDEL,6) ;rvon
W $P(DDGLVID,DDGLDEL,4) ;uon
W X
W $P(DDGLVID,DDGLDEL,10) ;rvoff
F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
W $P(DDGLVID,DDGLDEL,6) ;rvon
W $P(DDGLVID,DDGLDEL,4) ;uon
W X
W $P(DDGLVID,DDGLDEL,10) ;rvoff
W @IOSTBM
S DY=$P(DDBSY,";",2)
X IOXY
Q
;
SFR(Y) N X
S X(1)="",X(2)=$$CTXT^DDBR("<< "_$$EZBLD^DIALOG($S($G(Y):7076.1,1:7076))_" >>","",IOM) ;** 'SWITCH FUNCTION RESTRICTED'
W $$WS^DDBR1(.X),$C(7)
R X:3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBR2 4657 printed Sep 23, 2025@20:17:49 Page 2
DDBR2 ;SFISC/DCL-VA FILEMAN BROWSER ;2JAN2012
+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
SWITCH(DDBLST,DDBRET) ;Switch to another document in list or FileMan Database
+1 ;!(DDBSA="^XTMP(""DDBDOC"")") Q
IF $EXTRACT(DDBSA,1,11)="^DI(.84,920"
DO EXIT^DDBR0
QUIT
+2 IF DDBSA=$NAME(^TMP("DDWB",$JOB))
if $GET(DDBRET)["R"
GOTO EXIT^DDBR0
GOTO SWITCH^DDBRWB
QUIT
+3 NEW DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN
+4 SET DILN=DDBRSA(DDBRSA,"DDBSRL")-2
+5 if $GET(DDBLST)=""
SET DDBLST="^TMP(""DDBLST"",$J)"
SET DDBLN=$SELECT($DATA(@DDBLST@("A",DDBSA)):^(DDBSA),1:$ORDER(@DDBLST@(" "),-1)+1)
+6 IF DDBFLG["R"
IF '$DATA(@DDBLST)
DO SFR()
GOTO PS
+7 IF DDBFLG["A"
DO SFR()
GOTO PS
+8 IF $GET(DDBRET)["R"
Begin DoDot:1
+9 if DDBPSA'>0
QUIT
+10 if '$DATA(@DDBLST@("APSA",DDBPSA))
QUIT
SET X=^(DDBPSA)
if $DATA(@DDBLST@("A",X))
SET Y=^(X)
+11 IF $GET(Y)
SET DDBPSA=DDBPSA-1
NEW DDBPSA
DO SAVEDDB(DDBLST,DDBLN)
DO USAVEDDB(DDBLST,+Y)
+12 QUIT
End DoDot:1
if $GET(Y)
GOTO PS
QUIT
BRMC DO BRM
+1 IF $DATA(@DDBLST)
Begin DoDot:1
+2 IF $ORDER(@DDBLST@(" "),-1)=1
IF $GET(@DDBLST@(1,"DDBSA"))=DDBSA
QUIT
+3 ;W "Current list: ",!
+4 SET DDBZ=$GET(@DDBLST@("A",DDBSA),0)
+5 ;S X=0 F S X=$O(@DDBLST@(X)) Q:X'>0 W:X'=DDBZ !,$J(X,3)," ",$E(@DDBLST@(X,0),1,75)
+6 WRITE !
+7 KILL DIR0
CUR ;"Do you wish to select from current list"
IF DDBFLG'["R"
SET DIR(0)="Y"
SET DIR("A")=$$EZBLD^DIALOG(8142)
SET DIR("B")="YES"
DO ^DIR
if $DATA(DIRUT)!(Y'>0)
QUIT
+1 ;K DIC("S") Q:Y'>0
SET DIC=$$OREF^DIQGU(DDBLST)
SET DIC(0)="EMQ"
SET DIC("S")="I +Y'=DDBZ"
SET DIC("W")="W:$E(^(0))=U ^(0)"
SET X="??"
DO ^DIC
+2 SET DIC(0)="AEMQ"
+3 DO ^DIC
KILL DIC("S")
if Y'>0
QUIT
+4 DO SAVEDDB(DDBLST,DDBLN)
DO USAVEDDB(DDBLST,+Y)
+5 SET DIROUT=1
End DoDot:1
+6 NEW DDBLNA
+7 if DDBFLG["R"
SET DIROUT=1
+8 IF '$DATA(DIROUT)
DO LIST^DDBR3(.DDBLNA)
+9 IF $GET(DDBLNA,-1)=-1
GOTO PS
+10 ;if current document selected again
IF $GET(DDBLNA(6))=DDBSA
GOTO PS
+11 ;if already in list
IF $GET(DDBLNA(6))]""
IF $DATA(@DDBLST@("APSA",DDBSA))
GOTO PS
NO ;**
IF DDBLNA'>0
WRITE $CHAR(7),!!,$$EZBLD^DIALOG(1404),DDBLNA(5)
HANG 3
+1 if DDBLNA>0
DO SAVEDDB(DDBLST,DDBLN)
DO WP(.DDBLNA)
PS DO PSR^DDBR0(1)
+1 QUIT
+2 ;
WP(DDBX) ;
+1 SET DDBSA=DDBX(6)
+2 SET DDBPMSG=DDBX(5)
+3 SET DDBHDR=$$CTXT^DDBR(DDBPMSG,$JUSTIFY("",IOM+1),IOM)
+4 SET DDBTL=$PIECE(@DDBSA@(0),"^",3)
+5 SET DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
+6 SET DDBZN=1
+7 SET DDBDM=0
+8 SET DDBSF=1
+9 SET DDBST=IOM
+10 SET DDBC="^TMP(""DDBC"",""DDBC"",$J)"
+11 IF '$DATA(@DDBC)
FOR I=1,22:22:176
SET @DDBC@(I)=""
+12 SET DDBL=0
+13 QUIT
+14 ;
SAVEDDB(DDBLIST,IEN,NSAPSA) ;Save local varialbes into ^TMP("DDBLIST",$J,IEN)
+1 ;DDBS array to save list
+2 ;IEN internal entry
+3 ;NSAPSA Not Set "APSA" x-ref if undefined, pass 1 to not set NSAPSA (optional - default is to set "APSA")
+4 SET NSAPSA=+$GET(NSAPSA)
+5 NEW I,X
+6 FOR I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE"
SET X="DDB"_I
SET @DDBLIST@(IEN,X)=@X
+7 ;I $D(DDBFNO) S @DDBLIST@(IEN,DDBFNO)=DDBFNO ;decided to keep it the same throughout the browse session (Next Find String)
+8 SET @DDBLIST@(IEN,0)=DDBPMSG
+9 if '$DATA(@DDBLIST@(0))
SET ^(0)="CURRENT LIST^1"
+10 if '$DATA(@DDBLIST@("A",DDBSA))
SET @DDBLIST@("A",DDBSA)=IEN
+11 if '$DATA(@DDBLIST@("B",DDBPMSG,IEN))
SET @DDBLIST@("B",DDBPMSG,IEN)=""
+12 IF $GET(DDBRET)["R"
IF DDBRPE=DDBRE
QUIT
+13 if NSAPSA
QUIT
+14 SET X=$ORDER(@DDBLST@("APSA"," "),-1)+1
+15 IF $GET(@DDBLIST@("APSA",X-1))=DDBSA
SET DDBPSA=X-1
QUIT
+16 SET @DDBLIST@("APSA",X)=DDBSA
SET DDBPSA=X
+17 QUIT
+18 ;
USAVEDDB(DDBLIST,IEN) ;Unsave varialbes in ^TMP("DDBLIST",$J,IEN) to locals
+1 ;DDBS array to save list
+2 ;IEN internal entry
+3 NEW I,X
+4 FOR I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE"
SET X="DDB"_I
SET @X=@DDBLIST@(IEN,X)
+5 SET DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
+6 ;I $D(@DDBLIST@(IEN,"DDBFNO")) S DDBFNO=@DDBLIST@(IEN,"DDBFNO")
+7 QUIT
+8 ;
+9 ;
CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width
+1 if X=""
QUIT $GET(T)
+2 NEW HW
+3 SET W=$GET(W,79)
SET HW=W\2
+4 SET $EXTRACT(T,HW-($LENGTH(X)\2),HW-($LENGTH(X)\2)+$LENGTH(X))=X
QUIT T
OREF(X) NEW X1,X2
SET X1=$PIECE(X,"(")_"("
SET X2=$$OR2($PIECE(X,"(",2))
if X2=""
QUIT X1
QUIT X1_X2_","
OR2(%) if %=")"!(%=",")
QUIT ""
if $LENGTH(%)=1
QUIT %
if "),"[$EXTRACT(%,$LENGTH(%))
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
QUIT %
+1 ;
BRM ;BROWSE MANAGER SCREEN
+1 NEW DX,DY,X
+2 SET DX=0
SET DY=$PIECE(DDBSY,";")
SET X=$$CTXT^DDBR("BROWSE SWITCH MANAGER",$JUSTIFY("",IOM+1),IOM)
+3 XECUTE IOXY
+4 ;rvon
WRITE $PIECE(DDGLVID,DDGLDEL,6)
+5 ;uon
WRITE $PIECE(DDGLVID,DDGLDEL,4)
+6 WRITE X
+7 ;rvoff
WRITE $PIECE(DDGLVID,DDGLDEL,10)
+8 FOR DY=$PIECE(DDBSY,";",2):1:$PIECE(DDBSY,";",4)
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+9 ;rvon
WRITE $PIECE(DDGLVID,DDGLDEL,6)
+10 ;uon
WRITE $PIECE(DDGLVID,DDGLDEL,4)
+11 WRITE X
+12 ;rvoff
WRITE $PIECE(DDGLVID,DDGLDEL,10)
+13 WRITE @IOSTBM
+14 SET DY=$PIECE(DDBSY,";",2)
+15 XECUTE IOXY
+16 QUIT
+17 ;
SFR(Y) NEW X
+1 ;** 'SWITCH FUNCTION RESTRICTED'
SET X(1)=""
SET X(2)=$$CTXT^DDBR("<< "_$$EZBLD^DIALOG($SELECT($GET(Y):7076.1,1:7076))_" >>","",IOM)
+2 WRITE $$WS^DDBR1(.X),$CHAR(7)
+3 READ X:3
+4 QUIT
