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 Oct 16, 2024@18:49:20 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
