DDS2 ;SFISC/MLH-UP ARROW JUMP, BRANCH ;2015-01-02 4:52 PM
;;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.
;
;
MOUSE ;Mouse has clicked: DDSMX=$X,DDSMY=$Y
N DDSBO,P,DDS2O,%
S DDACT="N",DDSMOUSY=1,DDS2O=DDO,DDSBO=DDSBK
S X="" F S X=$O(DDSMOUSE(DDSMY,X)) Q:X=""!(X>DDSMX) S P=$O(DDSMOUSE(DDSMY,X,"")) I P'<DDSMX S X=$G(DDSMOUSE(DDSMY,X,P)) Q:X="" D S:X'[U X=X_"^DDS01" G @X
.;If they've clicked "+" on a different block, just go to that block
.I X="NP"!(X="PP") N B S P=$$FINDXY(DDSMY,DDSMX+1),B=$P(P,",",2) I B,B-DDSBO S DDSMX=DDSMX+1,X="F^DDS2"
I DDSMY+1=IOSL G OUT ;They clicked on COMMAND LINE
F S X=$$FINDXY(DDSMY,DDSMX) Q:'X
I $L(X,",")<4 S DDO=X,DDS2X="" D DDO S:DDSBK-DDSBO DDACT="NB" Q ;Going to single-valued field might mean leaving this block
N D,B,DDSCL,DDSDDO,DDSNR,DDSPDA,DDSSN,DDSSTL ;Going to a multiple...
S DDSCL=$P(X,",",4)
I $P(X,",",2)=DDSBK,$D(DDSREP),$P(DDSREP,U,3)=DDSCL S DDO=$P(X,",",1,3),DDS2X="" D DDO Q ;We clicked on a Field in the current multiple
S P=$P(X,",",3),B=$P(X,",",2),DDSDDO=+X
I B'=DDSBK S D=@DDSREFT@(P,B),DDSREP=$P(^(B,D),U,2,99),DDSBK=B
S DDSPDA=$P(DDSREP,U),DDSSTL=$P(DDSREP,U,2),DDSSN=DDSSTL-1+DDSCL
S X=DDSDA M %=DA N DDSDA,DA S DDSDA=X M DA=% ;We want the current DA & DDSDA to come back after we leave the multiple we're gonna enter!
D MDA^DDSM S DDACT="NB",DDSBR="" ;Fake out 1^DDS
Q
;
FINDXY(DY,DX) ;Find Field that is at mouseclick position
N F,B,Z,CAP,HITE,REP,TOP,D,ABOVE,PYX,PY
S PYX=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,3) Q:'PYX ;Page co-ords --must be added to Block's!
F B=0:0 S B=$O(@DDSREFS@(DDSPG,B)) Q:'B D Q:$G(Z)
.Q:'$D(^DIST(.403,+DDS,40,DDSPG,40,B,0))
.S REP=$G(^(2)),TOP=$P($G(^(0)),U,3)+PYX-1 I DY+1<TOP!($P(^(0),U,4)'="e") Q ;Click is above this Block, or Block's not editable
.I REP<2 D DX(DY) Q ;NON-REPEATING BLOCK May return Z
.S HITE=$$HITE^DDSR(B),D=$G(@DDSREFT@(DDSPG,B)) Q:D=""!'HITE
.S ABOVE=$P($G(^(B,D)),U,3)-1 Q:ABOVE<0
.S PY=$P(PYX,",",2)-1
.F F=0:0 S F=$O(^DIST(.404,B,40,F)) Q:'F D I $D(Z) S Z=F_","_B_","_DDSPG_","_Z Q
..S S=$P($P($G(^(F,2)),U),",",2) Q:'S S S=S+PY Q:S+$P(^(2),U,2)-2<DX ;Click is to the right of data
..I DX+1<S S CAP=$P($P(^(2),U,3),",",2) Q:'CAP S CAP=CAP+PY Q:CAP-1>DX ;Click is to the left of Caption
..S S=^(2)+TOP-2 ;$Y OF THE FIRST MULTIPLE for this Field
..S S=DY-S+HITE/HITE Q:S<1!(S[".")!(S>REP) ;Can't click above or below the window
..I $D(@DDSREFT@(DDSPG,B,D,S+ABOVE)) S Z=S Q ;Z IS THE LINE MUST BE OFFSET BY NUMBER OF ONES ABOVE!
..I $P(@DDSREFS@(DDSPG,B),U,9)'=F Q ;Must go to 1st field of new multiple
..I S=1!$D(@DDSREFT@(DDSPG,B,D,S-1+ABOVE)) S Z=S
Q $G(Z) ;Returns FIELD,BLOCK,PAGE,DDSCL
;
DX(DY) F F=0:0 S F=$O(@DDSREFS@(DDSPG,B,F)) Q:'F I $D(^(F,"N")),+$G(^("D"))=DY D Q:$G(Z)
.I $P(@DDSREFS@(DDSPG,B,F,"D"),U,2)+$P(^("D"),U,3)'>DX Q ;Click is to the right of data
.I DX<$P(^("D"),U,2) Q:'$G(^DIST(.404,B,40,F,2)) S CAP=$P($P(^(2),U,3),",",2) Q:'CAP Q:CAP-1>DX ;Click is to the left of Caption
.S Z=F_","_B_","_DDSPG
Q
;
NP ;from indirect GO in MOUSE+3, above
S DDACT="NP" G NP^DDS01
;
;
UPA ;Up-arrow jump
Q:$E(X)'=U
I X?1"^"1.E,X'="^^",$G(DDSDN) D MSG^DDSMSG($$EZBLD^DIALOG(3096),1) Q ;**
I X?1"^"1.E,X'="^^" D JMP Q
;
;Up-arrow only
OUT I 'DDO D E^DDS3 Q
I $D(DDSREP),DA D POSTACT D:$D(DDSBR)[0 END^DDSM Q
I $G(DDSDN)=1 D MSG^DDSMSG($$EZBLD^DIALOG(3095),1) Q ;**
D POSTACT S:$D(DDSBR)[0 DDSOSV=DDO,DDO=0 Q
Q
;
POSTACT ;Execute post action
Q:$G(DDSO(12))?." "
N X
S X=$G(DDSOLD) X DDSO(12)
D:$D(DDSBR)#2 BR
Q
;
JMP ;Up-arrow jump
S DDS2X=X,X=$P(X,U,2) I X="" W $C(7) G KILL
K DDH,DDQ S DDH=0
S (X,DDSX)=$$UPCASE($E(X,1,63))
;
;Find exact matches
D:$D(@DDSREFS@("CAP",X)) CAP
D:$D(@DDSREFT@("XCAP",DDSPG,X)) XCAP
;
;Find partial matches
S:X="?" (X,DDSX)=""
F S DDSX=$O(@DDSREFS@("CAP",DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D CAP
S DDSX=X F S DDSX=$O(@DDSREFT@("XCAP",DDSPG,DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D XCAP
;
NO I 'DDH D MSG^DDSMSG($$EZBLD^DIALOG(3098,$P(DDS2X,U,2)),1) G KILL ;**
S DDS2O=DDO
I DDH=1 S DDO=$O(DDH(DDH,""))
E S DDD="J" D SC^DDSU
DDO ;DDO=FIELD,BLOCK,PAGE
S DDS2B=$P(DDO,",",2),DDS2P=$P(DDO,",",3),DDO=+DDO
G:'DDS2B KILL
;
S DDS2DA=DDSDA
I DDS2P'=DDSPG D ;Different Page
. D:'$D(@DDSREFT@(DDS2P,DDS2B)) EN^DDS1(DDS2P)
. S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
. I DDS2DA="" D
.. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
.. S DDO=DDS2O
. E D CKUNED D:'$G(DDS2UNED)
.. D POSTACT
.. S:$D(DDSBR)[0 DDACT="NP",DDSPG=DDS2P,DDSBK=DDS2B,DDSBR="" ;Set the new page
;
E I DDS2B'=DDSBK D ;Different Block
. S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
. I DDS2DA="" D
.. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
.. S DDO=DDS2O
. E I $P($G(@DDSREFS@(DDS2P,DDS2B)),U,4) D
.. D MSG^DDSMSG($C(7)_$P($T(ERR1),";;",2))
.. S DDO=DDS2O
. E D CKUNED D:'$G(DDS2UNED)
.. D POSTACT
.. S:$D(DDSBR)[0 DDACT="NB",DDSBK=DDS2B,DDSBR="" ;Set the new Block
;
E D CKUNED D:'$G(DDS2UNED)
. D POSTACT
. S:$D(DDSBR)[0 DDACT="N"
;
KILL S X=DDS2X
K DDH,DDSI,DDSPGRP,DDSX
K DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X
Q
;
CKUNED ;Check uneditable status
N DDP,DDSFLD
;
I $P($G(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2 D
. S DDP=0
. S DDSFLD=+DDO_","_DDS2B
E D
. S DDP=$P($G(@DDSREFS@(DDS2P,DDS2B)),U,3)
. S DDSFLD=$P($G(^DIST(.404,DDS2B,40,+DDO,1)),U)
I 'DDSFLD S DDS2UNED=1,DDO=DDS2O Q
S DDS2ATT=$P($G(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4)
;
I DDO,$S(DDS2ATT="":$P($G(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1),'$P(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11) D
UNED .S DDS2UNED=$P(^DIST(.404,DDS2B,40,+DDO,0),U,2) I DDS2UNED="" S DDS2UNED=$P(^(0),U,5) I DDS2UNED="",$G(^(1)),$D(^DD(DDP,^(1),0)) S DDS2UNED=$P(^(0),U)
.D MSG^DDSMSG($$EZBLD^DIALOG(3090,DDS2UNED),1) ;**FIELD is UNEDITABLE!
.S DDS2UNED=1,DDO=DDS2O
Q
;
CAP ;Find all captions that match DDSX
S DDSPGRP="" F S DDSPGRP=$O(@DDSREFS@("CAP",DDSX,DDSPGRP)) Q:DDSPGRP="" D
. Q:U_DDSPGRP_U'[(U_DDSPG_U)
. S DDS2P="" F S DDS2P=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P)) Q:'DDS2P D
.. S DDS2B="" F S DDS2B=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B)) Q:'DDS2B D
... S DDS2F="" F S DDS2F=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F)) Q:'DDS2F D FILL
Q
;
XCAP ;Find all xecutable captions that match DDSX
S DDS2P=DDSPG
S DDS2B=0 F S DDS2B=$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B)) Q:'DDS2B D
. S DDS2F=0 F S DDS2F=+$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B,DDS2F)) Q:'DDS2F D
.. I $D(^DIST(.404,DDS2B,40,DDS2F,0))#2,$P(^(0),U,3)'=1 D FILL
Q
;
FILL ;Fill DDH array with possible choices
S DDS2V=DDSX_$S($P(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
S:DDS2P'=DDSPG DDS2V=DDS2V_" ("_$S($P($G(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))_")"
S DDH=DDH+1,DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V
K DDS2V
Q
;
BR ;Evaluate DDSBR
N B,B1,F,F1,P,P1,E,X Q:$D(DDSBR)[0 I DDSBR="QUIT" S DDACT="Q" Q ;**
S P=$P($G(DDSOPB),U),B=$P($G(DDSOPB),U,2),F=$G(DDO),E=1
S:'B B=+$P(@DDSREFS@(+P,"FIRST"),",",2)
S P1=$P(DDSBR,U,3),B1=$P(DDSBR,U,2),F1=$P(DDSBR,U)
;
D @$S(P1]"":"PG",B1]"":"BK",1:"FD")
S:'E DDACT=$S(P'=+DDSOPB:"NP",B'=$P(DDSOPB,U,2):"NB",1:"N"),DDSPG=P,DDSBK=B,DDO=F
K:E DDSBR
Q
;
PG ;
I P1=+$P(P1,"E") S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
E S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),""))
Q:'P
S:B1="" B1=$O(^DIST(.403,+DDS,40,P,40,"AC","")) Q:B1=""
BK ;
I B1=+$P(B1,"E") D
. S B=$O(^DIST(.403,+DDS,40,P,40,"AC",B1,""))
E D
. S B=$O(^DIST(.404,"B",B1,"")) Q:B=""
. S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
Q:'B
S:F1="" F1=$O(^DIST(.404,B,40,"B",""))
FD ;
Q:F1=""
I F1="COM" S (E,F)=0 Q
I F1=+$P(F1,"E") S X="B"
E S F1=$$UPCASE(F1),X=$S($D(^DIST(.404,B,40,"D",F1)):"D",1:"C")
S F=$O(^DIST(.404,B,40,X,F1,""))
S:F E=0
Q
;
UPCASE(X) ;
;Return X in uppercase
Q $$UP^DILIBF(X) ;**
;
ERR ;;Unable to jump to that field. The block on which that field is located has no record associated with it.
;
ERR1 ;;Unable to jump to that field. The block on which that field is located has navigation disabled.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS2 8478 printed Dec 13, 2024@02:43:04 Page 2
DDS2 ;SFISC/MLH-UP ARROW JUMP, BRANCH ;2015-01-02 4:52 PM
+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 ;
MOUSE ;Mouse has clicked: DDSMX=$X,DDSMY=$Y
+1 NEW DDSBO,P,DDS2O,%
+2 SET DDACT="N"
SET DDSMOUSY=1
SET DDS2O=DDO
SET DDSBO=DDSBK
+3 SET X=""
FOR
SET X=$ORDER(DDSMOUSE(DDSMY,X))
if X=""!(X>DDSMX)
QUIT
SET P=$ORDER(DDSMOUSE(DDSMY,X,""))
IF P'<DDSMX
SET X=$GET(DDSMOUSE(DDSMY,X,P))
if X=""
QUIT
Begin DoDot:1
+4 ;If they've clicked "+" on a different block, just go to that block
+5 IF X="NP"!(X="PP")
NEW B
SET P=$$FINDXY(DDSMY,DDSMX+1)
SET B=$PIECE(P,",",2)
IF B
IF B-DDSBO
SET DDSMX=DDSMX+1
SET X="F^DDS2"
End DoDot:1
if X'[U
SET X=X_"^DDS01"
GOTO @X
+6 ;They clicked on COMMAND LINE
IF DDSMY+1=IOSL
GOTO OUT
F SET X=$$FINDXY(DDSMY,DDSMX)
if 'X
QUIT
+1 ;Going to single-valued field might mean leaving this block
IF $LENGTH(X,",")<4
SET DDO=X
SET DDS2X=""
DO DDO
if DDSBK-DDSBO
SET DDACT="NB"
QUIT
+2 ;Going to a multiple...
NEW D,B,DDSCL,DDSDDO,DDSNR,DDSPDA,DDSSN,DDSSTL
+3 SET DDSCL=$PIECE(X,",",4)
+4 ;We clicked on a Field in the current multiple
IF $PIECE(X,",",2)=DDSBK
IF $DATA(DDSREP)
IF $PIECE(DDSREP,U,3)=DDSCL
SET DDO=$PIECE(X,",",1,3)
SET DDS2X=""
DO DDO
QUIT
+5 SET P=$PIECE(X,",",3)
SET B=$PIECE(X,",",2)
SET DDSDDO=+X
+6 IF B'=DDSBK
SET D=@DDSREFT@(P,B)
SET DDSREP=$PIECE(^(B,D),U,2,99)
SET DDSBK=B
+7 SET DDSPDA=$PIECE(DDSREP,U)
SET DDSSTL=$PIECE(DDSREP,U,2)
SET DDSSN=DDSSTL-1+DDSCL
+8 ;We want the current DA & DDSDA to come back after we leave the multiple we're gonna enter!
SET X=DDSDA
MERGE %=DA
NEW DDSDA,DA
SET DDSDA=X
MERGE DA=%
+9 ;Fake out 1^DDS
DO MDA^DDSM
SET DDACT="NB"
SET DDSBR=""
+10 QUIT
+11 ;
FINDXY(DY,DX) ;Find Field that is at mouseclick position
+1 NEW F,B,Z,CAP,HITE,REP,TOP,D,ABOVE,PYX,PY
+2 ;Page co-ords --must be added to Block's!
SET PYX=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U,3)
if 'PYX
QUIT
+3 FOR B=0:0
SET B=$ORDER(@DDSREFS@(DDSPG,B))
if 'B
QUIT
Begin DoDot:1
+4 if '$DATA(^DIST(.403,+DDS,40,DDSPG,40,B,0))
QUIT
+5 ;Click is above this Block, or Block's not editable
SET REP=$GET(^(2))
SET TOP=$PIECE($GET(^(0)),U,3)+PYX-1
IF DY+1<TOP!($PIECE(^(0),U,4)'="e")
QUIT
+6 ;NON-REPEATING BLOCK May return Z
IF REP<2
DO DX(DY)
QUIT
+7 SET HITE=$$HITE^DDSR(B)
SET D=$GET(@DDSREFT@(DDSPG,B))
if D=""!'HITE
QUIT
+8 SET ABOVE=$PIECE($GET(^(B,D)),U,3)-1
if ABOVE<0
QUIT
+9 SET PY=$PIECE(PYX,",",2)-1
+10 FOR F=0:0
SET F=$ORDER(^DIST(.404,B,40,F))
if 'F
QUIT
Begin DoDot:2
+11 ;Click is to the right of data
SET S=$PIECE($PIECE($GET(^(F,2)),U),",",2)
if 'S
QUIT
SET S=S+PY
if S+$PIECE(^(2),U,2)-2<DX
QUIT
+12 ;Click is to the left of Caption
IF DX+1<S
SET CAP=$PIECE($PIECE(^(2),U,3),",",2)
if 'CAP
QUIT
SET CAP=CAP+PY
if CAP-1>DX
QUIT
+13 ;$Y OF THE FIRST MULTIPLE for this Field
SET S=^(2)+TOP-2
+14 ;Can't click above or below the window
SET S=DY-S+HITE/HITE
if S<1!(S[".")!(S>REP)
QUIT
+15 ;Z IS THE LINE MUST BE OFFSET BY NUMBER OF ONES ABOVE!
IF $DATA(@DDSREFT@(DDSPG,B,D,S+ABOVE))
SET Z=S
QUIT
+16 ;Must go to 1st field of new multiple
IF $PIECE(@DDSREFS@(DDSPG,B),U,9)'=F
QUIT
+17 IF S=1!$DATA(@DDSREFT@(DDSPG,B,D,S-1+ABOVE))
SET Z=S
End DoDot:2
IF $DATA(Z)
SET Z=F_","_B_","_DDSPG_","_Z
QUIT
End DoDot:1
if $GET(Z)
QUIT
+18 ;Returns FIELD,BLOCK,PAGE,DDSCL
QUIT $GET(Z)
+19 ;
DX(DY) FOR F=0:0
SET F=$ORDER(@DDSREFS@(DDSPG,B,F))
if 'F
QUIT
IF $DATA(^(F,"N"))
IF +$GET(^("D"))=DY
Begin DoDot:1
+1 ;Click is to the right of data
IF $PIECE(@DDSREFS@(DDSPG,B,F,"D"),U,2)+$PIECE(^("D"),U,3)'>DX
QUIT
+2 ;Click is to the left of Caption
IF DX<$PIECE(^("D"),U,2)
if '$GET(^DIST(.404,B,40,F,2))
QUIT
SET CAP=$PIECE($PIECE(^(2),U,3),",",2)
if 'CAP
QUIT
if CAP-1>DX
QUIT
+3 SET Z=F_","_B_","_DDSPG
End DoDot:1
if $GET(Z)
QUIT
+4 QUIT
+5 ;
NP ;from indirect GO in MOUSE+3, above
+1 SET DDACT="NP"
GOTO NP^DDS01
+2 ;
+3 ;
UPA ;Up-arrow jump
+1 if $EXTRACT(X)'=U
QUIT
+2 ;**
IF X?1"^"1.E
IF X'="^^"
IF $GET(DDSDN)
DO MSG^DDSMSG($$EZBLD^DIALOG(3096),1)
QUIT
+3 IF X?1"^"1.E
IF X'="^^"
DO JMP
QUIT
+4 ;
+5 ;Up-arrow only
OUT IF 'DDO
DO E^DDS3
QUIT
+1 IF $DATA(DDSREP)
IF DA
DO POSTACT
if $DATA(DDSBR)[0
DO END^DDSM
QUIT
+2 ;**
IF $GET(DDSDN)=1
DO MSG^DDSMSG($$EZBLD^DIALOG(3095),1)
QUIT
+3 DO POSTACT
if $DATA(DDSBR)[0
SET DDSOSV=DDO
SET DDO=0
QUIT
+4 QUIT
+5 ;
POSTACT ;Execute post action
+1 if $GET(DDSO(12))?." "
QUIT
+2 NEW X
+3 SET X=$GET(DDSOLD)
XECUTE DDSO(12)
+4 if $DATA(DDSBR)#2
DO BR
+5 QUIT
+6 ;
JMP ;Up-arrow jump
+1 SET DDS2X=X
SET X=$PIECE(X,U,2)
IF X=""
WRITE $CHAR(7)
GOTO KILL
+2 KILL DDH,DDQ
SET DDH=0
+3 SET (X,DDSX)=$$UPCASE($EXTRACT(X,1,63))
+4 ;
+5 ;Find exact matches
+6 if $DATA(@DDSREFS@("CAP",X))
DO CAP
+7 if $DATA(@DDSREFT@("XCAP",DDSPG,X))
DO XCAP
+8 ;
+9 ;Find partial matches
+10 if X="?"
SET (X,DDSX)=""
+11 FOR
SET DDSX=$ORDER(@DDSREFS@("CAP",DDSX))
if DDSX=""!($PIECE(DDSX,X)]"")
QUIT
DO CAP
+12 SET DDSX=X
FOR
SET DDSX=$ORDER(@DDSREFT@("XCAP",DDSPG,DDSX))
if DDSX=""!($PIECE(DDSX,X)]"")
QUIT
DO XCAP
+13 ;
NO ;**
IF 'DDH
DO MSG^DDSMSG($$EZBLD^DIALOG(3098,$PIECE(DDS2X,U,2)),1)
GOTO KILL
+1 SET DDS2O=DDO
+2 IF DDH=1
SET DDO=$ORDER(DDH(DDH,""))
+3 IF '$TEST
SET DDD="J"
DO SC^DDSU
DDO ;DDO=FIELD,BLOCK,PAGE
+1 SET DDS2B=$PIECE(DDO,",",2)
SET DDS2P=$PIECE(DDO,",",3)
SET DDO=+DDO
+2 if 'DDS2B
GOTO KILL
+3 ;
+4 SET DDS2DA=DDSDA
+5 ;Different Page
IF DDS2P'=DDSPG
Begin DoDot:1
+6 if '$DATA(@DDSREFT@(DDS2P,DDS2B))
DO EN^DDS1(DDS2P)
+7 SET DDS2DA=@DDSREFT@(DDS2P,DDS2B)
+8 IF DDS2DA=""
Begin DoDot:2
+9 DO MSG^DDSMSG($CHAR(7)_$PIECE($TEXT(ERR),";;",2))
+10 SET DDO=DDS2O
End DoDot:2
+11 IF '$TEST
DO CKUNED
if '$GET(DDS2UNED)
Begin DoDot:2
+12 DO POSTACT
+13 ;Set the new page
if $DATA(DDSBR)[0
SET DDACT="NP"
SET DDSPG=DDS2P
SET DDSBK=DDS2B
SET DDSBR=""
End DoDot:2
End DoDot:1
+14 ;
+15 ;Different Block
IF '$TEST
IF DDS2B'=DDSBK
Begin DoDot:1
+16 SET DDS2DA=@DDSREFT@(DDS2P,DDS2B)
+17 IF DDS2DA=""
Begin DoDot:2
+18 DO MSG^DDSMSG($CHAR(7)_$PIECE($TEXT(ERR),";;",2))
+19 SET DDO=DDS2O
End DoDot:2
+20 IF '$TEST
IF $PIECE($GET(@DDSREFS@(DDS2P,DDS2B)),U,4)
Begin DoDot:2
+21 DO MSG^DDSMSG($CHAR(7)_$PIECE($TEXT(ERR1),";;",2))
+22 SET DDO=DDS2O
End DoDot:2
+23 IF '$TEST
DO CKUNED
if '$GET(DDS2UNED)
Begin DoDot:2
+24 DO POSTACT
+25 ;Set the new Block
if $DATA(DDSBR)[0
SET DDACT="NB"
SET DDSBK=DDS2B
SET DDSBR=""
End DoDot:2
End DoDot:1
+26 ;
+27 IF '$TEST
DO CKUNED
if '$GET(DDS2UNED)
Begin DoDot:1
+28 DO POSTACT
+29 if $DATA(DDSBR)[0
SET DDACT="N"
End DoDot:1
+30 ;
KILL SET X=DDS2X
+1 KILL DDH,DDSI,DDSPGRP,DDSX
+2 KILL DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X
+3 QUIT
+4 ;
CKUNED ;Check uneditable status
+1 NEW DDP,DDSFLD
+2 ;
+3 IF $PIECE($GET(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2
Begin DoDot:1
+4 SET DDP=0
+5 SET DDSFLD=+DDO_","_DDS2B
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET DDP=$PIECE($GET(@DDSREFS@(DDS2P,DDS2B)),U,3)
+8 SET DDSFLD=$PIECE($GET(^DIST(.404,DDS2B,40,+DDO,1)),U)
End DoDot:1
+9 IF 'DDSFLD
SET DDS2UNED=1
SET DDO=DDS2O
QUIT
+10 SET DDS2ATT=$PIECE($GET(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4)
+11 ;
+12 IF DDO
IF $SELECT(DDS2ATT="":$PIECE($GET(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1)
IF '$PIECE(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11)
Begin DoDot:1
UNED SET DDS2UNED=$PIECE(^DIST(.404,DDS2B,40,+DDO,0),U,2)
IF DDS2UNED=""
SET DDS2UNED=$PIECE(^(0),U,5)
IF DDS2UNED=""
IF $GET(^(1))
IF $DATA(^DD(DDP,^(1),0))
SET DDS2UNED=$PIECE(^(0),U)
+1 ;**FIELD is UNEDITABLE!
DO MSG^DDSMSG($$EZBLD^DIALOG(3090,DDS2UNED),1)
+2 SET DDS2UNED=1
SET DDO=DDS2O
End DoDot:1
+3 QUIT
+4 ;
CAP ;Find all captions that match DDSX
+1 SET DDSPGRP=""
FOR
SET DDSPGRP=$ORDER(@DDSREFS@("CAP",DDSX,DDSPGRP))
if DDSPGRP=""
QUIT
Begin DoDot:1
+2 if U_DDSPGRP_U'[(U_DDSPG_U)
QUIT
+3 SET DDS2P=""
FOR
SET DDS2P=$ORDER(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P))
if 'DDS2P
QUIT
Begin DoDot:2
+4 SET DDS2B=""
FOR
SET DDS2B=$ORDER(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B))
if 'DDS2B
QUIT
Begin DoDot:3
+5 SET DDS2F=""
FOR
SET DDS2F=$ORDER(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F))
if 'DDS2F
QUIT
DO FILL
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
XCAP ;Find all xecutable captions that match DDSX
+1 SET DDS2P=DDSPG
+2 SET DDS2B=0
FOR
SET DDS2B=$ORDER(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B))
if 'DDS2B
QUIT
Begin DoDot:1
+3 SET DDS2F=0
FOR
SET DDS2F=+$ORDER(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B,DDS2F))
if 'DDS2F
QUIT
Begin DoDot:2
+4 IF $DATA(^DIST(.404,DDS2B,40,DDS2F,0))#2
IF $PIECE(^(0),U,3)'=1
DO FILL
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
FILL ;Fill DDH array with possible choices
+1 SET DDS2V=DDSX_$SELECT($PIECE(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$PIECE(^(0),U,4)_")",1:"")
+2 if DDS2P'=DDSPG
SET DDS2V=DDS2V_" ("_$SELECT($PIECE($GET(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$PIECE(^(1),U),1:"Page "_$PIECE(^(0),U))_")"
+3 SET DDH=DDH+1
SET DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V
+4 KILL DDS2V
+5 QUIT
+6 ;
BR ;Evaluate DDSBR
+1 ;**
NEW B,B1,F,F1,P,P1,E,X
if $DATA(DDSBR)[0
QUIT
IF DDSBR="QUIT"
SET DDACT="Q"
QUIT
+2 SET P=$PIECE($GET(DDSOPB),U)
SET B=$PIECE($GET(DDSOPB),U,2)
SET F=$GET(DDO)
SET E=1
+3 if 'B
SET B=+$PIECE(@DDSREFS@(+P,"FIRST"),",",2)
+4 SET P1=$PIECE(DDSBR,U,3)
SET B1=$PIECE(DDSBR,U,2)
SET F1=$PIECE(DDSBR,U)
+5 ;
+6 DO @$SELECT(P1]"":"PG",B1]"":"BK",1:"FD")
+7 if 'E
SET DDACT=$SELECT(P'=+DDSOPB:"NP",B'=$PIECE(DDSOPB,U,2):"NB",1:"N")
SET DDSPG=P
SET DDSBK=B
SET DDO=F
+8 if E
KILL DDSBR
+9 QUIT
+10 ;
PG ;
+1 IF P1=+$PIECE(P1,"E")
SET P=$ORDER(^DIST(.403,+DDS,40,"B",P1,""))
+2 IF '$TEST
SET P=$ORDER(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),""))
+3 if 'P
QUIT
+4 if B1=""
SET B1=$ORDER(^DIST(.403,+DDS,40,P,40,"AC",""))
if B1=""
QUIT
BK ;
+1 IF B1=+$PIECE(B1,"E")
Begin DoDot:1
+2 SET B=$ORDER(^DIST(.403,+DDS,40,P,40,"AC",B1,""))
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 SET B=$ORDER(^DIST(.404,"B",B1,""))
if B=""
QUIT
+5 SET B=$ORDER(^DIST(.403,+DDS,40,P,40,"B",B,""))
End DoDot:1
+6 if 'B
QUIT
+7 if F1=""
SET F1=$ORDER(^DIST(.404,B,40,"B",""))
FD ;
+1 if F1=""
QUIT
+2 IF F1="COM"
SET (E,F)=0
QUIT
+3 IF F1=+$PIECE(F1,"E")
SET X="B"
+4 IF '$TEST
SET F1=$$UPCASE(F1)
SET X=$SELECT($DATA(^DIST(.404,B,40,"D",F1)):"D",1:"C")
+5 SET F=$ORDER(^DIST(.404,B,40,X,F1,""))
+6 if F
SET E=0
+7 QUIT
+8 ;
UPCASE(X) ;
+1 ;Return X in uppercase
+2 ;**
QUIT $$UP^DILIBF(X)
+3 ;
ERR ;;Unable to jump to that field. The block on which that field is located has no record associated with it.
+1 ;
ERR1 ;;Unable to jump to that field. The block on which that field is located has navigation disabled.
