Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDBRAP

DDBRAP.m

Go to the documentation of this file.
  1. DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;NOV 04, 1996@13:53
  1. ;;22.0;VA FileMan;;Mar 30, 1999
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. WP(DDBROOT,DDBRFLG,DDBRTLE) ;
  1. ;Pass existing wp root, flag=c/clear all -indexes, title
  1. I $G(DDBROOT)="" Q
  1. I '$D(@DDBROOT) Q
  1. S DDBROOT=$NA(@DDBROOT),DDBRFLG=$G(DDBRFLG),DDBRTLE=$G(DDBRTLE)
  1. N DDBRINDX,DDBRSUB,DDBRSUBL,DDBNROOT,DDBSROOT,DDBAXRT,DDBRCHK,DDBRCHK1
  1. N DDBRSX,DDBRSXL,DDBRI,DDBRSXP,DDBRX,DDBRTLER
  1. S DDBRINDX=0,DDBNROOT=$$NROOT(DDBROOT),DDBAXRT=$NA(@DDBNROOT@("A")),DDBRCHK1=0
  1. Q:DDBNROOT=""!(DDBAXRT="")
  1. K @DDBAXRT
  1. 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
  1. .S DDBRCHK=0
  1. .I DDBRCHK1 S DDBRSX=@DDBROOT@(DDBRINDX),DDBRSXL=$L(DDBRSX,"$.$")
  1. .E S DDBRSX=@DDBROOT@(DDBRINDX,0),DDBRSXL=$L(DDBRSX,"$.$")
  1. .F DDBRI=2:2:DDBRSXL S DDBRSXP=$P(DDBRSX,"$.$",DDBRI) S:'$D(@DDBAXRT@(DDBRSXP)) @DDBAXRT@(DDBRSXP)=DDBRINDX
  1. .Q
  1. S DDBRX=""
  1. I DDBRTLE]"" D
  1. .I '$D(@DDBNROOT@("TITLE")) S @DDBNROOT@("TITLE")=DDBRTLE
  1. .Q
  1. I $G(@DDBNROOT@("TITLE"))']"" D
  1. .Q:$$QL(DDBROOT)'>1
  1. .S DDBRTLER=$NA(@DDBROOT,$$QL(DDBROOT)-1)
  1. .S DDBRTLE=$P($G(@DDBRTLER@(0)),"^")
  1. .I DDBRTLE]"" S @DDBNROOT@("TITLE")=DDBRTLE Q
  1. .Q
  1. S @DDBNROOT@("DATE")=$H
  1. Q
  1. ;
  1. NROOT(DDBROOT) ; *FUNCTION* return new (negative) root for wp field X-REF
  1. ;Q $NA(@DDBROOT@(.001)) ;tested ok
  1. Q $NA(@DDBROOT@(-1)) ;tested ok and in use
  1. ;Q $NA(@DDBROOT@(0,0)) ;tested ok
  1. ;
  1. BINDEX(DDBROOT,DDBRNR,DDBRNRN) ; *FUNCTION* return "B" index root
  1. N DDBRSUBL,DDBSROOT
  1. S DDBRSUBL=$$QL(DDBROOT)
  1. Q:DDBRSUBL'>1 ""
  1. S DDBSROOT=$NA(@DDBROOT,(DDBRSUBL-2))
  1. S DDBRNR=DDBSROOT,DDBRNRN=$$QS(DDBROOT,DDBRSUBL)
  1. Q $NA(@DDBSROOT@("B"))
  1. ;
  1. IENROOT(DDBROOT,DDBRLEV) ;pass root,.variable~by reference to return
  1. ; $qs(ddbroot,$ql(ddbroot))~
  1. N DDBRSUBL,DDBSROOT
  1. S DDBRSUBL=$$QL(DDBROOT)
  1. Q:DDBRSUBL'>1 ""
  1. S DDBRLEV=$$QS(DDBROOT,DDBRSUBL)
  1. Q $NA(@DDBROOT,(DDBRSUBL-2))
  1. ;
  1. EN ;create anchors and jumps on existing wp entry
  1. N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM
  1. I '$$TEST^DDBRT W $C(7),!!,"This terminal does not support scroll region or reverse index",!! Q
  1. D LIST^DDBR3(.DDBX)
  1. I DDBX'>0 W:DDBX=0 $C(7),!!,"No Text",!! Q
  1. S DDBSA=DDBX(6)
  1. S DDBFLG=DDBX(4)
  1. S DDBPMSG=DDBX(5)
  1. W !,"...compiling anchors and hypertext jumps..."
  1. D WP(DDBSA,$G(DDBRFLG),DDBPMSG)
  1. W !,"done!",!
  1. Q
  1. ;
  1. ENP ;create anchors & jumps and 'P'urge non-referenced jumps
  1. N DDBRFLG
  1. S DDBRFLG="P"
  1. G EN
  1. ;
  1. ENC ;create anchors and jumps and "C"lear out all jumps prior to building
  1. N DDBRFLG
  1. S DDBRFLG="C"
  1. G EN
  1. ;
  1. ; THE FOLLOWING CODE WAS COPIED FROM KERNEL'S XLFUTL ROUTINE
  1. QL(X) ;$QLENGTH OF GLOBAL STRING
  1. N %,%1
  1. S %1="" F %=0:1 Q:%1=$NA(@X,%) S %1=$NA(@X,%)
  1. Q %-1
  1. ;
  1. QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING
  1. N %,%1,Y
  1. I X2=-1,X1?1"^"1"[".E1"]".E Q $TR($P($P($NA(@X1,0),"]"),"[",2),"""")
  1. I X2=-1,X1?1"^"1"|".E1"|".E Q $TR($P($NA(@X1,0),"|",2,$L($NA(@X1,0),"|")-1),"""")
  1. I X2=0,(X1'?1"^"1"[".E)&(X1'?1"^"1"|".E) Q $NA(@X1,X2)
  1. I X2=0,X1?1"^"1"[".E1"]".E Q "^"_$P($NA(@X1,X2),"]",2,999)
  1. I X2=0,X1?1"^"1"|".E Q "^"_$P($NA(@X1,X2),"|",$L($NA(@X1,X2),"|"))
  1. S %1=$NA(@X1,X2-1)
  1. I $E(%1,$L(%1))=")" S %1=$E(%1,1,$L(%1)-1)
  1. S Y=$P($NA(@X1,X2),%1,2,999),Y=$E(Y,1,$L(Y)-1)
  1. I X2=1,$E(Y)="(" S Y=$E(Y,2,999)
  1. I X2>1,$E(Y)="," S Y=$E(Y,2,999)
  1. I $A(Y)=34,$A(Y,$L(Y))=34 S Y=$E(Y,2,$L(Y)-1)
  1. Q Y
  1. ;
  1. GETR(DDBRWPDD,DDBRENS,DDBRFLG) ;return root
  1. ;pass Word-processing DD#, entries (external format)[separated by(:)]
  1. ;ie.999008.02,ENTRYONE:SUBENTRY)
  1. ;
  1. N DDBRA,DDBROOT,DDBREL,DDBRLVLS,DDBRI,DDBREN,DDBRIEN,DDBRDA,DDBRX,DDBRDD,DDBREEN,X,Y
  1. Q:'$$UP^DIQGU(DDBRWPDD,.DDBRA)
  1. S DDBREL=$L(DDBRENS,":"),DDBRLVLS=$O(DDBRA("")),DDBREN=1,DDBRIEN=","
  1. I $G(DDBRFLG)'["I",$G(DUZ(0))'="@" D Q:$G(DIERR) ""
  1. .N DIFILE,DIAC,%
  1. .S DIFILE=+DDBRA(DDBRLVLS),DIAC="RD"
  1. .D ^DIAC
  1. .Q:%
  1. .D ERR("Read access denied, for file #"_DIFILE)
  1. .Q
  1. I ("-"_DDBREL)'=DDBRLVLS Q ""
  1. F DDBRI=DDBRLVLS:1:-1 D Q:$G(DIERR)
  1. .S DDBRDD=+DDBRA(DDBRI),DDBREEN=$P(DDBRENS,":",DDBREN),DDBREN=DDBREN+1
  1. .D DA^DILF(DDBRIEN,.DDBRDA)
  1. .S DDBRIEN=","_+$$DIC($$ROOT^DILFD(DDBRDD,DDBRIEN),DDBREEN,.DDBRDA)_DDBRIEN
  1. .Q
  1. I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q ""
  1. S DDBRX=$$GET^DIQG(+DDBRA(-1),$P(DDBRIEN,",",2,99),$O(^DD(+DDBRA(-1),"SB",+DDBRA(0),"")),"B")
  1. I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q ""
  1. Q $P(DDBRX,"$CREF$",2)
  1. ;
  1. DIC(DIC,X,DA) ;dic call for exaxt match
  1. Q:DIC=""!(X="") ""
  1. S DIC(0)="X" S:$E(X)="`" DIC(0)="N"
  1. D ^DIC
  1. Q $G(Y)
  1. ;
  1. ERR(DDBERR) N P S P(1)=DDBERR
  1. I $G(U)="^" N U S U="^"
  1. D BLD^DIALOG(1700,.P)
  1. Q