- 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 Feb 19, 2025@00:15:03 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
