DIKCP ;SFISC/MKO-PRINT INDEX(ES) ;11:33 AM 1 Nov 1999
;;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)
;==============================
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKCP 6877 printed Jan 18, 2025@03:49:44 Page 2
DIKCP ;SFISC/MKO-PRINT INDEX(ES) ;11:33 AM 1 Nov 1999
+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 ;In:
+11 ; FIL = File #
+12 ; FLD = Field # (optional) (ignored if FLAG [ M)
+13 ; FLAG [ Cn : column tab stop from left margin (def=18)
+14 ; [ F : print field-level indexes
+15 ; [ Ln : left margin (def=0)
+16 ; [ M : include subfiles (multiples) under File
+17 ; [ N : don't print any mumps code
+18 ; [ O : print traditional 1-node cross references
+19 ; [ R : print record-level indexes
+20 ; [ S : single space (no blank lines)
+21 ; [ Tn : type (style) of 1st lines of each xref
+22 ; PAGE("H") = header text or M code that begins with a write statement
+23 ; If text : eop read issued; and @IOF, PAGE("H")
+24 ; is written automatically
+25 ; If M code : code must issue eop read, write @IOF, and
+26 ; write the header.
+27 ; undefined : no paging
+28 ;
+29 ; PAGE("B") = bottom margin
+30 ;Out:
+31 ; PAGE(U) = returns as 1, if timeout or ^ at eop
+32 ;Notes:
+33 ; Type 0 : Used for the listings at the beg and end of report.
+34 ; First line looks like:
+35 ; AC (#30) REGULAR FIELD IR SORTING ONLY
+36 ;
+37 ; Type 1 : Used for the listing with each field.
+38 ; First line looks like:
+39 ; FIELD INDEX: AC (#30) REGULAR IR SORTING ONLY
+40 ;
PRINT(FIL,FLD,FLAG,PAGE) ;Print all indexes on one file(/field)
+1 if '$GET(FIL)
QUIT
+2 NEW HSTR,LM,SB,TOP,TS,TYP,WID
+3 ;
+4 ;Initialize variables
+5 DO INIT
+6 ;
+7 ;M flag, print file and subfile indexes
+8 IF FLAG["M"
Begin DoDot:1
+9 DO SUBFILES^DIKCU(FIL,.SB)
+10 SET TOP=1
FOR
Begin DoDot:2
+11 IF FLAG["R"!(FLAG["F")
IF $DATA(^DD("IX","AC",FIL))
Begin DoDot:3
+12 DO PRFILE(FIL,"",FLAG,.PAGE)
End DoDot:3
+13 IF '$TEST
IF FLAG["O"
IF $DATA(^DD(FIL,"IX"))
Begin DoDot:3
+14 DO PRFILE(FIL,"",FLAG,.PAGE)
End DoDot:3
+15 IF $GET(TOP)
SET FIL=0
KILL TOP
End DoDot:2
if PAGE(U)
QUIT
SET FIL=$ORDER(SB(FIL))
if 'FIL
QUIT
End DoDot:1
+16 ;
+17 IF '$TEST
DO PRFILE(FIL,$GET(FLD),FLAG,.PAGE)
+18 QUIT
+19 ;
PRFILE(FIL,FLD,FLAG,PAGE) ;Print indexes for 1 file
+1 if '$GET(FIL)
QUIT
+2 NEW FHDR,HDR,NAM,NO,XR,XRL
+3 IF $GET(FLAG)'["i"
NEW LM,TS,TYP,WID
DO INIT
+4 ;
+5 ;Print traditional xrefs
+6 IF FLAG["O"
DO PRFILE^DIKCP3(FIL,$GET(FLD),FLAG,.PAGE,.FHDR)
if PAGE(U)
QUIT
+7 IF FLAG'["F"
IF FLAG'["R"
QUIT
+8 ;
+9 ;Print indexes
+10 IF $GET(FLD)=""
Begin DoDot:1
+11 ;Build list of xrefs sorted by name
+12 SET XR=0
FOR
SET XR=$ORDER(^DD("IX","AC",FIL,XR))
if 'XR
QUIT
Begin DoDot:2
+13 if $GET(^DD("IX",XR,0))?."^"
QUIT
if FLAG'[$PIECE(^(0),U,6)
QUIT
SET NAM=$PIECE(^(0),U,2)
+14 if NAM=""
SET NAM=" <no name"_$GET(NO)_">"
SET NO=$GET(NO)+1
+15 SET XRL(NAM,XR)=""
End DoDot:2
+16 ;
+17 ;Loop through sorted list
+18 SET NAM=""
FOR
SET NAM=$ORDER(XRL(NAM))
if NAM=""
QUIT
Begin DoDot:2
+19 SET XR=0
FOR
SET XR=$ORDER(XRL(NAM,XR))
if 'XR
QUIT
Begin DoDot:3
+20 IF '$GET(FHDR)
DO FHDR(FIL,FLAG,.PAGE,.FHDR)
if PAGE(U)
QUIT
+21 IF '$GET(HDR)
DO HDR(FIL,FLAG,LM,.PAGE,.HDR)
if PAGE(U)
QUIT
+22 DO PRINDEX(XR,FLAG,.PAGE)
if PAGE(U)
QUIT
+23 DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+24 IF FLAG'["S"
DO WRLN("",0,.PAGE)
End DoDot:3
if PAGE(U)
QUIT
End DoDot:2
if PAGE(U)
QUIT
End DoDot:1
+25 ;
+26 IF '$TEST
SET XR=0
FOR
SET XR=$ORDER(^DD("IX","F",FIL,FLD,XR))
if 'XR
QUIT
Begin DoDot:1
+27 if $DATA(^DD("IX",XR,0))?."^"
QUIT
if FLAG'[$PIECE(^(0),U,6)
QUIT
+28 IF '$GET(FHDR)
DO FHDR(FIL,FLAG,.PAGE,.FHDR)
if PAGE(U)
QUIT
+29 IF '$GET(HDR)
DO HDR(FIL,FLAG,LM,.PAGE,.HDR)
if PAGE(U)
QUIT
+30 DO PRINDEX(XR,FLAG,.PAGE)
if PAGE(U)
QUIT
+31 DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+32 IF FLAG'["S"
DO WRLN("",0,.PAGE)
End DoDot:1
if PAGE(U)
QUIT
+33 QUIT
+34 ;
PRINDEX(XR,FLAG,PAGE) ;Print one index
+1 GOTO PRINDEX^DIKCP1
+2 ;
HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header for indexes
+1 SET HDR=1
+2 IF FLAG'["M"
IF FLAG'["O"
QUIT
+3 DO WRLN($SELECT(FLAG["R"&(FLAG["F"):"New-Style",FLAG["R":"Record",1:"Field")_" Indexes:",LM,.PAGE,2)
if PAGE(U)
QUIT
+4 DO WRLN("",0,.PAGE)
+5 QUIT
+6 ;
FHDR(FIL,FLAG,PAGE,FHDR) ;Print header for file
+1 SET FHDR=1
+2 if FLAG'["M"
QUIT
+3 DO WRLN($PIECE("F^Subf",U,$DATA(^DD(FIL,0,"UP"))#2+1)_"ile #"_FIL,0,.PAGE,2)
if PAGE(U)
QUIT
+4 DO WRLN("",0,.PAGE)
+5 QUIT
+6 ;
+7 ;=============================
+8 ; LIST(File,Field,Flag,.Page)
+9 ;=============================
+10 ;List Indexes that reside on a given file.
+11 ;In:
+12 ; Same as PRINT above (except that N and O flag don't apply)
+13 ;Out:
+14 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
+15 ;Notes:
+16 ; Type 0 : Used for the listing of Indexes on a file or subfile
+17 ; INDEXED BY: ANOTHER FIELD (AC), SET & FREE (C),
+18 ; ANOTHER FIELD & EXTRACT (D)
+19 ;
+20 ; Type 1 : Used for the listing of Record Indexes with each field.
+21 ; RECORD INDEXES: WF (#22) [WHOLE FILE on #9999)],
+22 ; WF (#24), AC (#52)
+23 ;
LIST(FIL,FLD,FLAG,PAGE) ;
+1 if '$GET(FIL)
QUIT
+2 NEW LAB,LM,SB,SUB,TS,TYP,WID
+3 ;
+4 ;Initialize variables
+5 DO INIT
+6 ;
+7 ;Set label
+8 IF TYP=1
Begin DoDot:1
+9 IF FLAG["R"
IF FLAG["F"
SET LAB="INDEXES: "
+10 IF '$TEST
IF FLAG["R"
SET LAB="RECORD INDEXES: "
+11 IF '$TEST
SET LAB="FIELD INDEXES: "
End DoDot:1
+12 IF '$TEST
SET LAB="INDEXED BY: "
+13 SET LAB=LAB_$JUSTIFY("",TS-$LENGTH(LAB))
+14 ;
+15 ;M flag, get and list for file and subfiles
+16 IF FLAG["M"
Begin DoDot:1
+17 DO SUBFILES^DIKCU(FIL,.SB)
+18 SET SUB=""
+19 FOR
Begin DoDot:2
+20 if '$DATA(^DD("IX","B",FIL))
QUIT
+21 IF SUB]""!(FLAG'["S")
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+22 DO WRLN(SUB_"FILE #"_FIL,LM,.PAGE,1)
if PAGE(U)
QUIT
+23 DO LFILE(FIL,"",FLAG,LAB,.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
+24 ;
+25 ;Otherwise, just list for one file
+26 IF '$TEST
Begin DoDot:1
+27 IF FLAG'["S"
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+28 DO LFILE(FIL,$GET(FLD),FLAG,LAB,.PAGE)
End DoDot:1
+29 QUIT
+30 ;
LFILE(FIL,FLD,FLAG,LAB,PAGE) ;Format list of indexes and print
+1 GOTO LFILE^DIKCP2
+2 ;
INIT ;Initialize module-wide variables
+1 if $GET(FLAG)["i"
QUIT
+2 SET FLAG=$GET(FLAG)_"i"
+3 IF FLAG'["F"
IF FLAG'["R"
IF FLAG'["O"
SET FLAG="OFR"_FLAG
+4 SET LM=+$PIECE(FLAG,"L",2)\1
+5 SET TS=+$PIECE(FLAG,"C",2)
if 'TS
SET TS=18
+6 SET TYP=+$PIECE(FLAG,"T",2)\1
+7 SET WID=$GET(IOM,80)-1-LM-TS
if WID<1
SET WID=1
+8 SET PAGE(U)=""
+9 QUIT
+10 ;
+11 ;===================================
+12 ; WRLN(Text,Tab,.Page,KeepWithNext)
+13 ;===================================
+14 ;Write a single line of text, precede with a !, do paging if necessary
+15 ;In:
+16 ; TXT = Text to write; $C(0) replaced with spaces.
+17 ; TAB = ?Tab before writing text (def=0)
+18 ; PAGE("H") = Header text or M code that begins with a write statement
+19 ; If not passed in, no paging.
+20 ; PAGE("B") = Bottom margin
+21 ; KWN = Additional padding on bottom margin ("keep with next")
+22 ;Out:
+23 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
+24 ;
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
