Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIKCP

DIKCP.m

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