200 lines
6.3 KiB
Mathematica
200 lines
6.3 KiB
Mathematica
DIKCP ;SFISC/MKO-PRINT INDEX(ES) ;11:33 AM 1 Nov 1999
|
|
;;22.0;VA FileMan;**11**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;==============================
|
|
; PRINT(File,Field,Flag,.Page)
|
|
;==============================
|
|
;In:
|
|
; FIL = File #
|
|
; FLD = Field # (optional) (ignored if FLAG [ M)
|
|
; FLAG [ Cn : column tab stop from left margin (def=18)
|
|
; [ F : print field-level indexes
|
|
; [ Ln : left margin (def=0)
|
|
; [ M : include subfiles (multiples) under File
|
|
; [ N : don't print any mumps code
|
|
; [ O : print traditional 1-node cross references
|
|
; [ R : print record-level indexes
|
|
; [ S : single space (no blank lines)
|
|
; [ Tn : type (style) of 1st lines of each xref
|
|
; PAGE("H") = header text or M code that begins with a write statement
|
|
; If text : eop read issued; and @IOF, PAGE("H")
|
|
; is written automatically
|
|
; If M code : code must issue eop read, write @IOF, and
|
|
; write the header.
|
|
; undefined : no paging
|
|
;
|
|
; PAGE("B") = bottom margin
|
|
;Out:
|
|
; PAGE(U) = returns as 1, if timeout or ^ at eop
|
|
;Notes:
|
|
; Type 0 : Used for the listings at the beg and end of report.
|
|
; First line looks like:
|
|
; AC (#30) REGULAR FIELD IR SORTING ONLY
|
|
;
|
|
; Type 1 : Used for the listing with each field.
|
|
; First line looks like:
|
|
; FIELD INDEX: AC (#30) REGULAR IR SORTING ONLY
|
|
;
|
|
PRINT(FIL,FLD,FLAG,PAGE) ;Print all indexes on one file(/field)
|
|
Q:'$G(FIL)
|
|
N HSTR,LM,SB,TOP,TS,TYP,WID
|
|
;
|
|
;Initialize variables
|
|
D INIT
|
|
;
|
|
;M flag, print file and subfile indexes
|
|
I FLAG["M" D
|
|
. D SUBFILES^DIKCU(FIL,.SB)
|
|
. S TOP=1 F D Q:PAGE(U) S FIL=$O(SB(FIL)) Q:'FIL
|
|
.. I FLAG["R"!(FLAG["F"),$D(^DD("IX","AC",FIL)) D
|
|
... D PRFILE(FIL,"",FLAG,.PAGE)
|
|
.. E I FLAG["O",$D(^DD(FIL,"IX")) D
|
|
... D PRFILE(FIL,"",FLAG,.PAGE)
|
|
.. I $G(TOP) S FIL=0 K TOP
|
|
;
|
|
E D PRFILE(FIL,$G(FLD),FLAG,.PAGE)
|
|
Q
|
|
;
|
|
PRFILE(FIL,FLD,FLAG,PAGE) ;Print indexes for 1 file
|
|
Q:'$G(FIL)
|
|
N FHDR,HDR,NAM,NO,XR,XRL
|
|
I $G(FLAG)'["i" N LM,TS,TYP,WID D INIT
|
|
;
|
|
;Print traditional xrefs
|
|
I FLAG["O" D PRFILE^DIKCP3(FIL,$G(FLD),FLAG,.PAGE,.FHDR) Q:PAGE(U)
|
|
I FLAG'["F",FLAG'["R" Q
|
|
;
|
|
;Print indexes
|
|
I $G(FLD)="" D
|
|
. ;Build list of xrefs sorted by name
|
|
. S XR=0 F S XR=$O(^DD("IX","AC",FIL,XR)) Q:'XR D
|
|
.. Q:$G(^DD("IX",XR,0))?."^" Q:FLAG'[$P(^(0),U,6) S NAM=$P(^(0),U,2)
|
|
.. S:NAM="" NAM=" <no name"_$G(NO)_">",NO=$G(NO)+1
|
|
.. S XRL(NAM,XR)=""
|
|
. ;
|
|
. ;Loop through sorted list
|
|
. S NAM="" F S NAM=$O(XRL(NAM)) Q:NAM="" D Q:PAGE(U)
|
|
.. S XR=0 F S XR=$O(XRL(NAM,XR)) Q:'XR D Q:PAGE(U)
|
|
... I '$G(FHDR) D FHDR(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U)
|
|
... I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U)
|
|
... D PRINDEX(XR,FLAG,.PAGE) Q:PAGE(U)
|
|
... D WRLN("",0,.PAGE) Q:PAGE(U)
|
|
... I FLAG'["S" D WRLN("",0,.PAGE)
|
|
;
|
|
E S XR=0 F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D Q:PAGE(U)
|
|
. Q:$D(^DD("IX",XR,0))?."^" Q:FLAG'[$P(^(0),U,6)
|
|
. I '$G(FHDR) D FHDR(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U)
|
|
. I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U)
|
|
. D PRINDEX(XR,FLAG,.PAGE) Q:PAGE(U)
|
|
. D WRLN("",0,.PAGE) Q:PAGE(U)
|
|
. I FLAG'["S" D WRLN("",0,.PAGE)
|
|
Q
|
|
;
|
|
PRINDEX(XR,FLAG,PAGE) ;Print one index
|
|
G PRINDEX^DIKCP1
|
|
;
|
|
HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header for indexes
|
|
S HDR=1
|
|
I FLAG'["M",FLAG'["O" Q
|
|
D WRLN($S(FLAG["R"&(FLAG["F"):"New-Style",FLAG["R":"Record",1:"Field")_" Indexes:",LM,.PAGE,2) Q:PAGE(U)
|
|
D WRLN("",0,.PAGE)
|
|
Q
|
|
;
|
|
FHDR(FIL,FLAG,PAGE,FHDR) ;Print header for file
|
|
S FHDR=1
|
|
Q:FLAG'["M"
|
|
D WRLN($P("F^Subf",U,$D(^DD(FIL,0,"UP"))#2+1)_"ile #"_FIL,0,.PAGE,2) Q:PAGE(U)
|
|
D WRLN("",0,.PAGE)
|
|
Q
|
|
;
|
|
;=============================
|
|
; LIST(File,Field,Flag,.Page)
|
|
;=============================
|
|
;List Indexes that reside on a given file.
|
|
;In:
|
|
; Same as PRINT above (except that N and O flag don't apply)
|
|
;Out:
|
|
; PAGE(U) = Returns as 1, if timeout or ^ at eop
|
|
;Notes:
|
|
; Type 0 : Used for the listing of Indexes on a file or subfile
|
|
; INDEXED BY: ANOTHER FIELD (AC), SET & FREE (C),
|
|
; ANOTHER FIELD & EXTRACT (D)
|
|
;
|
|
; Type 1 : Used for the listing of Record Indexes with each field.
|
|
; RECORD INDEXES: WF (#22) [WHOLE FILE on #9999)],
|
|
; WF (#24), AC (#52)
|
|
;
|
|
LIST(FIL,FLD,FLAG,PAGE) ;
|
|
Q:'$G(FIL)
|
|
N LAB,LM,SB,SUB,TS,TYP,WID
|
|
;
|
|
;Initialize variables
|
|
D INIT
|
|
;
|
|
;Set label
|
|
I TYP=1 D
|
|
. I FLAG["R",FLAG["F" S LAB="INDEXES: "
|
|
. E I FLAG["R" S LAB="RECORD INDEXES: "
|
|
. E S LAB="FIELD INDEXES: "
|
|
E S LAB="INDEXED BY: "
|
|
S LAB=LAB_$J("",TS-$L(LAB))
|
|
;
|
|
;M flag, get and list for file and subfiles
|
|
I FLAG["M" D
|
|
. D SUBFILES^DIKCU(FIL,.SB)
|
|
. S SUB=""
|
|
. F D Q:PAGE(U) S:SUB="" SUB="SUB",FIL=0 S FIL=$O(SB(FIL)) Q:'FIL
|
|
.. Q:'$D(^DD("IX","B",FIL))
|
|
.. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U)
|
|
.. D WRLN(SUB_"FILE #"_FIL,LM,.PAGE,1) Q:PAGE(U)
|
|
.. D LFILE(FIL,"",FLAG,LAB,.PAGE) Q:PAGE(U)
|
|
;
|
|
;Otherwise, just list for one file
|
|
E D
|
|
. I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
|
|
. D LFILE(FIL,$G(FLD),FLAG,LAB,.PAGE)
|
|
Q
|
|
;
|
|
LFILE(FIL,FLD,FLAG,LAB,PAGE) ;Format list of indexes and print
|
|
G LFILE^DIKCP2
|
|
;
|
|
INIT ;Initialize module-wide variables
|
|
Q:$G(FLAG)["i"
|
|
S FLAG=$G(FLAG)_"i"
|
|
I FLAG'["F",FLAG'["R",FLAG'["O" S FLAG="OFR"_FLAG
|
|
S LM=+$P(FLAG,"L",2)\1
|
|
S TS=+$P(FLAG,"C",2) S:'TS TS=18
|
|
S TYP=+$P(FLAG,"T",2)\1
|
|
S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1
|
|
S PAGE(U)=""
|
|
Q
|
|
;
|
|
;===================================
|
|
; WRLN(Text,Tab,.Page,KeepWithNext)
|
|
;===================================
|
|
;Write a single line of text, precede with a !, do paging if necessary
|
|
;In:
|
|
; TXT = Text to write; $C(0) replaced with spaces.
|
|
; TAB = ?Tab before writing text (def=0)
|
|
; PAGE("H") = Header text or M code that begins with a write statement
|
|
; If not passed in, no paging.
|
|
; PAGE("B") = Bottom margin
|
|
; KWN = Additional padding on bottom margin ("keep with next")
|
|
;Out:
|
|
; PAGE(U) = Returns as 1, if timeout or ^ at eop
|
|
;
|
|
WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
|
|
N X
|
|
S PAGE(U)=""
|
|
;
|
|
;Do paging, if necessary
|
|
I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U)
|
|
. I PAGE("H")?1"W ".E X PAGE("H") Q
|
|
. I $E($G(IOST,"C"))="C" D Q:PAGE(U)
|
|
.. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1
|
|
. W @$G(IOF,"#"),PAGE("H")
|
|
;
|
|
;Write text
|
|
W !?$G(TAB),$TR($G(TXT),$C(0)," ")
|
|
Q
|