DIKCP3 ;SFISC/MKO-PRINT INDEX(ES) ;9:21 PM 7 Dec 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.
;
PRFILE(FIL,FLD,FLAG,PAGE,FHDR) ;Print Traditional cross-references on a file
Q:'$G(FIL)
N HDR,NAM,NO,XR
I $G(FLAG)'["i" N LM,TS,TYP,WID D INIT^DIKCP
;
;If field is not specified, print all xrefs on field
I $G(FLD)="" D
. ;Build list of xrefs sorted by name
. K ^TMP("DIKCP3",$J)
. S FLD=0 F S FLD=$O(^DD(FIL,"IX",FLD)) Q:'FLD D
.. S XR=0 F S XR=$O(^DD(FIL,FLD,1,XR)) Q:'XR D
... Q:$D(^DD(FIL,FLD,1,XR))<9 S NAM=$P($G(^(XR,0)),U,2)
... S:NAM="" NAM="~~"_$G(NO),NO=$G(NO)+1
... S ^TMP("DIKCP3",$J,NAM,FLD,XR)=""
. ;
. ;Loop through sorted list and print
. S NAM="" F S NAM=$O(^TMP("DIKCP3",$J,NAM)) Q:NAM="" D Q:PAGE(U)
.. S FLD=0 F S FLD=$O(^TMP("DIKCP3",$J,NAM,FLD)) Q:'FLD D Q:PAGE(U)
... S XR=0 F S XR=$O(^TMP("DIKCP3",$J,NAM,FLD,XR)) Q:'XR D Q:PAGE(U)
.... I '$G(FHDR) D FHDR^DIKCP(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U)
.... I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U)
.... D PRINDEX(FIL,FLD,XR,FLAG,.PAGE) Q:PAGE(U)
.... D WRLN("",0,.PAGE) Q:PAGE(U)
.... I FLAG'["S" D WRLN("",0,.PAGE)
. K ^TMP("DIKCP3",$J)
;
;Else print cross-references on specific field
E S XR=0 F S XR=$O(^DD(FIL,FLD,1,XR)) Q:'XR D Q:PAGE(U)
. I '$G(FHDR) D FHDR^DIKCP(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U)
. I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U)
. D PRINDEX(FIL,FLD,XR,FLAG,.PAGE) Q:PAGE(U)
. D WRLN("",0,.PAGE) Q:PAGE(U)
. I FLAG'["S" D WRLN("",0,.PAGE)
Q
;
PRINDEX(FIL,FLD,XR,FLAG,PAGE) ;Print a specific index
Q:'$G(FIL)!'$G(FLD)!'$G(XR)
N ND,WFLAG
I $G(FLAG)'["i" N LM,TYP,TS,WID D INIT^DIKCP
;
;Print first line of information
D FL(FIL,FLD,XR,WID,LM,TS,TYP,.PAGE) Q:PAGE(U)
;
;Print Field
D WLP^DIKCP1("Field: ",$P($G(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",WID,LM+TS,0,.PAGE)
Q:PAGE(U)
;
;For Triggers, print triggered field
I $P($G(^DD(FIL,FLD,1,XR,0)),U,3)["TRIG" D Q:PAGE(U)
. N LAB,TFIL,TFLD
. S TFIL=$P(^DD(FIL,FLD,1,XR,0),U,4),TFLD=$P(^(0),U,5)
. S LAB="Triggered Field: "
. D WLP^DIKCP1(LAB,$P($G(^DD(TFIL,TFLD,0)),U)_" ("_TFIL_","_TFLD_")",WID-$L(LAB),LM+TS+$L(LAB),"",.PAGE)
;
;Print Description
I $O(^DD(FIL,FLD,1,XR,"%D",0)) D Q:PAGE(U)
. D WRWP^DIKCP1($NA(^DD(FIL,FLD,1,XR,"%D")),LM,WID,"Description: ",TS,.PAGE)
I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
;
;Print xref nodes
K WFLAG
S ND=0 F S ND=$O(^DD(FIL,FLD,1,XR,ND)) Q:ND="" D Q:PAGE(U)
. Q:ND="%D"!(ND="DT")
. N TXT
. S TXT(0)=ND_")= "
. S TXT(1)=^DD(FIL,FLD,1,XR,ND)
. I FLAG'["S",ND,$G(WFLAG) D WRLN("",0,.PAGE) Q:PAGE(U)
. D WLP^DIKCP1("",.TXT,WID,LM+TS,1,.PAGE,.WFLAG)
Q
;
FL(FIL,FLD,XR,WID,LM,TS,TYP,PAGE) ;Print first line
N NAME,SP,TYPE,TXT,WF,XR0
;
S SP=$J("",4)
S XR0=$G(^DD(FIL,FLD,1,XR,0)) Q:XR0?."^"
S NAME=$P(XR0,U,2)
S TYPE=$P(XR0,U,3) S:TYPE="" TYPE="REGULAR"
S TXT=NAME_SP_TYPE
;
I $P(XR0,U),$P(XR0,U)'=FIL D
. S TXT=TXT_SP_"WHOLE"_$C(0)_"FILE"_$C(0)_"(#"_$P(XR0,U)_")"
;
;Print first line
D WRPHI^DIKCP1(TXT,WID,LM,TS,0,.PAGE)
Q
;
HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header
I FLAG'["M",FLAG'["R",FLAG'["F" Q
D WRLN("Traditional Cross-References:",LM,.PAGE,2) Q:PAGE(U)
D WRLN("",0,.PAGE)
S HDR=1
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[HDIKCP3 3973 printed Sep 23, 2025@20:24:55 Page 2
DIKCP3 ;SFISC/MKO-PRINT INDEX(ES) ;9:21 PM 7 Dec 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 ;
PRFILE(FIL,FLD,FLAG,PAGE,FHDR) ;Print Traditional cross-references on a file
+1 if '$GET(FIL)
QUIT
+2 NEW HDR,NAM,NO,XR
+3 IF $GET(FLAG)'["i"
NEW LM,TS,TYP,WID
DO INIT^DIKCP
+4 ;
+5 ;If field is not specified, print all xrefs on field
+6 IF $GET(FLD)=""
Begin DoDot:1
+7 ;Build list of xrefs sorted by name
+8 KILL ^TMP("DIKCP3",$JOB)
+9 SET FLD=0
FOR
SET FLD=$ORDER(^DD(FIL,"IX",FLD))
if 'FLD
QUIT
Begin DoDot:2
+10 SET XR=0
FOR
SET XR=$ORDER(^DD(FIL,FLD,1,XR))
if 'XR
QUIT
Begin DoDot:3
+11 if $DATA(^DD(FIL,FLD,1,XR))<9
QUIT
SET NAM=$PIECE($GET(^(XR,0)),U,2)
+12 if NAM=""
SET NAM="~~"_$GET(NO)
SET NO=$GET(NO)+1
+13 SET ^TMP("DIKCP3",$JOB,NAM,FLD,XR)=""
End DoDot:3
End DoDot:2
+14 ;
+15 ;Loop through sorted list and print
+16 SET NAM=""
FOR
SET NAM=$ORDER(^TMP("DIKCP3",$JOB,NAM))
if NAM=""
QUIT
Begin DoDot:2
+17 SET FLD=0
FOR
SET FLD=$ORDER(^TMP("DIKCP3",$JOB,NAM,FLD))
if 'FLD
QUIT
Begin DoDot:3
+18 SET XR=0
FOR
SET XR=$ORDER(^TMP("DIKCP3",$JOB,NAM,FLD,XR))
if 'XR
QUIT
Begin DoDot:4
+19 IF '$GET(FHDR)
DO FHDR^DIKCP(FIL,FLAG,.PAGE,.FHDR)
if PAGE(U)
QUIT
+20 IF '$GET(HDR)
DO HDR(FIL,FLAG,LM,.PAGE,.HDR)
if PAGE(U)
QUIT
+21 DO PRINDEX(FIL,FLD,XR,FLAG,.PAGE)
if PAGE(U)
QUIT
+22 DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+23 IF FLAG'["S"
DO WRLN("",0,.PAGE)
End DoDot:4
if PAGE(U)
QUIT
End DoDot:3
if PAGE(U)
QUIT
End DoDot:2
if PAGE(U)
QUIT
+24 KILL ^TMP("DIKCP3",$JOB)
End DoDot:1
+25 ;
+26 ;Else print cross-references on specific field
+27 IF '$TEST
SET XR=0
FOR
SET XR=$ORDER(^DD(FIL,FLD,1,XR))
if 'XR
QUIT
Begin DoDot:1
+28 IF '$GET(FHDR)
DO FHDR^DIKCP(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(FIL,FLD,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(FIL,FLD,XR,FLAG,PAGE) ;Print a specific index
+1 if '$GET(FIL)!'$GET(FLD)!'$GET(XR)
QUIT
+2 NEW ND,WFLAG
+3 IF $GET(FLAG)'["i"
NEW LM,TYP,TS,WID
DO INIT^DIKCP
+4 ;
+5 ;Print first line of information
+6 DO FL(FIL,FLD,XR,WID,LM,TS,TYP,.PAGE)
if PAGE(U)
QUIT
+7 ;
+8 ;Print Field
+9 DO WLP^DIKCP1("Field: ",$PIECE($GET(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",WID,LM+TS,0,.PAGE)
+10 if PAGE(U)
QUIT
+11 ;
+12 ;For Triggers, print triggered field
+13 IF $PIECE($GET(^DD(FIL,FLD,1,XR,0)),U,3)["TRIG"
Begin DoDot:1
+14 NEW LAB,TFIL,TFLD
+15 SET TFIL=$PIECE(^DD(FIL,FLD,1,XR,0),U,4)
SET TFLD=$PIECE(^(0),U,5)
+16 SET LAB="Triggered Field: "
+17 DO WLP^DIKCP1(LAB,$PIECE($GET(^DD(TFIL,TFLD,0)),U)_" ("_TFIL_","_TFLD_")",WID-$LENGTH(LAB),LM+TS+$LENGTH(LAB),"",.PAGE)
End DoDot:1
if PAGE(U)
QUIT
+18 ;
+19 ;Print Description
+20 IF $ORDER(^DD(FIL,FLD,1,XR,"%D",0))
Begin DoDot:1
+21 DO WRWP^DIKCP1($NAME(^DD(FIL,FLD,1,XR,"%D")),LM,WID,"Description: ",TS,.PAGE)
End DoDot:1
if PAGE(U)
QUIT
+22 IF FLAG'["S"
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+23 ;
+24 ;Print xref nodes
+25 KILL WFLAG
+26 SET ND=0
FOR
SET ND=$ORDER(^DD(FIL,FLD,1,XR,ND))
if ND=""
QUIT
Begin DoDot:1
+27 if ND="%D"!(ND="DT")
QUIT
+28 NEW TXT
+29 SET TXT(0)=ND_")= "
+30 SET TXT(1)=^DD(FIL,FLD,1,XR,ND)
+31 IF FLAG'["S"
IF ND
IF $GET(WFLAG)
DO WRLN("",0,.PAGE)
if PAGE(U)
QUIT
+32 DO WLP^DIKCP1("",.TXT,WID,LM+TS,1,.PAGE,.WFLAG)
End DoDot:1
if PAGE(U)
QUIT
+33 QUIT
+34 ;
FL(FIL,FLD,XR,WID,LM,TS,TYP,PAGE) ;Print first line
+1 NEW NAME,SP,TYPE,TXT,WF,XR0
+2 ;
+3 SET SP=$JUSTIFY("",4)
+4 SET XR0=$GET(^DD(FIL,FLD,1,XR,0))
if XR0?."^"
QUIT
+5 SET NAME=$PIECE(XR0,U,2)
+6 SET TYPE=$PIECE(XR0,U,3)
if TYPE=""
SET TYPE="REGULAR"
+7 SET TXT=NAME_SP_TYPE
+8 ;
+9 IF $PIECE(XR0,U)
IF $PIECE(XR0,U)'=FIL
Begin DoDot:1
+10 SET TXT=TXT_SP_"WHOLE"_$CHAR(0)_"FILE"_$CHAR(0)_"(#"_$PIECE(XR0,U)_")"
End DoDot:1
+11 ;
+12 ;Print first line
+13 DO WRPHI^DIKCP1(TXT,WID,LM,TS,0,.PAGE)
+14 QUIT
+15 ;
HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header
+1 IF FLAG'["M"
IF FLAG'["R"
IF FLAG'["F"
QUIT
+2 DO WRLN("Traditional Cross-References:",LM,.PAGE,2)
if PAGE(U)
QUIT
+3 DO WRLN("",0,.PAGE)
+4 SET HDR=1
+5 QUIT
+6 ;
+7 ;
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
