ROUTINE DIDH

From VistApedia
Jump to: navigation, search

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

TAG UP^DIDH

TAG UP+1^DIDH

TAG UP+2^DIDH

TAG UP+3^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