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