- 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