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

DIKKP.m

Go to the documentation of this file. 
  1. DIKKP ;SFISC/MKO-PRINT KEYS ;9:52 AM  3 Mar 1998
  1.  ;;22.0;VA FileMan;;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;==============================
  1.  ; PRINT(File,Field,Flag,.Page)
  1.  ;==============================
  1.  ;Print Keys defined a file
  1.  ;In:
  1.  ; FIL     = File #
  1.  ; FLD     = Field # (optional) (ignored if FLAG [ M)
  1.  ; FLAG    [ Cn : column tab stop from left margin
  1.  ;         [ Ln : left margin (def=0)
  1.  ;         [ M  : include subfiles (multiples) under File
  1.  ;         [ S  : suppress line feed before listing
  1.  ; PAGE("H") = Header text or M code that begins with a write statement
  1.  ; PAGE("B") = Bottom margin
  1.  ;Out:
  1.  ; PAGE(U)   = Returns as 1, if timeout or ^ at eop
  1.  ;
  1. PRINT(FIL,FLD,FLAG,PAGE) ;Print keys
  1.  Q:'$G(FIL)
  1.  N FILETXT,LM,SB,SUB,TS,WID
  1.  ;
  1.  ;Initialize variables
  1.  D INIT
  1.  ;
  1.  ;M flag, get and print keys 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("KEY","B",FIL))
  1.  .. S FILETXT=SUB_"FILE #"_FIL
  1.  .. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U)
  1.  .. D WRLN(FILETXT,LM,.PAGE,2) Q:PAGE(U)
  1.  .. D WRLN($TR($J("",$L(FILETXT))," ","-"),LM,.PAGE) Q:PAGE(U)
  1.  .. D PRFILE(FIL,"",FLAG,.PAGE) Q:PAGE(U)
  1.  ;
  1.  ;Otherwise, print keys for one file
  1.  E  D
  1.  . I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
  1.  . D PRFILE(FIL,$G(FLD),FLAG,.PAGE)
  1.  Q
  1.  ;
  1. PRFILE(FIL,FLD,FLAG,PAGE) ;Print keys for a file
  1.  Q:'$G(FIL)
  1.  N KEY,NAM,SP
  1.  I $G(FLAG)'["i" N LM,TS,WID D INIT
  1.  ;
  1.  I $G(FLD)="" D
  1.  . S NAM="" F  S NAM=$O(^DD("KEY","BB",FIL,NAM)) Q:NAM=""  D  Q:PAGE(U)
  1.  .. S KEY=0 F  S KEY=$O(^DD("KEY","BB",FIL,NAM,KEY)) Q:'KEY  D  Q:PAGE(U)
  1.  ... I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U)
  1.  ... D PRKEY(KEY,FLAG,.PAGE)
  1.  ... S SP=1
  1.  ;
  1.  E  S KEY=0 F  S KEY=$O(^DD("KEY","F",FIL,FLD,KEY)) Q:'KEY  D  Q:PAGE(U)
  1.  . I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U)
  1.  . D PRKEY(KEY,FLAG,.PAGE)
  1.  . S SP=1
  1.  Q
  1.  ;
  1. PRKEY(KEY,FLAG,PAGE) ;Print one key
  1.  Q:'$G(KEY)
  1.  N FIL,FLD,FLDN,LN,LUI,LUIN,NAM,PRI,SEQ,TAB1,TXT,UI,UI0
  1.  I $G(FLAG)'["i" N LM,TS,WID D INIT
  1.  ;
  1.  ;Print Priority, Key Name and Number
  1.  Q:$G(^DD("KEY",KEY,0))?."^"
  1.  S NAM=$P(^DD("KEY",KEY,0),U,2),PRI=$P(^(0),U,3),UI=$P(^(0),U,4)
  1.  S:PRI]"" PRI=$$EXTERNAL^DILFD(.31,1,"",PRI)
  1.  S TXT=PRI_" KEY: "
  1.  S TXT=TXT_$J("",TS-$L(TXT))_NAM_" (#"_KEY_")"
  1.  D WRLN(TXT,LM,.PAGE) Q:PAGE(U)
  1.  ;
  1.  ;Print Uniqueness Index
  1.  I UI D
  1.  . S UI0=$G(^DD("IX",UI,0))
  1.  . K TXT S TXT=0,TXT(0)=$P(UI0,U,2)_" (#"_UI_")"
  1.  . D:$P(UI0,U)'=$P(UI0,U,9) ADDSTR("  WHOLE FILE (#"_$P(UI0,U)_")",.TXT)
  1.  . D WRAP^DIKCU2(.TXT,WID)
  1.  . D WRLN("Uniqueness Index: "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U)
  1.  . F LN=1:1 Q:'$D(TXT(LN))  D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
  1.  ;
  1.  ;Print Lookup Indexes
  1.  K TXT S TXT=0,TXT(0)=""
  1.  S LUIN=0 F  S LUIN=$O(^DD("KEY",KEY,3.1,LUIN)) Q:'LUIN  D
  1.  . S LUI=$P($G(^DD("KEY",KEY,3.1,LUIN,0)),U) Q:'LUI
  1.  . S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_", "
  1.  . D ADDSTR($P($G(^DD("IX",LUI,0)),U,2)_" (#"_LUI_")",.TXT)
  1.  I TXT(0)]"" D  Q:PAGE(U)
  1.  . D WRAP^DIKCU2(.TXT,WID)
  1.  . D WRLN("Lookup Index(es): "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U)
  1.  . F LN=1:1 Q:'$D(TXT(LN))  D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
  1.  ;
  1.  ;Print Fields
  1.  K TXT S TXT=0,TXT(0)=""
  1.  S SEQ=0 F  S SEQ=$O(^DD("KEY",KEY,2,"S",SEQ)) Q:'SEQ  D  Q:PAGE(U)
  1.  . S FLD=0 F  S FLD=$O(^DD("KEY",KEY,2,"S",SEQ,FLD)) Q:'FLD  D  Q:PAGE(U)
  1.  .. S FIL=0 F  S FIL=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL)) Q:'FIL  D  Q:PAGE(U)
  1.  ... S FLDN=0 F  S FLDN=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL,FLDN)) Q:'FLDN  D  Q:PAGE(U)
  1.  .... Q:$G(^DD("KEY",KEY,2,FLDN,0))?."^"
  1.  .... S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_"  "
  1.  .... D ADDSTR(SEQ_")"_$C(0)_$P($G(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",.TXT)
  1.  I TXT(0)]"" D  Q:PAGE(U)
  1.  . D WRAP^DIKCU2(.TXT,WID)
  1.  . D WRLN("File, Field: "_TXT(0),LM+TS-13,.PAGE) Q:PAGE(U)
  1.  . F LN=1:1 Q:'$D(TXT(LN))  D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
  1.  Q
  1.  ;
  1. ADDSTR(X,TXT) ;Add string X to the TXT array
  1.  I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)=""
  1.  S TXT(TXT)=TXT(TXT)_X
  1.  Q
  1.  ;
  1. INIT ;Initialize module-wide variables
  1.  Q:$G(FLAG)["i"
  1.  S FLAG=$G(FLAG)_"i"
  1.  S LM=$P(FLAG,"L",2)\1
  1.  S TS=$P(FLAG,"C",2)\1 S:'TS TS=20
  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