ROUTINE DIDH

Entryref POINT^DIDH

CALLED BY ^DD(1,.01,"DEL",.5,0) -- "DEL" node of FILE of FILEs (File#1) field NAME (field#.01)

lvn DIC == "^DIC"

CALLED FROM PAGE1+34^DIDH1

lvn DIC == global root of file or subfile

when double loop active

sometimes WRITE text

when loop finishes

sometimes init lvn DG == -1

sometimes init lvn X == -1

sometimes KILLs lvn W1

sometimes KILLs lvn DOPT

when loop stopped by undef lvn DIU

sometimes KILLs DDV

sometimes KILLs %F

sometimes KILLs M1

QUIT

Code

POINT ; CALLED BY ^DD(1,.01,"DEL",.5,0)

S W1="W:$Y ! W !,""POINTED TO BY: "",?15" I $O(^DD(DA,0,"PT",""))'="" S DDPT=1

S X="" F S X=$O(^DD(DA,0,"PT",X)) Q:X="" S DG=0 F S DG=$O(^DD(DA,0,"PT",X,DG)) Q:DG="" D PD W:$D(^DD(DA,0,"PT",X,DG)) !?15 I '$D(DIU) D H G Q:M=U

S (DG,X)=-1 K W1,DDPT Q

TAG POINT^DIDH

FALLSTHRU none

INPUT VARS

lvn DA == DDnumber

$ORDER(^DD(DA,0,"PT","")) -- what files point at this one.

OUTPUT VARS

sometimes inits lvn DDPT=1

always inits lvn W1 == XECUTE-able code with WRITE

TAG POINT^DIDH

FALLSTHRU from POINT^DIDH

INPUT VARS

lvn DA

$ORDER(^DD(DA,0,"PT",

always evals $ORDER(^DD(DA,0,"PT",X))

OUTPUT VARS

lvn X

always inits to ""

always exits line ==""

after command=5 then == subscript of ^DD(DA,0,"PT", ...

LOOP start with X over $ORDER(^DD(DA,0,"PT",X))

lvn DG

always inits to 0

always exits line == 0

after command=8 then == subscript of ^DD(DA,0,"PT",X, ...

DOUBLE LOOP start with DG over $ORDER(^DD(DA,0,"PT",X,DG))

Calls PD^DIDH

sometimes WRITEs

sometimes calls H^DIDH

IF undef lvn DIU

AND lvn M == U == "^"

GOTO out of double loop to Q^DIDH

Entryref PD^DIDH

Code

PD I $S('$D(^DD(X,DG,0)):1,$P(^(0),U,2)["V":0,1:$P($P(^(0),U,2),"P",2)-DA) K ^DD(DA,0,"PT",X,DG) Q

S %=X,%F=DG

; fallsthru to WR^DIDH

TAG PD^DIDH

CALLED from POINT^DIDH

INPUT VARS

lvn DA == DDnumber

lvn X == subscript of ^DD(DA,0,"PT", ...

lvn DA == subscript of ^DD(DA,0,"PT",X ...

checks if not $D(^DD(X,DG,0))

-- if field DG of file X is undefined

then KILL ^DD(DA,0,X,DG) ;; kill off this reference

then QUIT  ;; process no more

skips if $P(^DD(X,DG,0),U,2)["V"

-- if datatype of field is VARIABLE POINTER

otherwise if $P($P(^DD(X,DG,0),U,2),"P",2)-DA)

-- if datatype is a pointer and does not points to current DDnumber

TAG PD+1^DIDH

FALLSTHRU from PD^DIDH

init lvn % to lvn X

init lvn %F to lvn DG

Entryref WR^DIDH

Code

WR I '$D(IOM) S IOP="HOME" N %X D ^%ZIS Q:POP

I $D(DDPT) X W1 K DDPT

S X1=$P(^DD(%,%F,0),U)_" field (#"_%F_")"

; fallsthru to UP^DIDH

TAG WR^DIDH

FALLSTRU from PD+1^DIDH

if unknown right margin in lvn IOM

then force default I/O device as IOP == "HOME"

then call ^%ZIS

if POP is true

ie fails to init home device

then QUIT subroutine

TAG WR+1^DIDH

FALLS THRU from WR^DIDH

IF lvn DDPT is defined (setup in POINT+1^DIDH)

then assume W1 is defined (also setup in POINT+1^DIDH)

then XECUTE W1 (setup as a WRITE)

then KILL lvn DDPT flag variable

TAG WR+2^DIDH

FALLSTHRU from WR+1^DIDH

Entryref UP^DIDH

Code

UP I $L(X1)+$L(%)+$L($O(^DD(%,0,"NM",0)))>225 S X1=X1_" etc... ^" G L1

S X1=X1_" of the "_$O(^(0))

I $D(^DD(%,0,"UP")) S X1=X1_" sub-field (#"_%_")",%=^("UP") G UP

S X1=X1_" File (#"_%_") ^"

: ; fallsthru to L1^DIDH

Entryref L1^DIDH

Code

L1 F DDC=1:1 S DDV=$P(X1," ",DDC)_" " Q:DDV["^" W:$L(DDV)+$X>IOM !,?19 W DDV

K DDC,DDV,X1 Q