DDBRAHTJ ;SFISC/DCL-BROWSER HYPERTEXT JUMP ;18NOV2012
;;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
JUMP(DDBRDIR) ; pass direction 1/forward -1/backward
;
;
N DDBSAN,DDBRAFLG,DDBLST
S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)),DDBLST=$NA(^TMP("DDBLST",$J))
I $G(DDBRDIR)=1 D FRWD Q
D BCK
Q
FRWD ; forward
Q:'$$CHKI
N DDBRAHP,DDBRAHA,DDBSANX,DDBRAAH,DDBRAHL,DDBRSET,DIERM
S DDBSANX=$P(DDBRHT,DDGLDEL,2),DDBRAAH=$P(DDBSANX,"^"),DDBRSET=1
;jump to another root
I DDBSANX["$CREF$" D G STKPT:DDBSANX]"" G PS^DDBR2
.N DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT,DDBRXC2,DDBRXC3
.S DDBRATR=$P(DDBSANX,"$CREF$",2)
.S DDBRAAH=$P($P(DDBSANX,"$CREF$",3),"^")
.I DDBRATR="" S DDBRAAH="" Q
.I $D(@DDBRATR)'>9,$E($G(@DDBRATR),1,5)="$XC$^" D Q:$D(@DDBRATR)'>9
..N X,DDBRNR
..S DDBRXC3=$P(@DDBRATR,"$XC$^",3)
..S X(1)="",X(2)=$$CTXT^DDBR("Loading "_DDBRXC3,"",IOM),X(3)=""
..W $$WS^DDBR1(.X)
..S DDBRXC2=$P(@DDBRATR,"$XC$^",2) X DDBRXC2
..I $D(@DDBRATR)'>9 Q
..I DDBRXC3]"" D WP^DDBRAP(DDBRATR,"",DDBRXC3)
..Q
.I $D(@DDBRATR)'>9,$E($G(@DDBRATR),1,6)="$XCR$^" D W @IOSTBM Q
..N X,IOTM,IOBM,IOSTBM
..S DDBRXC2=$P(@DDBRATR,"$XCR$^",2),DDBSANX="" X DDBRXC2
..W:$D(IOF) @IOF
..S X=0 X ^DD("OS",DISYS,"RM")
..W $P(DDGLVID,DDGLDEL,8)
..Q
.I '$D(@DDBRATR) S DDBRAAH="" Q
.S DDBRANRT=$$NROOT^DDBRAP(DDBRATR)
.I '$D(@DDBRANRT) D WP^DDBRAP(DDBRATR)
.S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
.D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET
.S DDBRSET=0
.S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1
.S DDBSA=DDBRATR,DDBSAN=DDBRANRT
UP .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG=$$UP^DILIBF($P(DDBSANX,"^",$L(DDBSANX,"^"))) ;**
.D SAVSET
.Q
;jump to another file, w-pDD#,entry:entry#anchor
I DDBRAAH,DDBRAAH["@" D G STKPT
.N DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT
.S DDBRAB=$P(DDBRAAH,"#")
.I DDBRAB="" S DDBRAAH="" Q
.S DDBRATR=$$GETR^DDBRAP($P(DDBRAB,"@"),$P($P(DDBRAB,"@",2),"#"))
.I DDBRATR="" D Q
..S DDBRAAH=""
..I $G(DIERR) S DIERM=$$CTXT^DDBR($G(^TMP("DIERR",$J,+DIERR,"TEXT",1)))
..K DIERR,^TMP("DIERR",$J)
..Q
.S DDBRANRT=$$NROOT^DDBRAP(DDBRATR)
.I '$D(@DDBRANRT) D WP^DDBRAP(DDBRATR)
.S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
.D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET
.S DDBRSET=0
.S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1
.S DDBSA=DDBRATR,DDBSAN=DDBRANRT
.S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG="HYPERTEXT JUMP ID#"_$O(@DDBLST@("J",""),-1)+1
.D SAVSET
.Q
;jump to another entry in the same file, same level
I DDBRAAH["#",$P(DDBRAAH,"#")]"" D
.N DDBRAB,DDBRABR,DDBRAIEN,DDBLSTN,DDBRALEV,DDBRANRT
.S DDBRAB=$P(DDBRAAH,"#")
.I DDBRAB="" S DDBRAAH="" Q
.S DDBRALEV="",DDBRABR=$$IENROOT^DDBRAP($NA(@DDBSA),.DDBRALEV)
.S DDBRAIEN=$O(@DDBRABR@("B",DDBRAB,""))
.I 'DDBRAIEN S DDBRAAH="" Q
.S DDBRANRT=$$NROOT^DDBRAP($NA(@DDBRABR@(DDBRAIEN,DDBRALEV)))
.I '$D(@DDBRANRT) D WP^DDBRAP($NA(@DDBRABR@(DDBRAIEN,DDBRALEV)))
.S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
.D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET
.S DDBRSET=0
.S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1
.S DDBSA=$NA(@DDBRABR@(DDBRAIEN,DDBRALEV))
.S DDBSAN=DDBRANRT
.S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG="HYPERTEXT JUMP ID#"_$O(@DDBLST@("J",""),-1)+1
.D SAVSET
.Q
STKPT S:DDBRAAH["#" DDBRAAH=$P(DDBRAAH,"#",2)
I DDBRAAH]"" S DDBRAHA=$G(@DDBSAN@("A",DDBRAAH))
I DDBRSET,$G(DDBRAHA)'>0 D NOHTJ($G(DIERM)) G PS^DDBR2
S DDBRAHL=$S($G(DDBRAHA):DDBRAHA+DDBSRL-1,1:0)
D SET:DDBRSET,GOTO Q
Q
;
SET ; set and save jump info
S DDBRAHP=$O(@DDBLST@("J",""),-1)+1
S @DDBLST@("J",DDBRAHP)=DDBSA_DDGLDEL_DDBL_"^"_+$G(DDBLSTN)_DDGLDEL_DDBRHT
Q
;
GOTO ; jump to line in current document
S DDBL=$S(DDBRAHL'>DDBSRL:0,DDBRAHL>DDBTL:DDBTL,1:DDBRAHL) D PSR^DDBR0(+$G(DDBRAFLG))
Q
BCK ; backward
Q:'$D(@DDBLST@("J"))
N DDBX,DDBY,DDBRAFLG
S DDBX=$O(@DDBLST@("J",""),-1),DDBY=@DDBLST@("J",DDBX)
K @DDBLST@("J",DDBX)
I $P(DDBY,DDGLDEL)'=DDBSA D S DDBRAFLG=1
.D USAVEDDB^DDBR2(DDBLST,$P($P(DDBY,DDGLDEL,2),"^",2))
S DDBL=+$P(DDBY,DDGLDEL,2),DDBRHT=$P(DDBY,DDGLDEL,3,255)
D PSR^DDBR0(+$G(DDBRAFLG))
Q
CHKI() ;return 1 if ok 0 not ok to continue also init DDBRHT if undefined
S DDBRHT=$G(DDBRHT)
Q:DDBRHT="" 0
I $P(DDBRHT,DDGLDEL,4)'=DDBSA Q 0
I +DDBRHT>DDBL Q 0
I +DDBRHT<($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q 0
Q 1
;
NOHTJ(EM) ; no hypertext jump available
N X,Y
S Y=$P(DDBSANX,"^",$S(DDBSANX["$CREF$":$L(DDBSANX,"^"),1:2)),X(1)=$$CTXT^DDBR(Y,"",IOM),EM=$G(EM) S:$P(EM,"Error:",2)]"" EM="<< "_$P(EM,"Error:",2)_" >>"
S X(2)=""
S X(3)=$$CTXT^DDBR($S(EM]"":EM,1:"<< "_$$EZBLD^DIALOG(7077)_" >>"),"",IOM) ;**NO HYPERTEXT JUMP
W $$WS^DDBR1(.X),$C(7)
R X:5
Q
;
SAVSET ;
S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM)
S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1)
S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
S DDBZN=$D(@DDBSA@(DDBTL,0))#2
S DDBDM=0
S DDBSF=1
S DDBST=IOM
S DDBC=$NA(^TMP("DDBC","DDBC",$J))
I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBRAHTJ 5405 printed Oct 16, 2024@18:42:23 Page 2
DDBRAHTJ ;SFISC/DCL-BROWSER HYPERTEXT JUMP ;18NOV2012
+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
JUMP(DDBRDIR) ; pass direction 1/forward -1/backward
+1 ;
+2 ;
+3 NEW DDBSAN,DDBRAFLG,DDBLST
+4 SET DDBSAN=$$NROOT^DDBRAP($NAME(@DDBSA))
SET DDBLST=$NAME(^TMP("DDBLST",$JOB))
+5 IF $GET(DDBRDIR)=1
DO FRWD
QUIT
+6 DO BCK
+7 QUIT
FRWD ; forward
+1 if '$$CHKI
QUIT
+2 NEW DDBRAHP,DDBRAHA,DDBSANX,DDBRAAH,DDBRAHL,DDBRSET,DIERM
+3 SET DDBSANX=$PIECE(DDBRHT,DDGLDEL,2)
SET DDBRAAH=$PIECE(DDBSANX,"^")
SET DDBRSET=1
+4 ;jump to another root
+5 IF DDBSANX["$CREF$"
Begin DoDot:1
+6 NEW DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT,DDBRXC2,DDBRXC3
+7 SET DDBRATR=$PIECE(DDBSANX,"$CREF$",2)
+8 SET DDBRAAH=$PIECE($PIECE(DDBSANX,"$CREF$",3),"^")
+9 IF DDBRATR=""
SET DDBRAAH=""
QUIT
+10 IF $DATA(@DDBRATR)'>9
IF $EXTRACT($GET(@DDBRATR),1,5)="$XC$^"
Begin DoDot:2
+11 NEW X,DDBRNR
+12 SET DDBRXC3=$PIECE(@DDBRATR,"$XC$^",3)
+13 SET X(1)=""
SET X(2)=$$CTXT^DDBR("Loading "_DDBRXC3,"",IOM)
SET X(3)=""
+14 WRITE $$WS^DDBR1(.X)
+15 SET DDBRXC2=$PIECE(@DDBRATR,"$XC$^",2)
XECUTE DDBRXC2
+16 IF $DATA(@DDBRATR)'>9
QUIT
+17 IF DDBRXC3]""
DO WP^DDBRAP(DDBRATR,"",DDBRXC3)
+18 QUIT
End DoDot:2
if $DATA(@DDBRATR)'>9
QUIT
+19 IF $DATA(@DDBRATR)'>9
IF $EXTRACT($GET(@DDBRATR),1,6)="$XCR$^"
Begin DoDot:2
+20 NEW X,IOTM,IOBM,IOSTBM
+21 SET DDBRXC2=$PIECE(@DDBRATR,"$XCR$^",2)
SET DDBSANX=""
XECUTE DDBRXC2
+22 if $DATA(IOF)
WRITE @IOF
+23 SET X=0
XECUTE ^DD("OS",DISYS,"RM")
+24 WRITE $PIECE(DDGLVID,DDGLDEL,8)
+25 QUIT
End DoDot:2
WRITE @IOSTBM
QUIT
+26 IF '$DATA(@DDBRATR)
SET DDBRAAH=""
QUIT
+27 SET DDBRANRT=$$NROOT^DDBRAP(DDBRATR)
+28 IF '$DATA(@DDBRANRT)
DO WP^DDBRAP(DDBRATR)
+29 SET DDBLSTN=$SELECT($DATA(@DDBLST@("A",DDBSA)):^(DDBSA),1:$ORDER(@DDBLST@(" "),-1)+1)
+30 DO SAVEDDB^DDBR2(DDBLST,DDBLSTN,1)
DO SET
+31 SET DDBRSET=0
+32 SET DDBRAAH=$PIECE(DDBRAAH,"#",2)
SET DDBRAFLG=1
+33 SET DDBSA=DDBRATR
SET DDBSAN=DDBRANRT
UP ;**
SET DDBPMSG=$GET(@DDBSAN@("TITLE"))
if DDBPMSG=""
SET DDBPMSG=$$UP^DILIBF($PIECE(DDBSANX,"^",$LENGTH(DDBSANX,"^")))
+1 DO SAVSET
+2 QUIT
End DoDot:1
if DDBSANX]""
GOTO STKPT
GOTO PS^DDBR2
+3 ;jump to another file, w-pDD#,entry:entry#anchor
+4 IF DDBRAAH
IF DDBRAAH["@"
Begin DoDot:1
+5 NEW DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT
+6 SET DDBRAB=$PIECE(DDBRAAH,"#")
+7 IF DDBRAB=""
SET DDBRAAH=""
QUIT
+8 SET DDBRATR=$$GETR^DDBRAP($PIECE(DDBRAB,"@"),$PIECE($PIECE(DDBRAB,"@",2),"#"))
+9 IF DDBRATR=""
Begin DoDot:2
+10 SET DDBRAAH=""
+11 IF $GET(DIERR)
SET DIERM=$$CTXT^DDBR($GET(^TMP("DIERR",$JOB,+DIERR,"TEXT",1)))
+12 KILL DIERR,^TMP("DIERR",$JOB)
+13 QUIT
End DoDot:2
QUIT
+14 SET DDBRANRT=$$NROOT^DDBRAP(DDBRATR)
+15 IF '$DATA(@DDBRANRT)
DO WP^DDBRAP(DDBRATR)
+16 SET DDBLSTN=$SELECT($DATA(@DDBLST@("A",DDBSA)):^(DDBSA),1:$ORDER(@DDBLST@(" "),-1)+1)
+17 DO SAVEDDB^DDBR2(DDBLST,DDBLSTN,1)
DO SET
+18 SET DDBRSET=0
+19 SET DDBRAAH=$PIECE(DDBRAAH,"#",2)
SET DDBRAFLG=1
+20 SET DDBSA=DDBRATR
SET DDBSAN=DDBRANRT
+21 SET DDBPMSG=$GET(@DDBSAN@("TITLE"))
if DDBPMSG=""
SET DDBPMSG="HYPERTEXT JUMP ID#"_$ORDER(@DDBLST@("J",""),-1)+1
+22 DO SAVSET
+23 QUIT
End DoDot:1
GOTO STKPT
+24 ;jump to another entry in the same file, same level
+25 IF DDBRAAH["#"
IF $PIECE(DDBRAAH,"#")]""
Begin DoDot:1
+26 NEW DDBRAB,DDBRABR,DDBRAIEN,DDBLSTN,DDBRALEV,DDBRANRT
+27 SET DDBRAB=$PIECE(DDBRAAH,"#")
+28 IF DDBRAB=""
SET DDBRAAH=""
QUIT
+29 SET DDBRALEV=""
SET DDBRABR=$$IENROOT^DDBRAP($NAME(@DDBSA),.DDBRALEV)
+30 SET DDBRAIEN=$ORDER(@DDBRABR@("B",DDBRAB,""))
+31 IF 'DDBRAIEN
SET DDBRAAH=""
QUIT
+32 SET DDBRANRT=$$NROOT^DDBRAP($NAME(@DDBRABR@(DDBRAIEN,DDBRALEV)))
+33 IF '$DATA(@DDBRANRT)
DO WP^DDBRAP($NAME(@DDBRABR@(DDBRAIEN,DDBRALEV)))
+34 SET DDBLSTN=$SELECT($DATA(@DDBLST@("A",DDBSA)):^(DDBSA),1:$ORDER(@DDBLST@(" "),-1)+1)
+35 DO SAVEDDB^DDBR2(DDBLST,DDBLSTN,1)
DO SET
+36 SET DDBRSET=0
+37 SET DDBRAAH=$PIECE(DDBRAAH,"#",2)
SET DDBRAFLG=1
+38 SET DDBSA=$NAME(@DDBRABR@(DDBRAIEN,DDBRALEV))
+39 SET DDBSAN=DDBRANRT
+40 SET DDBPMSG=$GET(@DDBSAN@("TITLE"))
if DDBPMSG=""
SET DDBPMSG="HYPERTEXT JUMP ID#"_$ORDER(@DDBLST@("J",""),-1)+1
+41 DO SAVSET
+42 QUIT
End DoDot:1
STKPT if DDBRAAH["#"
SET DDBRAAH=$PIECE(DDBRAAH,"#",2)
+1 IF DDBRAAH]""
SET DDBRAHA=$GET(@DDBSAN@("A",DDBRAAH))
+2 IF DDBRSET
IF $GET(DDBRAHA)'>0
DO NOHTJ($GET(DIERM))
GOTO PS^DDBR2
+3 SET DDBRAHL=$SELECT($GET(DDBRAHA):DDBRAHA+DDBSRL-1,1:0)
+4 if DDBRSET
DO SET
DO GOTO
QUIT
+5 QUIT
+6 ;
SET ; set and save jump info
+1 SET DDBRAHP=$ORDER(@DDBLST@("J",""),-1)+1
+2 SET @DDBLST@("J",DDBRAHP)=DDBSA_DDGLDEL_DDBL_"^"_+$GET(DDBLSTN)_DDGLDEL_DDBRHT
+3 QUIT
+4 ;
GOTO ; jump to line in current document
+1 SET DDBL=$SELECT(DDBRAHL'>DDBSRL:0,DDBRAHL>DDBTL:DDBTL,1:DDBRAHL)
DO PSR^DDBR0(+$GET(DDBRAFLG))
+2 QUIT
BCK ; backward
+1 if '$DATA(@DDBLST@("J"))
QUIT
+2 NEW DDBX,DDBY,DDBRAFLG
+3 SET DDBX=$ORDER(@DDBLST@("J",""),-1)
SET DDBY=@DDBLST@("J",DDBX)
+4 KILL @DDBLST@("J",DDBX)
+5 IF $PIECE(DDBY,DDGLDEL)'=DDBSA
Begin DoDot:1
+6 DO USAVEDDB^DDBR2(DDBLST,$PIECE($PIECE(DDBY,DDGLDEL,2),"^",2))
End DoDot:1
SET DDBRAFLG=1
+7 SET DDBL=+$PIECE(DDBY,DDGLDEL,2)
SET DDBRHT=$PIECE(DDBY,DDGLDEL,3,255)
+8 DO PSR^DDBR0(+$GET(DDBRAFLG))
+9 QUIT
CHKI() ;return 1 if ok 0 not ok to continue also init DDBRHT if undefined
+1 SET DDBRHT=$GET(DDBRHT)
+2 if DDBRHT=""
QUIT 0
+3 IF $PIECE(DDBRHT,DDGLDEL,4)'=DDBSA
QUIT 0
+4 IF +DDBRHT>DDBL
QUIT 0
+5 IF +DDBRHT<($SELECT(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1)
QUIT 0
+6 QUIT 1
+7 ;
NOHTJ(EM) ; no hypertext jump available
+1 NEW X,Y
+2 SET Y=$PIECE(DDBSANX,"^",$SELECT(DDBSANX["$CREF$":$LENGTH(DDBSANX,"^"),1:2))
SET X(1)=$$CTXT^DDBR(Y,"",IOM)
SET EM=$GET(EM)
if $PIECE(EM,"Error
SET EM="<< "_$PIECE(EM,"Error:",2)_" >>"
+3 SET X(2)=""
+4 ;**NO HYPERTEXT JUMP
SET X(3)=$$CTXT^DDBR($SELECT(EM]"":EM,1:"<< "_$$EZBLD^DIALOG(7077)_" >>"),"",IOM)
+5 WRITE $$WS^DDBR1(.X),$CHAR(7)
+6 READ X:5
+7 QUIT
+8 ;
SAVSET ;
+1 SET DDBHDR=$$CTXT^DDBR(DDBPMSG,$JUSTIFY("",IOM+1),IOM)
+2 SET DDBTL=$PIECE($GET(@DDBSA@(0)),"^",3)
if DDBTL'>0
SET DDBTL=$ORDER(@DDBSA@(" "),-1)
+3 SET DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
+4 SET DDBZN=$DATA(@DDBSA@(DDBTL,0))#2
+5 SET DDBDM=0
+6 SET DDBSF=1
+7 SET DDBST=IOM
+8 SET DDBC=$NAME(^TMP("DDBC","DDBC",$JOB))
+9 IF '$DATA(@DDBC)
FOR I=1,22:22:176
SET @DDBC@(I)=""
+10 QUIT
