DDBR ;SFISC/DCL - VA FILEMAN BROWSER ;13JUN2016
;;22.2;VA FileMan;**3,7**;Jan 05, 2016;Build 3
;;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.
;GFT;**165,999,1055**;
;
EN N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM
; I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;VEN/SMH - don't check for supportability
D LIST^DDBR3(.DDBX)
I DDBX'>0 W:DDBX=0 $C(7),!!,$$EZBLD^DIALOG(1404),!! Q ;**
S DDBSA=DDBX(6)
S DDBFLG=DDBX(4)
S DDBPMSG=DDBX(5)
D CONTNU
D KTMP^DDBRU
Q
;
WP(DDBFN,DDBRN,DDBFLD,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBSA
S DDBSA=$$GET^DIQG($G(DDBFN),$G(DDBRN),$G(DDBFLD),"B")
I $G(DIERR) D CLEAN Q
S DDBSA=$P(DDBSA,"$CREF$",2)
I DDBSA']"" D ERR("FILE, RECORD and/or FIELD") Q
I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q
I $G(DDBFLG)["A" D
.N DDBSAN
.S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA))
.I '$D(@DDBSAN) D WP^DDBRAP($NA(@DDBSA))
.Q:$G(DDBPMSG)]""
.I $D(@DDBSAN@("TITLE")) S DDBPMSG=@DDBSAN@("TITLE") Q
.Q
S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser (wp) DOCUMENT 1")
D CONTNU
D:$G(DDBFLG)'["P" KTMP^DDBRU
Q
;
BROWSE(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBRLIST
CONTNU I $G(U)'="^" N U S U="^"
I $G(DDBFLG)["A" D
.N DDBSAN
.S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA))
.I '$D(@DDBSAN) D WP^DDBRAP($NA(@DDBSA))
.Q:$G(DDBPMSG)]""
.I $D(@DDBSAN@("TITLE")) S DDBPMSG=@DDBSAN@("TITLE") Q
.Q
S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser DOCUMENT 1")
N %,D,DX,IOP,XY,X,Y
D:$G(DDBFLG)'["H" INIT I $G(DIERR) D CLEAN Q
I $G(DDBSA)']"" D ERR("SOURCE ARRAY") Q
I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q
I $G(DDBFLG)'["N",DDBSA'="^TMP(""DDB"",$J)" D
.I $NA(@DDBSA)=$NA(^TMP("DDB",$J)) S DDBSA="^TMP(""DDB"",$J)" Q
.K ^TMP("DDB",$J)
.D XY^%RCR($$OREF(DDBSA),"^TMP(""DDB"",$J,")
.;M ^TMP("DDB",$J)=@DDBSA
.S DDBSA="^TMP(""DDB"",$J)"
.Q
N DDBRE,DDBRPE,DDBPSA,DDBTO,DDBDM,DDBFNO,I,DDBFLGS,DDBRHT,DDBRHTF
N DDBHDR,DDBHDRC,DDBFTR,DDBSP,DDBSF,DDBST,DDBTL,DDBTPG,DDBZN
I '$G(DDBRLIST) N DDBSRL,DDBSX,DDBSY,DDBRSA
S DDBFTR=$E("Col> |"_$$EZBLD^DIALOG(8074)_"| Line> Screen>"_$J("",IOM),1,IOM) ;**
I '$G(DDBRLIST) S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1
S DDBRSA=0
D TB^DDBRS(.IOTM,.IOBM,.DDBRSA)
S DDBSX="0;4;40;65"
S DDBSY=DDBRSA(0,"DDBSY")
I IOBM>(IOSL-1) D ERR($$EZBLD^DIALOG(833)) Q ;**
I IOTM<2 D ERR($$EZBLD^DIALOG(832)) Q ;**
I IOBM'>IOTM D ERR($$EZBLD^DIALOG(831)) Q ;**
S DDBSRL=DDBRSA(0,"DDBSRL")
I DDBSRL'>4,$G(DDBFLG)'["H" D ERR($$EZBLD^DIALOG(834)) Q ;**
I DDBRSA(1,"DDBSRL")'>4 K DDBRSA(1),DDBRSA(2)
S DDBHDR=$$CTXT(DDBPMSG,$J("",IOM+1),IOM),DDBHDRC=0
S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1)
I DDBTL'>0 D I DDBTL'>0 D BLD^DIALOG(1700,$$EZBLD^DIALOG(1404)_DDBSA) D CLEAN Q ;**
.N I S I=0 F S I=$O(@DDBSA@(I)) Q:I'>0 S DDBTL=I
.Q
S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBSF=1,DDBST=IOM
S DDBDM=DDBSA="^TMP(""DDB"",$J)"
I $G(DDBC)=+$G(DDBC) D ERR("TAB (Closed Array Root)") Q
S:$G(DDBC)="" DDBC="^TMP(""DDBC"",$J)"
I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)=""
I $D(@DDBC@(1))'>9 N DDBC0,DDBC1 S @DDBC@(1)="",DDBC1=1,DDBC0=DDBC
S DDBPSA=0,DDBFLG=$G(DDBFLG)
S DDBFLGS=DDBFLG["S",DDBRHTF=DDBFLG["A"
I DDBRHTF S $E(DDBFTR,1,9)="HYPER-TXT"
G EN^DDBRGE
DOCLIST(DDBDSA,DDBFLG,IOTM,IOBM) S IOP="HOME" D ^%ZIS
N DDBPMSG,DDBL,DDBC,DDBSA,DDBSRL,DDBSX,DDBSY,DDBRSA,DDBRLIST
S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1
S DDBSX="0;4;40;65"
S DDBSY=(IOTM-2)_";"_(IOTM-1)_";"_(IOBM-1)_";"_(IOBM) ;hdr,txttop,txtbot,ftr
I IOBM>(IOSL-1) D ERR($$EZBLD^DIALOG(833)) Q ;**
I IOTM<2 D ERR($$EZBLD^DIALOG(832)) Q ;**
I IOBM'>IOTM D ERR($$EZBLD^DIALOG(831)) Q ;**
S DDBSRL=(IOBM-IOTM)+1 ;scroll region lines
I '$D(@DDBDSA) D ERR("DOCUMENT ARRAY INVALID") Q
S DDBFLG=$TR($G(DDBFLG),"P")_"N"
S DDBPMSG=$O(@DDBDSA@("")) S:DDBPMSG]"" DDBSA=@DDBDSA@(DDBPMSG)
I DDBPMSG']""!(DDBSA']"") D ERR("DOCUMENT ARRAY INVALID") Q
D I $G(DIERR) K ^TMP("DDBLST",$J) D CLEAN Q
.N DOC,DOCSA
.S DOC=""
.K ^TMP("DDBLST",$J)
.F S DOC=$O(@DDBDSA@(DOC)) Q:DOC="" D
..S DOCSA=@DDBDSA@(DOC)
..D LOADCL^DDBR4(DOCSA,"",DOC)
..Q
.Q
Q:$G(DDBENDR)
S DDBRLIST=1
G CONTNU
;
RTN G DR^DDBRU
;
ROOT G EN^DDBRU2
;
CTXT(X,T,W) 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 $E(T,1,W)
;
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 %
;
INIT I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
D INIT^DDGLIB0(1)
I $G(DIERR) Q
I '$D(IOSTBM)!('$D(IORI)) S X="IOSTBM;IORI" D ENDR^%ZISS
D:$G(IOSTBM)="" TRMERR^DDGLIB0($$EZBLD^DIALOG(831)) ;**
D:$G(IORI)="" TRMERR^DDGLIB0($$EZBLD^DIALOG(835))
;W $P(DDGLCLR,DDGLDEL,2) ; VEN/SMH - Clear entire screen. ;P7
;TODO: Rollback IOSL to 24 if IOSL is >100; restore at exit (prob in CLEAN) - VEN/SMH
Q
;
ERR(DDBERR) N P S P(1)=DDBERR
I $G(U)="^" N U S U="^"
D BLD^DIALOG(202,.P),OUT^DDBRU:$D(DDGLDEL)
CLEAN D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBR 5414 printed Dec 13, 2024@02:41:41 Page 2
DDBR ;SFISC/DCL - VA FILEMAN BROWSER ;13JUN2016
+1 ;;22.2;VA FileMan;**3,7**;Jan 05, 2016;Build 3
+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 ;GFT;**165,999,1055**;
+7 ;
EN NEW DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM
+1 ; I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;VEN/SMH - don't check for supportability
+2 DO LIST^DDBR3(.DDBX)
+3 ;**
IF DDBX'>0
if DDBX=0
WRITE $CHAR(7),!!,$$EZBLD^DIALOG(1404),!!
QUIT
+4 SET DDBSA=DDBX(6)
+5 SET DDBFLG=DDBX(4)
+6 SET DDBPMSG=DDBX(5)
+7 DO CONTNU
+8 DO KTMP^DDBRU
+9 QUIT
+10 ;
WP(DDBFN,DDBRN,DDBFLD,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) NEW DDBSA
+1 SET DDBSA=$$GET^DIQG($GET(DDBFN),$GET(DDBRN),$GET(DDBFLD),"B")
+2 IF $GET(DIERR)
DO CLEAN
QUIT
+3 SET DDBSA=$PIECE(DDBSA,"$CREF$",2)
+4 IF DDBSA']""
DO ERR("FILE, RECORD and/or FIELD")
QUIT
+5 IF '$DATA(@DDBSA)
DO ERR("SOURCE ARRAY")
QUIT
+6 IF $GET(DDBFLG)["A"
Begin DoDot:1
+7 NEW DDBSAN
+8 SET DDBSAN=$$NROOT^DDBRAP($NAME(@DDBSA))
+9 IF '$DATA(@DDBSAN)
DO WP^DDBRAP($NAME(@DDBSA))
+10 if $GET(DDBPMSG)]""
QUIT
+11 IF $DATA(@DDBSAN@("TITLE"))
SET DDBPMSG=@DDBSAN@("TITLE")
QUIT
+12 QUIT
End DoDot:1
+13 SET DDBPMSG=$SELECT($GET(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser (wp) DOCUMENT 1")
+14 DO CONTNU
+15 if $GET(DDBFLG)'["P"
DO KTMP^DDBRU
+16 QUIT
+17 ;
BROWSE(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) NEW DDBRLIST
CONTNU IF $GET(U)'="^"
NEW U
SET U="^"
+1 IF $GET(DDBFLG)["A"
Begin DoDot:1
+2 NEW DDBSAN
+3 SET DDBSAN=$$NROOT^DDBRAP($NAME(@DDBSA))
+4 IF '$DATA(@DDBSAN)
DO WP^DDBRAP($NAME(@DDBSA))
+5 if $GET(DDBPMSG)]""
QUIT
+6 IF $DATA(@DDBSAN@("TITLE"))
SET DDBPMSG=@DDBSAN@("TITLE")
QUIT
+7 QUIT
End DoDot:1
+8 SET DDBPMSG=$SELECT($GET(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser DOCUMENT 1")
+9 NEW %,D,DX,IOP,XY,X,Y
+10 if $GET(DDBFLG)'["H"
DO INIT
IF $GET(DIERR)
DO CLEAN
QUIT
+11 IF $GET(DDBSA)']""
DO ERR("SOURCE ARRAY")
QUIT
+12 IF '$DATA(@DDBSA)
DO ERR("SOURCE ARRAY")
QUIT
+13 IF $GET(DDBFLG)'["N"
IF DDBSA'="^TMP(""DDB"",$J)"
Begin DoDot:1
+14 IF $NAME(@DDBSA)=$NAME(^TMP("DDB",$JOB))
SET DDBSA="^TMP(""DDB"",$J)"
QUIT
+15 KILL ^TMP("DDB",$JOB)
+16 DO XY^%RCR($$OREF(DDBSA),"^TMP(""DDB"",$J,")
+17 ;M ^TMP("DDB",$J)=@DDBSA
+18 SET DDBSA="^TMP(""DDB"",$J)"
+19 QUIT
End DoDot:1
+20 NEW DDBRE,DDBRPE,DDBPSA,DDBTO,DDBDM,DDBFNO,I,DDBFLGS,DDBRHT,DDBRHTF
+21 NEW DDBHDR,DDBHDRC,DDBFTR,DDBSP,DDBSF,DDBST,DDBTL,DDBTPG,DDBZN
+22 IF '$GET(DDBRLIST)
NEW DDBSRL,DDBSX,DDBSY,DDBRSA
+23 ;**
SET DDBFTR=$EXTRACT("Col> |"_$$EZBLD^DIALOG(8074)_"| Line> Screen>"_$JUSTIFY("",IOM),1,IOM)
+24 IF '$GET(DDBRLIST)
SET IOBM=$SELECT($GET(IOBM)>0:IOBM,1:$GET(IOSL,24))-1
SET IOTM=$SELECT($GET(IOTM)>0:IOTM,1:1)+1
+25 SET DDBRSA=0
+26 DO TB^DDBRS(.IOTM,.IOBM,.DDBRSA)
+27 SET DDBSX="0;4;40;65"
+28 SET DDBSY=DDBRSA(0,"DDBSY")
+29 ;**
IF IOBM>(IOSL-1)
DO ERR($$EZBLD^DIALOG(833))
QUIT
+30 ;**
IF IOTM<2
DO ERR($$EZBLD^DIALOG(832))
QUIT
+31 ;**
IF IOBM'>IOTM
DO ERR($$EZBLD^DIALOG(831))
QUIT
+32 SET DDBSRL=DDBRSA(0,"DDBSRL")
+33 ;**
IF DDBSRL'>4
IF $GET(DDBFLG)'["H"
DO ERR($$EZBLD^DIALOG(834))
QUIT
+34 IF DDBRSA(1,"DDBSRL")'>4
KILL DDBRSA(1),DDBRSA(2)
+35 SET DDBHDR=$$CTXT(DDBPMSG,$JUSTIFY("",IOM+1),IOM)
SET DDBHDRC=0
+36 SET DDBTL=$PIECE($GET(@DDBSA@(0)),"^",3)
if DDBTL'>0
SET DDBTL=$ORDER(@DDBSA@(" "),-1)
+37 ;**
IF DDBTL'>0
Begin DoDot:1
+38 NEW I
SET I=0
FOR
SET I=$ORDER(@DDBSA@(I))
if I'>0
QUIT
SET DDBTL=I
+39 QUIT
End DoDot:1
IF DDBTL'>0
DO BLD^DIALOG(1700,$$EZBLD^DIALOG(1404)_DDBSA)
DO CLEAN
QUIT
+40 SET DDBZN=$DATA(@DDBSA@(DDBTL,0))#2
SET DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
SET DDBSF=1
SET DDBST=IOM
+41 SET DDBDM=DDBSA="^TMP(""DDB"",$J)"
+42 IF $GET(DDBC)=+$GET(DDBC)
DO ERR("TAB (Closed Array Root)")
QUIT
+43 if $GET(DDBC)=""
SET DDBC="^TMP(""DDBC"",$J)"
+44 IF '$DATA(@DDBC)
FOR I=1,22:22:176
SET @DDBC@(I)=""
+45 IF $DATA(@DDBC@(1))'>9
NEW DDBC0,DDBC1
SET @DDBC@(1)=""
SET DDBC1=1
SET DDBC0=DDBC
+46 SET DDBPSA=0
SET DDBFLG=$GET(DDBFLG)
+47 SET DDBFLGS=DDBFLG["S"
SET DDBRHTF=DDBFLG["A"
+48 IF DDBRHTF
SET $EXTRACT(DDBFTR,1,9)="HYPER-TXT"
+49 GOTO EN^DDBRGE
DOCLIST(DDBDSA,DDBFLG,IOTM,IOBM) SET IOP="HOME"
DO ^%ZIS
+1 NEW DDBPMSG,DDBL,DDBC,DDBSA,DDBSRL,DDBSX,DDBSY,DDBRSA,DDBRLIST
+2 SET IOBM=$SELECT($GET(IOBM)>0:IOBM,1:$GET(IOSL,24))-1
SET IOTM=$SELECT($GET(IOTM)>0:IOTM,1:1)+1
+3 SET DDBSX="0;4;40;65"
+4 ;hdr,txttop,txtbot,ftr
SET DDBSY=(IOTM-2)_";"_(IOTM-1)_";"_(IOBM-1)_";"_(IOBM)
+5 ;**
IF IOBM>(IOSL-1)
DO ERR($$EZBLD^DIALOG(833))
QUIT
+6 ;**
IF IOTM<2
DO ERR($$EZBLD^DIALOG(832))
QUIT
+7 ;**
IF IOBM'>IOTM
DO ERR($$EZBLD^DIALOG(831))
QUIT
+8 ;scroll region lines
SET DDBSRL=(IOBM-IOTM)+1
+9 IF '$DATA(@DDBDSA)
DO ERR("DOCUMENT ARRAY INVALID")
QUIT
+10 SET DDBFLG=$TRANSLATE($GET(DDBFLG),"P")_"N"
+11 SET DDBPMSG=$ORDER(@DDBDSA@(""))
if DDBPMSG]""
SET DDBSA=@DDBDSA@(DDBPMSG)
+12 IF DDBPMSG']""!(DDBSA']"")
DO ERR("DOCUMENT ARRAY INVALID")
QUIT
+13 Begin DoDot:1
+14 NEW DOC,DOCSA
+15 SET DOC=""
+16 KILL ^TMP("DDBLST",$JOB)
+17 FOR
SET DOC=$ORDER(@DDBDSA@(DOC))
if DOC=""
QUIT
Begin DoDot:2
+18 SET DOCSA=@DDBDSA@(DOC)
+19 DO LOADCL^DDBR4(DOCSA,"",DOC)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
IF $GET(DIERR)
KILL ^TMP("DDBLST",$JOB)
DO CLEAN
QUIT
+22 if $GET(DDBENDR)
QUIT
+23 SET DDBRLIST=1
+24 GOTO CONTNU
+25 ;
RTN GOTO DR^DDBRU
+1 ;
ROOT GOTO EN^DDBRU2
+1 ;
CTXT(X,T,W) if X=""
QUIT $GET(T)
+1 NEW HW
+2 SET W=$GET(W,79)
SET HW=W\2
+3 SET $EXTRACT(T,HW-($LENGTH(X)\2),HW-($LENGTH(X)\2)+$LENGTH(X))=X
QUIT $EXTRACT(T,1,W)
+4 ;
OREF(X) NEW X1,X2
SET X1=$PIECE(X,"(")_"("
SET X2=$$OR2($PIECE(X,"(",2))
if X2=""
QUIT X1
QUIT X1_X2_","
+1 ;
OR2(%) if %=")"!(%=",")
QUIT ""
if $LENGTH(%)=1
QUIT %
if "),"[$EXTRACT(%,$LENGTH(%))
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
QUIT %
+1 ;
INIT IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+1 DO INIT^DDGLIB0(1)
+2 IF $GET(DIERR)
QUIT
+3 IF '$DATA(IOSTBM)!('$DATA(IORI))
SET X="IOSTBM;IORI"
DO ENDR^%ZISS
+4 ;**
if $GET(IOSTBM)=""
DO TRMERR^DDGLIB0($$EZBLD^DIALOG(831))
+5 if $GET(IORI)=""
DO TRMERR^DDGLIB0($$EZBLD^DIALOG(835))
+6 ;W $P(DDGLCLR,DDGLDEL,2) ; VEN/SMH - Clear entire screen. ;P7
+7 ;TODO: Rollback IOSL to 24 if IOSL is >100; restore at exit (prob in CLEAN) - VEN/SMH
+8 QUIT
+9 ;
ERR(DDBERR) NEW P
SET P(1)=DDBERR
+1 IF $GET(U)="^"
NEW U
SET U="^"
+2 DO BLD^DIALOG(202,.P)
if $DATA(DDGLDEL)
DO OUT^DDBRU
CLEAN if '$DATA(DDS)
DO KILL^DDGLIB0($GET(DDBFLG))
+1 QUIT
