DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;06:56 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
WP(DDBROOT,DDBRFLG,DDBRTLE) ;
;Pass existing wp root, flag=c/clear all -indexes, title
I $G(DDBROOT)="" Q
I '$D(@DDBROOT) Q
S DDBROOT=$NA(@DDBROOT),DDBRFLG=$G(DDBRFLG),DDBRTLE=$G(DDBRTLE)
N DDBRINDX,DDBRSUB,DDBRSUBL,DDBNROOT,DDBSROOT,DDBAXRT,DDBRCHK,DDBRCHK1
N DDBRSX,DDBRSXL,DDBRI,DDBRSXP,DDBRX,DDBRTLER
S DDBRINDX=0,DDBNROOT=$$NROOT(DDBROOT),DDBAXRT=$NA(@DDBNROOT@("A")),DDBRCHK1=0
Q:DDBNROOT=""!(DDBAXRT="")
K @DDBAXRT
F S DDBRINDX=$O(@DDBROOT@(DDBRINDX)),DDBRCHK=1 Q:DDBRINDX'>0 D:$L($G(@DDBROOT@(DDBRINDX,0)),"$.$")>1 I DDBRCHK,$L($G(@DDBROOT@(DDBRINDX)),"$.$")>1 S DDBRCHK1=1 D
.S DDBRCHK=0
.I DDBRCHK1 S DDBRSX=@DDBROOT@(DDBRINDX),DDBRSXL=$L(DDBRSX,"$.$")
.E S DDBRSX=@DDBROOT@(DDBRINDX,0),DDBRSXL=$L(DDBRSX,"$.$")
.F DDBRI=2:2:DDBRSXL S DDBRSXP=$P(DDBRSX,"$.$",DDBRI) S:'$D(@DDBAXRT@(DDBRSXP)) @DDBAXRT@(DDBRSXP)=DDBRINDX
.Q
S DDBRX=""
I DDBRTLE]"" D
.I '$D(@DDBNROOT@("TITLE")) S @DDBNROOT@("TITLE")=DDBRTLE
.Q
I $G(@DDBNROOT@("TITLE"))']"" D
.Q:$$QL(DDBROOT)'>1
.S DDBRTLER=$NA(@DDBROOT,$$QL(DDBROOT)-1)
.S DDBRTLE=$P($G(@DDBRTLER@(0)),"^")
.I DDBRTLE]"" S @DDBNROOT@("TITLE")=DDBRTLE Q
.Q
S @DDBNROOT@("DATE")=$H
Q
;
NROOT(DDBROOT) ; *FUNCTION* return new (negative) root for wp field X-REF
;Q $NA(@DDBROOT@(.001)) ;tested ok
Q $NA(@DDBROOT@(-1)) ;tested ok and in use
;Q $NA(@DDBROOT@(0,0)) ;tested ok
;
BINDEX(DDBROOT,DDBRNR,DDBRNRN) ; *FUNCTION* return "B" index root
N DDBRSUBL,DDBSROOT
S DDBRSUBL=$$QL(DDBROOT)
Q:DDBRSUBL'>1 ""
S DDBSROOT=$NA(@DDBROOT,(DDBRSUBL-2))
S DDBRNR=DDBSROOT,DDBRNRN=$$QS(DDBROOT,DDBRSUBL)
Q $NA(@DDBSROOT@("B"))
;
IENROOT(DDBROOT,DDBRLEV) ;pass root,.variable~by reference to return
; $qs(ddbroot,$ql(ddbroot))~
N DDBRSUBL,DDBSROOT
S DDBRSUBL=$$QL(DDBROOT)
Q:DDBRSUBL'>1 ""
S DDBRLEV=$$QS(DDBROOT,DDBRSUBL)
Q $NA(@DDBROOT,(DDBRSUBL-2))
;
EN ;create anchors and jumps on existing wp entry
N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM
I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;**
D LIST^DDBR3(.DDBX)
I DDBX'>0 W:DDBX=0 $C(7),!!,$$EZBLD^DIALOG(1404),!! Q ;**NO TEXT
S DDBSA=DDBX(6)
S DDBFLG=DDBX(4)
S DDBPMSG=DDBX(5)
W !,"...." ;**
D WP(DDBSA,$G(DDBRFLG),DDBPMSG)
W !,"done!",!
Q
;
ENP ;create anchors & jumps and 'P'urge non-referenced jumps
N DDBRFLG
S DDBRFLG="P"
G EN
;
ENC ;create anchors and jumps and "C"lear out all jumps prior to building
N DDBRFLG
S DDBRFLG="C"
G EN
;
; THE FOLLOWING CODE WAS COPIED FROM KERNEL'S XLFUTL ROUTINE
QL(X) ;$QLENGTH OF GLOBAL STRING
N %,%1
S %1="" F %=0:1 Q:%1=$NA(@X,%) S %1=$NA(@X,%)
Q %-1
;
QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING
N %,%1,Y
I X2=-1,X1?1"^"1"[".E1"]".E Q $TR($P($P($NA(@X1,0),"]"),"[",2),"""")
I X2=-1,X1?1"^"1"|".E1"|".E Q $TR($P($NA(@X1,0),"|",2,$L($NA(@X1,0),"|")-1),"""")
I X2=0,(X1'?1"^"1"[".E)&(X1'?1"^"1"|".E) Q $NA(@X1,X2)
I X2=0,X1?1"^"1"[".E1"]".E Q "^"_$P($NA(@X1,X2),"]",2,999)
I X2=0,X1?1"^"1"|".E Q "^"_$P($NA(@X1,X2),"|",$L($NA(@X1,X2),"|"))
S %1=$NA(@X1,X2-1)
I $E(%1,$L(%1))=")" S %1=$E(%1,1,$L(%1)-1)
S Y=$P($NA(@X1,X2),%1,2,999),Y=$E(Y,1,$L(Y)-1)
I X2=1,$E(Y)="(" S Y=$E(Y,2,999)
I X2>1,$E(Y)="," S Y=$E(Y,2,999)
I $A(Y)=34,$A(Y,$L(Y))=34 S Y=$E(Y,2,$L(Y)-1)
Q Y
;
GETR(DDBRWPDD,DDBRENS,DDBRFLG) ;return root
;pass Word-processing DD#, entries (external format)[separated by(:)]
;ie.999008.02,ENTRYONE:SUBENTRY)
;
N DDBRA,DDBROOT,DDBREL,DDBRLVLS,DDBRI,DDBREN,DDBRIEN,DDBRDA,DDBRX,DDBRDD,DDBREEN,X,Y
Q:'$$UP^DIQGU(DDBRWPDD,.DDBRA)
S DDBREL=$L(DDBRENS,":"),DDBRLVLS=$O(DDBRA("")),DDBREN=1,DDBRIEN=","
I $G(DDBRFLG)'["I",$G(DUZ(0))'="@" D Q:$G(DIERR) ""
.N DIFILE,DIAC,%
.S DIFILE=+DDBRA(DDBRLVLS),DIAC="RD"
.D ^DIAC
.Q:%
.D ERR("Read access denied, for file #"_DIFILE)
.Q
I ("-"_DDBREL)'=DDBRLVLS Q ""
F DDBRI=DDBRLVLS:1:-1 D Q:$G(DIERR)
.S DDBRDD=+DDBRA(DDBRI),DDBREEN=$P(DDBRENS,":",DDBREN),DDBREN=DDBREN+1
.D DA^DILF(DDBRIEN,.DDBRDA)
.S DDBRIEN=","_+$$DIC($$ROOT^DILFD(DDBRDD,DDBRIEN),DDBREEN,.DDBRDA)_DDBRIEN
.Q
I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q ""
S DDBRX=$$GET^DIQG(+DDBRA(-1),$P(DDBRIEN,",",2,99),$O(^DD(+DDBRA(-1),"SB",+DDBRA(0),"")),"B")
I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q ""
Q $P(DDBRX,"$CREF$",2)
;
DIC(DIC,X,DA) ;dic call for exaxt match
Q:DIC=""!(X="") ""
S DIC(0)="X" S:$E(X)="`" DIC(0)="N"
D ^DIC
Q $G(Y)
;
ERR(DDBERR) N P S P(1)=DDBERR
I $G(U)="^" N U S U="^"
D BLD^DIALOG(1700,.P)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBRAP 4921 printed Dec 13, 2024@02:41:51 Page 2
DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;06:56 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
WP(DDBROOT,DDBRFLG,DDBRTLE) ;
+1 ;Pass existing wp root, flag=c/clear all -indexes, title
+2 IF $GET(DDBROOT)=""
QUIT
+3 IF '$DATA(@DDBROOT)
QUIT
+4 SET DDBROOT=$NAME(@DDBROOT)
SET DDBRFLG=$GET(DDBRFLG)
SET DDBRTLE=$GET(DDBRTLE)
+5 NEW DDBRINDX,DDBRSUB,DDBRSUBL,DDBNROOT,DDBSROOT,DDBAXRT,DDBRCHK,DDBRCHK1
+6 NEW DDBRSX,DDBRSXL,DDBRI,DDBRSXP,DDBRX,DDBRTLER
+7 SET DDBRINDX=0
SET DDBNROOT=$$NROOT(DDBROOT)
SET DDBAXRT=$NAME(@DDBNROOT@("A"))
SET DDBRCHK1=0
+8 if DDBNROOT=""!(DDBAXRT="")
QUIT
+9 KILL @DDBAXRT
+10 FOR
SET DDBRINDX=$ORDER(@DDBROOT@(DDBRINDX))
SET DDBRCHK=1
if DDBRINDX'>0
QUIT
if $LENGTH($GET(@DDBROOT@(DDBRINDX,0)),"$.$")>1
Begin DoDot:1
+11 SET DDBRCHK=0
+12 IF DDBRCHK1
SET DDBRSX=@DDBROOT@(DDBRINDX)
SET DDBRSXL=$LENGTH(DDBRSX,"$.$")
+13 IF '$TEST
SET DDBRSX=@DDBROOT@(DDBRINDX,0)
SET DDBRSXL=$LENGTH(DDBRSX,"$.$")
+14 FOR DDBRI=2:2:DDBRSXL
SET DDBRSXP=$PIECE(DDBRSX,"$.$",DDBRI)
if '$DATA(@DDBAXRT@(DDBRSXP))
SET @DDBAXRT@(DDBRSXP)=DDBRINDX
+15 QUIT
End DoDot:1
IF DDBRCHK
IF $LENGTH($GET(@DDBROOT@(DDBRINDX)),"$.$")>1
SET DDBRCHK1=1
Begin DoDot:1
End DoDot:1
+16 SET DDBRX=""
+17 IF DDBRTLE]""
Begin DoDot:1
+18 IF '$DATA(@DDBNROOT@("TITLE"))
SET @DDBNROOT@("TITLE")=DDBRTLE
+19 QUIT
End DoDot:1
+20 IF $GET(@DDBNROOT@("TITLE"))']""
Begin DoDot:1
+21 if $$QL(DDBROOT)'>1
QUIT
+22 SET DDBRTLER=$NAME(@DDBROOT,$$QL(DDBROOT)-1)
+23 SET DDBRTLE=$PIECE($GET(@DDBRTLER@(0)),"^")
+24 IF DDBRTLE]""
SET @DDBNROOT@("TITLE")=DDBRTLE
QUIT
+25 QUIT
End DoDot:1
+26 SET @DDBNROOT@("DATE")=$HOROLOG
+27 QUIT
+28 ;
NROOT(DDBROOT) ; *FUNCTION* return new (negative) root for wp field X-REF
+1 ;Q $NA(@DDBROOT@(.001)) ;tested ok
+2 ;tested ok and in use
QUIT $NAME(@DDBROOT@(-1))
+3 ;Q $NA(@DDBROOT@(0,0)) ;tested ok
+4 ;
BINDEX(DDBROOT,DDBRNR,DDBRNRN) ; *FUNCTION* return "B" index root
+1 NEW DDBRSUBL,DDBSROOT
+2 SET DDBRSUBL=$$QL(DDBROOT)
+3 if DDBRSUBL'>1
QUIT ""
+4 SET DDBSROOT=$NAME(@DDBROOT,(DDBRSUBL-2))
+5 SET DDBRNR=DDBSROOT
SET DDBRNRN=$$QS(DDBROOT,DDBRSUBL)
+6 QUIT $NAME(@DDBSROOT@("B"))
+7 ;
IENROOT(DDBROOT,DDBRLEV) ;pass root,.variable~by reference to return
+1 ; $qs(ddbroot,$ql(ddbroot))~
+2 NEW DDBRSUBL,DDBSROOT
+3 SET DDBRSUBL=$$QL(DDBROOT)
+4 if DDBRSUBL'>1
QUIT ""
+5 SET DDBRLEV=$$QS(DDBROOT,DDBRSUBL)
+6 QUIT $NAME(@DDBROOT,(DDBRSUBL-2))
+7 ;
EN ;create anchors and jumps on existing wp entry
+1 NEW DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM
+2 ;**
IF '$$TEST^DDBRT
WRITE $CHAR(7),!!,$$EZBLD^DIALOG(830),!!
QUIT
+3 DO LIST^DDBR3(.DDBX)
+4 ;**NO TEXT
IF DDBX'>0
if DDBX=0
WRITE $CHAR(7),!!,$$EZBLD^DIALOG(1404),!!
QUIT
+5 SET DDBSA=DDBX(6)
+6 SET DDBFLG=DDBX(4)
+7 SET DDBPMSG=DDBX(5)
+8 ;**
WRITE !,"...."
+9 DO WP(DDBSA,$GET(DDBRFLG),DDBPMSG)
+10 WRITE !,"done!",!
+11 QUIT
+12 ;
ENP ;create anchors & jumps and 'P'urge non-referenced jumps
+1 NEW DDBRFLG
+2 SET DDBRFLG="P"
+3 GOTO EN
+4 ;
ENC ;create anchors and jumps and "C"lear out all jumps prior to building
+1 NEW DDBRFLG
+2 SET DDBRFLG="C"
+3 GOTO EN
+4 ;
+5 ; THE FOLLOWING CODE WAS COPIED FROM KERNEL'S XLFUTL ROUTINE
QL(X) ;$QLENGTH OF GLOBAL STRING
+1 NEW %,%1
+2 SET %1=""
FOR %=0:1
if %1=$NAME(@X,%)
QUIT
SET %1=$NAME(@X,%)
+3 QUIT %-1
+4 ;
QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING
+1 NEW %,%1,Y
+2 IF X2=-1
IF X1?1"^"1"[".E1"]".E
QUIT $TRANSLATE($PIECE($PIECE($NAME(@X1,0),"]"),"[",2),"""")
+3 IF X2=-1
IF X1?1"^"1"|".E1"|".E
QUIT $TRANSLATE($PIECE($NAME(@X1,0),"|",2,$LENGTH($NAME(@X1,0),"|")-1),"""")
+4 IF X2=0
IF (X1'?1"^"1"[".E)&(X1'?1"^"1"|".E)
QUIT $NAME(@X1,X2)
+5 IF X2=0
IF X1?1"^"1"[".E1"]".E
QUIT "^"_$PIECE($NAME(@X1,X2),"]",2,999)
+6 IF X2=0
IF X1?1"^"1"|".E
QUIT "^"_$PIECE($NAME(@X1,X2),"|",$LENGTH($NAME(@X1,X2),"|"))
+7 SET %1=$NAME(@X1,X2-1)
+8 IF $EXTRACT(%1,$LENGTH(%1))=")"
SET %1=$EXTRACT(%1,1,$LENGTH(%1)-1)
+9 SET Y=$PIECE($NAME(@X1,X2),%1,2,999)
SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
+10 IF X2=1
IF $EXTRACT(Y)="("
SET Y=$EXTRACT(Y,2,999)
+11 IF X2>1
IF $EXTRACT(Y)=","
SET Y=$EXTRACT(Y,2,999)
+12 IF $ASCII(Y)=34
IF $ASCII(Y,$LENGTH(Y))=34
SET Y=$EXTRACT(Y,2,$LENGTH(Y)-1)
+13 QUIT Y
+14 ;
GETR(DDBRWPDD,DDBRENS,DDBRFLG) ;return root
+1 ;pass Word-processing DD#, entries (external format)[separated by(:)]
+2 ;ie.999008.02,ENTRYONE:SUBENTRY)
+3 ;
+4 NEW DDBRA,DDBROOT,DDBREL,DDBRLVLS,DDBRI,DDBREN,DDBRIEN,DDBRDA,DDBRX,DDBRDD,DDBREEN,X,Y
+5 if '$$UP^DIQGU(DDBRWPDD,.DDBRA)
QUIT
+6 SET DDBREL=$LENGTH(DDBRENS,":")
SET DDBRLVLS=$ORDER(DDBRA(""))
SET DDBREN=1
SET DDBRIEN=","
+7 IF $GET(DDBRFLG)'["I"
IF $GET(DUZ(0))'="@"
Begin DoDot:1
+8 NEW DIFILE,DIAC,%
+9 SET DIFILE=+DDBRA(DDBRLVLS)
SET DIAC="RD"
+10 DO ^DIAC
+11 if %
QUIT
+12 DO ERR("Read access denied, for file #"_DIFILE)
+13 QUIT
End DoDot:1
if $GET(DIERR)
QUIT ""
+14 IF ("-"_DDBREL)'=DDBRLVLS
QUIT ""
+15 FOR DDBRI=DDBRLVLS:1:-1
Begin DoDot:1
+16 SET DDBRDD=+DDBRA(DDBRI)
SET DDBREEN=$PIECE(DDBRENS,":",DDBREN)
SET DDBREN=DDBREN+1
+17 DO DA^DILF(DDBRIEN,.DDBRDA)
+18 SET DDBRIEN=","_+$$DIC($$ROOT^DILFD(DDBRDD,DDBRIEN),DDBREEN,.DDBRDA)_DDBRIEN
+19 QUIT
End DoDot:1
if $GET(DIERR)
QUIT
+20 IF $GET(DIERR)
KILL DIERR,^TMP("DIERR",$JOB)
QUIT ""
+21 SET DDBRX=$$GET^DIQG(+DDBRA(-1),$PIECE(DDBRIEN,",",2,99),$ORDER(^DD(+DDBRA(-1),"SB",+DDBRA(0),"")),"B")
+22 IF $GET(DIERR)
KILL DIERR,^TMP("DIERR",$JOB)
QUIT ""
+23 QUIT $PIECE(DDBRX,"$CREF$",2)
+24 ;
DIC(DIC,X,DA) ;dic call for exaxt match
+1 if DIC=""!(X="")
QUIT ""
+2 SET DIC(0)="X"
if $EXTRACT(X)="`"
SET DIC(0)="N"
+3 DO ^DIC
+4 QUIT $GET(Y)
+5 ;
ERR(DDBERR) NEW P
SET P(1)=DDBERR
+1 IF $GET(U)="^"
NEW U
SET U="^"
+2 DO BLD^DIALOG(1700,.P)
+3 QUIT
