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

INPUT VARS

lvn IOM

lvn DDPT

lvn W1

lvn % == DD number

lvn %F == Field number

lvn U == "^"

OUTPUT VARS

lvn X1

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

FALLSTHRU to WR+1^DIDH

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

TAG L1^DIDH

loop thru each piece of X1

if next word will go past right margin (as lvn IOM)

WRITE linefeed and tab to column 19

WRITE current piece of X1 as lvn DDV

TAG L1+1^DIDH

KILL lvn DDC

KILL lvn DDV

KILL lvn X1

QUIT subroutine