DIKKP ;SFISC/MKO-PRINT KEYS ;9:52 AM 3 Mar 1998
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;==============================
; PRINT(File,Field,Flag,.Page)
;==============================
;Print Keys defined a file
;In:
; FIL = File #
; FLD = Field # (optional) (ignored if FLAG [ M)
; FLAG [ Cn : column tab stop from left margin
; [ Ln : left margin (def=0)
; [ M : include subfiles (multiples) under File
; [ S : suppress line feed before listing
; PAGE("H") = Header text or M code that begins with a write statement
; PAGE("B") = Bottom margin
;Out:
; PAGE(U) = Returns as 1, if timeout or ^ at eop
;
PRINT(FIL,FLD,FLAG,PAGE) ;Print keys
Q:'$G(FIL)
N FILETXT,LM,SB,SUB,TS,WID
;
;Initialize variables
D INIT
;
;M flag, get and print keys 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("KEY","B",FIL))
.. S FILETXT=SUB_"FILE #"_FIL
.. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U)
.. D WRLN(FILETXT,LM,.PAGE,2) Q:PAGE(U)
.. D WRLN($TR($J("",$L(FILETXT))," ","-"),LM,.PAGE) Q:PAGE(U)
.. D PRFILE(FIL,"",FLAG,.PAGE) Q:PAGE(U)
;
;Otherwise, print keys for one file
E D
. I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
. D PRFILE(FIL,$G(FLD),FLAG,.PAGE)
Q
;
PRFILE(FIL,FLD,FLAG,PAGE) ;Print keys for a file
Q:'$G(FIL)
N KEY,NAM,SP
I $G(FLAG)'["i" N LM,TS,WID D INIT
;
I $G(FLD)="" D
. S NAM="" F S NAM=$O(^DD("KEY","BB",FIL,NAM)) Q:NAM="" D Q:PAGE(U)
.. S KEY=0 F S KEY=$O(^DD("KEY","BB",FIL,NAM,KEY)) Q:'KEY D Q:PAGE(U)
... I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U)
... D PRKEY(KEY,FLAG,.PAGE)
... S SP=1
;
E S KEY=0 F S KEY=$O(^DD("KEY","F",FIL,FLD,KEY)) Q:'KEY D Q:PAGE(U)
. I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U)
. D PRKEY(KEY,FLAG,.PAGE)
. S SP=1
Q
;
PRKEY(KEY,FLAG,PAGE) ;Print one key
Q:'$G(KEY)
N FIL,FLD,FLDN,LN,LUI,LUIN,NAM,PRI,SEQ,TAB1,TXT,UI,UI0
I $G(FLAG)'["i" N LM,TS,WID D INIT
;
;Print Priority, Key Name and Number
Q:$G(^DD("KEY",KEY,0))?."^"
S NAM=$P(^DD("KEY",KEY,0),U,2),PRI=$P(^(0),U,3),UI=$P(^(0),U,4)
S:PRI]"" PRI=$$EXTERNAL^DILFD(.31,1,"",PRI)
S TXT=PRI_" KEY: "
S TXT=TXT_$J("",TS-$L(TXT))_NAM_" (#"_KEY_")"
D WRLN(TXT,LM,.PAGE) Q:PAGE(U)
;
;Print Uniqueness Index
I UI D
. S UI0=$G(^DD("IX",UI,0))
. K TXT S TXT=0,TXT(0)=$P(UI0,U,2)_" (#"_UI_")"
. D:$P(UI0,U)'=$P(UI0,U,9) ADDSTR(" WHOLE FILE (#"_$P(UI0,U)_")",.TXT)
. D WRAP^DIKCU2(.TXT,WID)
. D WRLN("Uniqueness Index: "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U)
. F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
;
;Print Lookup Indexes
K TXT S TXT=0,TXT(0)=""
S LUIN=0 F S LUIN=$O(^DD("KEY",KEY,3.1,LUIN)) Q:'LUIN D
. S LUI=$P($G(^DD("KEY",KEY,3.1,LUIN,0)),U) Q:'LUI
. S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_", "
. D ADDSTR($P($G(^DD("IX",LUI,0)),U,2)_" (#"_LUI_")",.TXT)
I TXT(0)]"" D Q:PAGE(U)
. D WRAP^DIKCU2(.TXT,WID)
. D WRLN("Lookup Index(es): "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U)
. F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
;
;Print Fields
K TXT S TXT=0,TXT(0)=""
S SEQ=0 F S SEQ=$O(^DD("KEY",KEY,2,"S",SEQ)) Q:'SEQ D Q:PAGE(U)
. S FLD=0 F S FLD=$O(^DD("KEY",KEY,2,"S",SEQ,FLD)) Q:'FLD D Q:PAGE(U)
.. S FIL=0 F S FIL=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL)) Q:'FIL D Q:PAGE(U)
... S FLDN=0 F S FLDN=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL,FLDN)) Q:'FLDN D Q:PAGE(U)
.... Q:$G(^DD("KEY",KEY,2,FLDN,0))?."^"
.... S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_" "
.... D ADDSTR(SEQ_")"_$C(0)_$P($G(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",.TXT)
I TXT(0)]"" D Q:PAGE(U)
. D WRAP^DIKCU2(.TXT,WID)
. D WRLN("File, Field: "_TXT(0),LM+TS-13,.PAGE) Q:PAGE(U)
. F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
Q
;
ADDSTR(X,TXT) ;Add string X to the TXT array
I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)=""
S TXT(TXT)=TXT(TXT)_X
Q
;
INIT ;Initialize module-wide variables
Q:$G(FLAG)["i"
S FLAG=$G(FLAG)_"i"
S LM=$P(FLAG,"L",2)\1
S TS=$P(FLAG,"C",2)\1 S:'TS TS=20
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKKP 5456 printed Sep 23, 2025@20:25:11 Page 2
DIKKP ;SFISC/MKO-PRINT KEYS ;9:52 AM 3 Mar 1998
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;==============================
+8 ; PRINT(File,Field,Flag,.Page)
+9 ;==============================
+10 ;Print Keys defined a file
+11 ;In:
+12 ; FIL = File #
+13 ; FLD = Field # (optional) (ignored if FLAG [ M)
+14 ; FLAG [ Cn : column tab stop from left margin
+15 ; [ Ln : left margin (def=0)
+16 ; [ M : include subfiles (multiples) under File
+17 ; [ S : suppress line feed before listing
+18 ; PAGE("H") = Header text or M code that begins with a write statement
+19 ; PAGE("B") = Bottom margin
+20 ;Out:
+21 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
+22 ;
PRINT(FIL,FLD,FLAG,PAGE) ;Print keys
+1 if '$GET(FIL)
QUIT
+2 NEW FILETXT,LM,SB,SUB,TS,WID
+3 ;
+4 ;Initialize variables
+5 DO INIT
+6 ;
+7 ;M flag, get and print keys for file and subfiles
+8 IF FLAG["M"
Begin DoDot:1
+9 DO SUBFILES^DIKCU(FIL,.SB)
+10 SET SUB=""
+11 FOR
Begin DoDot:2
+12 if '$DATA(^DD("KEY","B",FIL))
QUIT
+13 SET FILETXT=SUB_"FILE #"_FIL
+14 IF SUB]""!(FLAG'["S")
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+15 DO WRLN(FILETXT,LM,.PAGE,2)
if PAGE(U)
QUIT
+16 DO WRLN($TRANSLATE($JUSTIFY("",$LENGTH(FILETXT))," ","-"),LM,.PAGE)
if PAGE(U)
QUIT
+17 DO PRFILE(FIL,"",FLAG,.PAGE)
if PAGE(U)
QUIT
End DoDot:2
if PAGE(U)
QUIT
if SUB=""
SET SUB="SUB"
SET FIL=0
SET FIL=$ORDER(SB(FIL))
if 'FIL
QUIT
End DoDot:1
+18 ;
+19 ;Otherwise, print keys for one file
+20 IF '$TEST
Begin DoDot:1
+21 IF FLAG'["S"
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+22 DO PRFILE(FIL,$GET(FLD),FLAG,.PAGE)
End DoDot:1
+23 QUIT
+24 ;
PRFILE(FIL,FLD,FLAG,PAGE) ;Print keys for a file
+1 if '$GET(FIL)
QUIT
+2 NEW KEY,NAM,SP
+3 IF $GET(FLAG)'["i"
NEW LM,TS,WID
DO INIT
+4 ;
+5 IF $GET(FLD)=""
Begin DoDot:1
+6 SET NAM=""
FOR
SET NAM=$ORDER(^DD("KEY","BB",FIL,NAM))
if NAM=""
QUIT
Begin DoDot:2
+7 SET KEY=0
FOR
SET KEY=$ORDER(^DD("KEY","BB",FIL,NAM,KEY))
if 'KEY
QUIT
Begin DoDot:3
+8 IF $GET(SP)
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+9 DO PRKEY(KEY,FLAG,.PAGE)
+10 SET SP=1
End DoDot:3
if PAGE(U)
QUIT
End DoDot:2
if PAGE(U)
QUIT
End DoDot:1
+11 ;
+12 IF '$TEST
SET KEY=0
FOR
SET KEY=$ORDER(^DD("KEY","F",FIL,FLD,KEY))
if 'KEY
QUIT
Begin DoDot:1
+13 IF $GET(SP)
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+14 DO PRKEY(KEY,FLAG,.PAGE)
+15 SET SP=1
End DoDot:1
if PAGE(U)
QUIT
+16 QUIT
+17 ;
PRKEY(KEY,FLAG,PAGE) ;Print one key
+1 if '$GET(KEY)
QUIT
+2 NEW FIL,FLD,FLDN,LN,LUI,LUIN,NAM,PRI,SEQ,TAB1,TXT,UI,UI0
+3 IF $GET(FLAG)'["i"
NEW LM,TS,WID
DO INIT
+4 ;
+5 ;Print Priority, Key Name and Number
+6 if $GET(^DD("KEY",KEY,0))?."^"
QUIT
+7 SET NAM=$PIECE(^DD("KEY",KEY,0),U,2)
SET PRI=$PIECE(^(0),U,3)
SET UI=$PIECE(^(0),U,4)
+8 if PRI]""
SET PRI=$$EXTERNAL^DILFD(.31,1,"",PRI)
+9 SET TXT=PRI_" KEY: "
+10 SET TXT=TXT_$JUSTIFY("",TS-$LENGTH(TXT))_NAM_" (#"_KEY_")"
+11 DO WRLN(TXT,LM,.PAGE)
if PAGE(U)
QUIT
+12 ;
+13 ;Print Uniqueness Index
+14 IF UI
Begin DoDot:1
+15 SET UI0=$GET(^DD("IX",UI,0))
+16 KILL TXT
SET TXT=0
SET TXT(0)=$PIECE(UI0,U,2)_" (#"_UI_")"
+17 if $PIECE(UI0,U)'=$PIECE(UI0,U,9)
DO ADDSTR(" WHOLE FILE (#"_$PIECE(UI0,U)_")",.TXT)
+18 DO WRAP^DIKCU2(.TXT,WID)
+19 DO WRLN("Uniqueness Index: "_TXT(0),LM+TS-18,.PAGE)
if PAGE(U)
QUIT
+20 FOR LN=1:1
if '$DATA(TXT(LN))
QUIT
DO WRLN(TXT(LN),LM+TS,.PAGE)
if PAGE(U)
QUIT
End DoDot:1
+21 ;
+22 ;Print Lookup Indexes
+23 KILL TXT
SET TXT=0
SET TXT(0)=""
+24 SET LUIN=0
FOR
SET LUIN=$ORDER(^DD("KEY",KEY,3.1,LUIN))
if 'LUIN
QUIT
Begin DoDot:1
+25 SET LUI=$PIECE($GET(^DD("KEY",KEY,3.1,LUIN,0)),U)
if 'LUI
QUIT
+26 if TXT(TXT)]""
SET TXT(TXT)=TXT(TXT)_", "
+27 DO ADDSTR($PIECE($GET(^DD("IX",LUI,0)),U,2)_" (#"_LUI_")",.TXT)
End DoDot:1
+28 IF TXT(0)]""
Begin DoDot:1
+29 DO WRAP^DIKCU2(.TXT,WID)
+30 DO WRLN("Lookup Index(es): "_TXT(0),LM+TS-18,.PAGE)
if PAGE(U)
QUIT
+31 FOR LN=1:1
if '$DATA(TXT(LN))
QUIT
DO WRLN(TXT(LN),LM+TS,.PAGE)
if PAGE(U)
QUIT
End DoDot:1
if PAGE(U)
QUIT
+32 ;
+33 ;Print Fields
+34 KILL TXT
SET TXT=0
SET TXT(0)=""
+35 SET SEQ=0
FOR
SET SEQ=$ORDER(^DD("KEY",KEY,2,"S",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+36 SET FLD=0
FOR
SET FLD=$ORDER(^DD("KEY",KEY,2,"S",SEQ,FLD))
if 'FLD
QUIT
Begin DoDot:2
+37 SET FIL=0
FOR
SET FIL=$ORDER(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL))
if 'FIL
QUIT
Begin DoDot:3
+38 SET FLDN=0
FOR
SET FLDN=$ORDER(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL,FLDN))
if 'FLDN
QUIT
Begin DoDot:4
+39 if $GET(^DD("KEY",KEY,2,FLDN,0))?."^"
QUIT
+40 if TXT(TXT)]""
SET TXT(TXT)=TXT(TXT)_" "
+41 DO ADDSTR(SEQ_")"_$CHAR(0)_$PIECE($GET(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",.TXT)
End DoDot:4
if PAGE(U)
QUIT
End DoDot:3
if PAGE(U)
QUIT
End DoDot:2
if PAGE(U)
QUIT
End DoDot:1
if PAGE(U)
QUIT
+42 IF TXT(0)]""
Begin DoDot:1
+43 DO WRAP^DIKCU2(.TXT,WID)
+44 DO WRLN("File, Field: "_TXT(0),LM+TS-13,.PAGE)
if PAGE(U)
QUIT
+45 FOR LN=1:1
if '$DATA(TXT(LN))
QUIT
DO WRLN(TXT(LN),LM+TS,.PAGE)
if PAGE(U)
QUIT
End DoDot:1
if PAGE(U)
QUIT
+46 QUIT
+47 ;
ADDSTR(X,TXT) ;Add string X to the TXT array
+1 IF $LENGTH(TXT(TXT))+$LENGTH(X)>200
SET TXT=TXT+1
SET TXT(TXT)=""
+2 SET TXT(TXT)=TXT(TXT)_X
+3 QUIT
+4 ;
INIT ;Initialize module-wide variables
+1 if $GET(FLAG)["i"
QUIT
+2 SET FLAG=$GET(FLAG)_"i"
+3 SET LM=$PIECE(FLAG,"L",2)\1
+4 SET TS=$PIECE(FLAG,"C",2)\1
if 'TS
SET TS=20
+5 SET WID=$GET(IOM,80)-1-LM-TS
if WID<1
SET WID=1
+6 SET PAGE(U)=""
+7 QUIT
+8 ;
+9 ;===================================
+10 ; WRLN(Text,Tab,.Page,KeepWithNext)
+11 ;===================================
+12 ;Write a single line of text, precede with a !, do paging if necessary
+13 ;In:
+14 ; TXT = Text to write; $C(0) replaced with spaces.
+15 ; TAB = ?Tab before writing text (def=0)
+16 ; PAGE("H") = Header text or M code that begins with a write statement
+17 ; If not passed in, no paging.
+18 ; PAGE("B") = Bottom margin
+19 ; KWN = Additional padding on bottom margin ("keep with next")
+20 ;Out:
+21 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
+22 ;
WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
+1 NEW X
+2 SET PAGE(U)=""
+3 ;
+4 ;Do paging, if necessary
+5 IF $DATA(PAGE("H"))#2
IF $GET(IOSL,24)-2-$GET(PAGE("B"))-$GET(KWN)'>$Y
Begin DoDot:1
+6 IF PAGE("H")?1"W ".E
XECUTE PAGE("H")
QUIT
+7 IF $EXTRACT($GET(IOST,"C"))="C"
Begin DoDot:2
+8 WRITE $CHAR(7)
READ X:$GET(DTIME,300)
IF X=U!'$TEST
SET PAGE(U)=1
End DoDot:2
if PAGE(U)
QUIT
+9 WRITE @$GET(IOF,"#"),PAGE("H")
End DoDot:1
if PAGE(U)
QUIT
+10 ;
+11 ;Write text
+12 WRITE !?$GET(TAB),$TRANSLATE($GET(TXT),$CHAR(0)," ")
+13 QUIT
