- DIKCP2 ;SFISC/MKO-PRINT INDEX(ES) ;9:39 AM 5 Aug 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.
- ;
- LFILE ;Format list of indexes and print; Come here from LFILE^DIKCP
- N LN,NAM,NO,TXT,XR,XRL
- S TXT=0,TXT(0)=""
- ;
- I $G(FLD)="" S NAM="" F S NAM=$O(^DD("IX","BB",FIL,NAM)) Q:NAM="" D
- . S XR=0
- . F S XR=$O(^DD("IX","BB",FIL,NAM,XR)) Q:'XR D ADDXR(XR,.TXT,FLAG)
- E D
- . S XR=0
- . F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D
- .. Q:$G(^DD("IX",XR,0))?."^" S NAM=$P(^(0),U,2)
- .. S:NAM="" NAM=" <no name"_$G(NO)_">",NO=$G(NO)+1
- .. S XRL(NAM,XR)=""
- . S NAM="" F S NAM=$O(XRL(NAM)) Q:NAM="" D
- .. S XR=0 F S XR=$O(XRL(NAM,XR)) Q:'XR D ADDXR(XR,.TXT,FLAG)
- Q:TXT(0)=""
- ;
- D WRAP^DIKCU2(.TXT,WID)
- D WRLN($G(LAB)_TXT(0),LM,.PAGE) Q:PAGE(U)
- F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+$L(LAB),.PAGE) Q:PAGE(U)
- Q
- ;
- ADDXR(XR,TXT,FLAG) ;Add field list and xref name to TXT array
- N CRV,FIL,FLD,FLDNAM,FND,NAM,RTYP,STR,XR0
- S XR0=$G(^DD("IX",XR,0))
- Q:XR0?."^" Q:FLAG'[$P(XR0,U,6)
- ;
- S:$G(TXT(TXT))]"" TXT(TXT)=TXT(TXT)_", "
- S NAM=$P(XR0,U,2)
- ;
- I TYP=1 D
- . S STR=NAM_$C(0)_"(#"_XR_")"
- . S RTYP=$P(XR0,U,8)
- . I "I"'[RTYP D
- .. S STR=STR_" ("_$TR($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$C(0))
- .. S STR=STR_" #"_$P(XR0,U)_")"
- ;
- E D
- . S CRV=0 F S CRV=$O(^DD("IX",XR,11.1,CRV)) Q:'CRV D
- .. Q:$P($G(^DD("IX",XR,11.1,CRV,0)),U,2)'="F"
- .. S FIL=$P(^DD("IX",XR,11.1,CRV,0),U,3),FLD=$P(^(0),U,4)
- .. Q:'FIL Q:'FLD
- .. S FLDNAM=$P($G(^DD(FIL,FLD,0)),U) Q:FLDNAM=""
- .. D:$G(FND) ADDSTR("& ",.TXT) D ADDSTR(FLDNAM_" ",.TXT)
- .. S FND=1
- . S STR="("_NAM_")"
- . ;
- D ADDSTR(STR,.TXT)
- Q
- ;
- ADDSTR(X,TXT) ;Add string X to the TXT array
- I $L(TXT(TXT))+$L(X)>250 S TXT=TXT+1,TXT(TXT)=""
- S TXT(TXT)=TXT(TXT)_X
- Q
- ;
- WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
- ;See ^DIKCP for documentation
- 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[HDIKCP2 2464 printed Feb 19, 2025@00:15:02 Page 2
- DIKCP2 ;SFISC/MKO-PRINT INDEX(ES) ;9:39 AM 5 Aug 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 ;
- LFILE ;Format list of indexes and print; Come here from LFILE^DIKCP
- +1 NEW LN,NAM,NO,TXT,XR,XRL
- +2 SET TXT=0
- SET TXT(0)=""
- +3 ;
- +4 IF $GET(FLD)=""
- SET NAM=""
- FOR
- SET NAM=$ORDER(^DD("IX","BB",FIL,NAM))
- if NAM=""
- QUIT
- Begin DoDot:1
- +5 SET XR=0
- +6 FOR
- SET XR=$ORDER(^DD("IX","BB",FIL,NAM,XR))
- if 'XR
- QUIT
- DO ADDXR(XR,.TXT,FLAG)
- End DoDot:1
- +7 IF '$TEST
- Begin DoDot:1
- +8 SET XR=0
- +9 FOR
- SET XR=$ORDER(^DD("IX","F",FIL,FLD,XR))
- if 'XR
- QUIT
- Begin DoDot:2
- +10 if $GET(^DD("IX",XR,0))?."^"
- QUIT
- SET NAM=$PIECE(^(0),U,2)
- +11 if NAM=""
- SET NAM=" <no name"_$GET(NO)_">"
- SET NO=$GET(NO)+1
- +12 SET XRL(NAM,XR)=""
- End DoDot:2
- +13 SET NAM=""
- FOR
- SET NAM=$ORDER(XRL(NAM))
- if NAM=""
- QUIT
- Begin DoDot:2
- +14 SET XR=0
- FOR
- SET XR=$ORDER(XRL(NAM,XR))
- if 'XR
- QUIT
- DO ADDXR(XR,.TXT,FLAG)
- End DoDot:2
- End DoDot:1
- +15 if TXT(0)=""
- QUIT
- +16 ;
- +17 DO WRAP^DIKCU2(.TXT,WID)
- +18 DO WRLN($GET(LAB)_TXT(0),LM,.PAGE)
- if PAGE(U)
- QUIT
- +19 FOR LN=1:1
- if '$DATA(TXT(LN))
- QUIT
- DO WRLN(TXT(LN),LM+$LENGTH(LAB),.PAGE)
- if PAGE(U)
- QUIT
- +20 QUIT
- +21 ;
- ADDXR(XR,TXT,FLAG) ;Add field list and xref name to TXT array
- +1 NEW CRV,FIL,FLD,FLDNAM,FND,NAM,RTYP,STR,XR0
- +2 SET XR0=$GET(^DD("IX",XR,0))
- +3 if XR0?."^"
- QUIT
- if FLAG'[$PIECE(XR0,U,6)
- QUIT
- +4 ;
- +5 if $GET(TXT(TXT))]""
- SET TXT(TXT)=TXT(TXT)_", "
- +6 SET NAM=$PIECE(XR0,U,2)
- +7 ;
- +8 IF TYP=1
- Begin DoDot:1
- +9 SET STR=NAM_$CHAR(0)_"(#"_XR_")"
- +10 SET RTYP=$PIECE(XR0,U,8)
- +11 IF "I"'[RTYP
- Begin DoDot:2
- +12 SET STR=STR_" ("_$TRANSLATE($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$CHAR(0))
- +13 SET STR=STR_" #"_$PIECE(XR0,U)_")"
- End DoDot:2
- End DoDot:1
- +14 ;
- +15 IF '$TEST
- Begin DoDot:1
- +16 SET CRV=0
- FOR
- SET CRV=$ORDER(^DD("IX",XR,11.1,CRV))
- if 'CRV
- QUIT
- Begin DoDot:2
- +17 if $PIECE($GET(^DD("IX",XR,11.1,CRV,0)),U,2)'="F"
- QUIT
- +18 SET FIL=$PIECE(^DD("IX",XR,11.1,CRV,0),U,3)
- SET FLD=$PIECE(^(0),U,4)
- +19 if 'FIL
- QUIT
- if 'FLD
- QUIT
- +20 SET FLDNAM=$PIECE($GET(^DD(FIL,FLD,0)),U)
- if FLDNAM=""
- QUIT
- +21 if $GET(FND)
- DO ADDSTR("& ",.TXT)
- DO ADDSTR(FLDNAM_" ",.TXT)
- +22 SET FND=1
- End DoDot:2
- +23 SET STR="("_NAM_")"
- +24 ;
- End DoDot:1
- +25 DO ADDSTR(STR,.TXT)
- +26 QUIT
- +27 ;
- ADDSTR(X,TXT) ;Add string X to the TXT array
- +1 IF $LENGTH(TXT(TXT))+$LENGTH(X)>250
- SET TXT=TXT+1
- SET TXT(TXT)=""
- +2 SET TXT(TXT)=TXT(TXT)_X
- +3 QUIT
- +4 ;
- WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
- +1 ;See ^DIKCP for documentation
- +2 NEW X
- +3 SET PAGE(U)=""
- +4 ;
- +5 ;Do paging, if necessary
- +6 IF $DATA(PAGE("H"))#2
- IF $GET(IOSL,24)-2-$GET(PAGE("B"))-$GET(KWN)'>$Y
- Begin DoDot:1
- +7 IF PAGE("H")?1"W ".E
- XECUTE PAGE("H")
- QUIT
- +8 IF $EXTRACT($GET(IOST,"C"))="C"
- Begin DoDot:2
- +9 WRITE $CHAR(7)
- READ X:$GET(DTIME,300)
- IF X=U!'$TEST
- SET PAGE(U)=1
- End DoDot:2
- if PAGE(U)
- QUIT
- +10 WRITE @$GET(IOF,"#"),PAGE("H")
- End DoDot:1
- if PAGE(U)
- QUIT
- +11 ;
- +12 ;Write text
- +13 WRITE !?$GET(TAB),$TRANSLATE($GET(TXT),$CHAR(0)," ")
- +14 QUIT
