- DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;NOV 04, 1996@13:53
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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),!!,"This terminal does not support scroll region or reverse index",!! Q
- D LIST^DDBR3(.DDBX)
- I DDBX'>0 W:DDBX=0 $C(7),!!,"No Text",!! Q
- S DDBSA=DDBX(6)
- S DDBFLG=DDBX(4)
- S DDBPMSG=DDBX(5)
- W !,"...compiling anchors and hypertext jumps..."
- 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
- DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;NOV 04, 1996@13:53
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 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),!!,"This terminal does not support scroll region or reverse index",!!
- QUIT
- +3 DO LIST^DDBR3(.DDBX)
- +4 IF DDBX'>0
- IF DDBX=0
- WRITE $CHAR(7),!!,"No Text",!!
- QUIT
- +5 SET DDBSA=DDBX(6)
- +6 SET DDBFLG=DDBX(4)
- +7 SET DDBPMSG=DDBX(5)
- +8 WRITE !,"...compiling anchors and hypertext jumps..."
- +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