- XINDX51 ;ISC/REL,GRK,RWF - PRINT ROUTINE ;06/24/08 16:06
- ;;7.3;TOOLKIT;**20,48,61,110,133,140,149,151**;Apr 25, 1995;Build 1
- ; Per VHA Directive 2004-038, this routine should not be modified.
- ;Setup Local IO paramiters
- B S RTN="",INL(1)=IOM-2,INL(2)=IOSL-4,INL(3)=("C"=$E(IOST)),INL(4)=IOM-1,PG=0,INL(5)="Compiled list of Errors and Warnings "
- K ER,HED D HD1 ;Do header
- ;Show Errors
- F S RTN=$O(^UTILITY($J,1,RTN)) Q:RTN=""!$D(IND("QUIT")) S X=^(RTN,0) I $D(^UTILITY($J,1,RTN,"E"))>9 S HED=$$BHDR(RTN,X) D HD,WERR(1)
- W:'$D(ER) !,"No errors or warnings to report",!
- ;Did they want more?
- G END:'INP(1)!$D(IND("QUIT")),CR:INP(6)
- ;Show detail on each routine
- W !!,"--- Routine Detail"
- W:INP(5)?1A " --- with "_$S(INP(5)["R":"REGULAR",INP(5)["S":"STRUCTURED",INP(5)["B":"R/S",1:"")_" ROUTINE LISTING" W " ---"
- S RTN="$",INDB="R" ;Report on each routine
- BL F S RTN=$O(^UTILITY($J,RTN)) Q:RTN=""!('INP(4)&(RTN?1"|"1.4L.NP))!$D(IND("QUIT")) D B1,CHK
- ;Exit or do Cross-Refference
- G END:NRO<2,END:$D(IND("QUIT")),CR
- ;
- BHDR(R,X) ;Build hdr
- Q $E(R_" ",1,15)_" * * "_$P(X,"^",2)_" Lines, "_(+X)_" Bytes, Checksum: "_$G(^UTILITY($J,1,R,"RSUM"))
- ;
- WERR(FL) ;Write error messages
- N ER2
- F ER=1:1 Q:'$D(^UTILITY($J,1,RTN,"E",ER))!$D(IND("QUIT")) S %=^(ER) D
- . I $Y'<INL(2) D HD K ER2
- . D:FL&(%>0)&($G(ER2)'=+%) WORL(^UTILITY($J,1,RTN,0,+%,0)) ;Write the routine line
- . W !?3,$P(%,$C(9),2) W:$X>16 ! W ?16,$P(%,$C(9),3) S ER2=+% ;Write the error p110
- . Q
- Q
- ;
- WR ;Write one routine
- S X=^UTILITY($J,1,RTN,0),INL(5)=$$BHDR(RTN,X)
- D HD1 W !,?14,$P(X,"^",3)_" bytes in comments" G:'INP(2) B2
- I $G(ROU),'$$WP^DIUTL($NA(^DIZ(1009.1,ROU,1)),12,IOM) S IND("QUIT")=1 ; GFT: Print Tammy's Documentation File
- F I=1:1 Q:'$D(^UTILITY($J,1,RTN,0,I)) S X=^(I,0) D
- . D:$Y'<INL(2) HD1 I $D(IND("QUIT")) S I=99999 Q
- . D WORL(X) ;Write routine line
- . Q
- Q
- ;
- WORL(D) ;Write one routine line
- N J,L
- I $G(ROU) S J=$P($P(D," "),"(") S:J]"" TAG=J S:J="" TAG=$P(TAG,"+")_"+"_($P(TAG,"+",2)+1) ; GFT: Print Tammy's Documentation File
- S L=$P(D," ",1),D=$P(D," ",2,999)
- F J=8,9:0 W !,L,?J," " W:$X>10 "--",!,?10 W $E(D,1,INL(4)-J) S D=$E(D,INL(4)-J+1,999),L="" Q:D=""
- I $G(ROU),TAG]"" S L=$O(^DIZ(1009.1,ROU,2,"B",TAG,0)) I L,'$$WP^DIUTL($NA(^DIZ(1009.1,ROU,2,L,1)),12,IOM) S IND("QUIT")=1 ; GFT ditto
- Q
- ;
- CHK I $D(ZTQUEUED),$$S^%ZTLOAD S IND("QUIT")=1,ZTSTOP=1
- S:$D(IND("QUIT")) RTN="~"
- Q
- ;
- B1 I '$D(^UTILITY($J,1,RTN,0)) Q ;No data to show
- N ROU,TAG S ROU=$O(^DIZ(1009.1,"B",RTN,0)),TAG=RTN ; GFT Tammy Docs
- S:INP(5)["N" OPT("NUM")=1
- D:INP(5)["S"!(INP(5)["B") ^XINDX8 ;Show structured listing
- D:INP(5)["F" SC
- D:INP(5)["R"!(INP(5)["B") WR ;Show normal listing
- B2 ;
- G:'INP(3)!('$D(^UTILITY($J,1,RTN,"E",0))) B3
- S HED="***** ERRORS & WARNINGS IN "_RTN_" *****" W !,HED
- D WERR(0) ;Show errors
- B3 ;
- S INL(5)="***** INDEX OF "_RTN_" *****" W !!,INL(5),!
- S HED="Local Variables Line Occurrences ( >> not killed explicitly)",HED(1)=$J("",40)_"( * Changed ! Killed ~ Newed)" D P("L","") Q:$D(IND("QUIT"))
- S HED="Global Variables ( * Changed ! Killed)" D P("G","") Q:$D(IND("QUIT"))
- S HED="Naked Globals" D P("N","") Q:$D(IND("QUIT"))
- S HED="Cache Objects" D P("O","") Q:$D(IND("QUIT"))
- S HED="Marked Items" D P("MK","") Q:$D(IND("QUIT"))
- S HED="Label References" D P("I","") Q:$D(IND("QUIT"))
- S HED="External References" D P("X","^") Q:$D(IND("QUIT"))
- W !!,"***** END *****",!
- Q
- ;
- P(LOC,SYM) ;
- S L="",PC="",TAB=$S("XG"[LOC:23,"O"[LOC:35,1:16) D HD Q:$D(IND("QUIT"))
- P1 S L=$O(^UTILITY($J,1,RTN,LOC,L)) G:L="" PX
- I LOC="X",L?1L.LNP Q
- ;p151 check for Kernel variables only if "L"ocal
- S X=$S($G(^UTILITY($J,1,RTN,LOC,L))]"":^(L),$G(^UTILITY($J,1,RTN,LOC,$P(L,"(")))]"":^($P(L,"(")),1:"")
- I LOC="L" S PC(1)=X_$S("^DT^DTIME^DILOCKTM^DUZ^IO^IOF^ION^IOM^IOSL^IOST^U^"[("^"_L_"^"):"!",1:" ")
- E S PC(1)=X_" "
- ;S PC(1)=$G(^UTILITY($J,1,RTN,LOC,$P(L,"(")))_$S("^DT^DTIME^DILOCKTM^DUZ^IO^IOF^ION^IOM^IOSL^IOST^U^"[("^"_$P(L,"(")_"^"):"!",1:" ") ;p149 added DILOCKTM
- S PC(1)=(PC(1)["!")!(PC(1)["~"),PC="*"
- F J=0:1 S X=$S($D(^UTILITY($J,1,RTN,LOC,L,J)):^(J),1:"") Q:X=""!$D(IND("QUIT")) D P2,P3
- G P1
- PX W:PC="" !?3,"NONE" K HED
- Q
- P2 I $Y'<INL(2) D HD S PC="*"
- Q:PC=L
- I LOC="L" W !,$S(('PC(1)):">> ",1:" "),SYM,L," ",?TAB Q
- I LOC'="X" W !," ",SYM,L,?TAB Q
- W !?3,$P(L," ",2),SYM,$P(L," ",1)," ",?TAB
- Q
- P3 W:$X>TAB !,?TAB
- S PC=L F I=1:1 S ARG=$P(X,",",I) Q:ARG="" W:$X+$L(ARG)>INL(1) !?TAB W:$X'=TAB "," W ARG
- I $G(ROU),LOC="L" S I=$O(^DIZ(1009.1,ROU,3,"B",L,0)) I I,'$$WP^DIUTL($NA(^DIZ(1009.1,ROU,3,I,1)),14,IOM) S IND("QUIT")=1 ; GFT Tammy Docs
- Q
- HD D:$Y'<INL(2) HD1 D HD2
- Q
- HD1 D WAIT:INL(3) S PG=PG+1 W @IOF,!,INL(5) W:(IOM-30)<$X ! W ?(IOM-30),INDXDT," page ",PG
- Q
- HD2 W !!,HED W:$D(HED(1)) !,HED(1)
- Q
- CR S INDB="C" U IO(0) W !!,"--- CROSS-REFERENCING ALL ROUTINES ---" U IO
- S RTN="$" D CRX^XINDX5
- S INL(5)="***** Cross Reference of all Routines *****",RTN="***" D HD1
- S HED="Local Variables Routines ( >> not killed explicitly)",HED(1)=$J("",30)_"( * Changed ! Killed ~ Newed)" D P("L","") G:$D(IND("QUIT")) END
- S HED="Global Variables" D P("G","") G:$D(IND("QUIT")) END
- S HED="Naked Globals" D P("N","") Q:$D(IND("QUIT"))
- S HED="Cache Objects" D P("O","") Q:$D(IND("QUIT"))
- S HED="Marked Items" D P("MK","") G:$D(IND("QUIT")) END
- S HED="Routine Invokes:" D P("Z","") G:$D(IND("QUIT")) END
- S HED="Routine is Invoked by:" D P("X","^")
- W !!,"***** END *****",!
- END K INL,HED Q
- SC ;Print a command chart
- S INL(5)=RTN_" Command chart" D HD1
- F I=0:0 S I=$O(^UTILITY($J,1,RTN,"COM",I)) Q:I'>0 W !,^(I)
- Q
- WAIT N % W !," Press return to continue:" R %:300 S:'$T %="^"
- I %["?" W !,"Press return to continue the report, ^ to exit the report" G WAIT
- S:%="^" IND("QUIT")=1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXINDX51 5791 printed Mar 13, 2025@21:45:07 Page 2
- XINDX51 ;ISC/REL,GRK,RWF - PRINT ROUTINE ;2018-02-22 2:42 PM
- +1 ;;7.3;TOOLKIT;**20,48,61,110,133,10001**;Apr 25, 1995;Build 4
- +2 ; Original routine authored by Department of Veterans Affairs
- +3 ; B1+1 added by David Whitten 2018
- +4 ; BHDR+1 corrected by Geroge Timson 2018
- +5 ; WR,WORL,B1,P3 modified by George Timson 2018
- +6 ;Setup Local IO paramiters
- B SET RTN=""
- SET INL(1)=IOM-2
- SET INL(2)=IOSL-4
- SET INL(3)=("C"=$EXTRACT(IOST))
- SET INL(4)=IOM-1
- SET PG=0
- SET INL(5)="Compiled list of Errors and Warnings "
- +1 ;Do header
- KILL ER,HED
- DO HD1
- +2 ;Show Errors
- +3 FOR
- SET RTN=$ORDER(^UTILITY($JOB,1,RTN))
- if RTN=""!$DATA(IND("QUIT"))
- QUIT
- SET X=^(RTN,0)
- IF $DATA(^UTILITY($JOB,1,RTN,"E"))>9
- SET HED=$$BHDR(RTN,X)
- DO HD
- DO WERR(1)
- +4 if '$DATA(ER)
- WRITE !,"No errors or warnings to report",!
- +5 ;Did they want more?
- +6 if 'INP(1)!$DATA(IND("QUIT"))
- GOTO END
- if INP(6)
- GOTO CR
- +7 ;Show detail on each routine
- +8 WRITE !!,"--- Routine Detail"
- +9 if INP(5)?1A
- WRITE " --- with "_$SELECT(INP(5)["R":"REGULAR",INP(5)["S":"STRUCTURED",INP(5)["B":"R/S",1:"")_" ROUTINE LISTING"
- WRITE " ---"
- +10 ;Report on each routine
- SET RTN="$"
- SET INDB="R"
- BL FOR
- SET RTN=$ORDER(^UTILITY($JOB,RTN))
- if RTN=""!('INP(4)&(RTN?1"|"1.4L.NP))!$DATA(IND("QUIT"))
- QUIT
- DO B1
- DO CHK
- +1 ;Exit or do Cross-Refference
- +2 if NRO<2
- GOTO END
- if $DATA(IND("QUIT"))
- GOTO END
- GOTO CR
- +3 ;
- BHDR(R,X) ;Build hdr ; (GFT d 8 -> 15 to print whole routine name)
- +1 QUIT $EXTRACT(R_" ",1,15)_" * * "_$PIECE(X,"^",2)_" Lines, "_(+X)_" Bytes, Checksum: "_$GET(^UTILITY($JOB,1,R,"RSUM"))
- +2 ;
- WERR(FL) ;Write error messages
- +1 NEW ER2
- +2 FOR ER=1:1
- if '$DATA(^UTILITY($JOB,1,RTN,"E",ER))!$DATA(IND("QUIT"))
- QUIT
- SET %=^(ER)
- Begin DoDot:1
- +3 IF $Y'<INL(2)
- DO HD
- KILL ER2
- +4 ;Write the routine line
- if FL&(%>0)&($GET(ER2)'=+%)
- DO WORL(^UTILITY($JOB,1,RTN,0,+%,0))
- +5 ;Write the error p110
- WRITE !?3,$PIECE(%,$CHAR(9),2)
- if $X>16
- WRITE !
- WRITE ?16,$PIECE(%,$CHAR(9),3)
- SET ER2=+%
- +6 QUIT
- End DoDot:1
- +7 QUIT
- +8 ;
- WR ;Write one routine
- +1 SET X=^UTILITY($JOB,1,RTN,0)
- SET INL(5)=$$BHDR(RTN,X)
- +2 DO HD1
- WRITE !,?14,$PIECE(X,"^",3)_" bytes in comments"
- if 'INP(2)
- GOTO B2
- +3 ; GFT addition: Print Tammy's Documentation File
- IF $GET(ROU)
- IF '$$WP^DIUTL($NAME(^DIZ(1009.1,ROU,1)),12,IOM)
- SET IND("QUIT")=1
- +4 FOR I=1:1
- if '$DATA(^UTILITY($JOB,1,RTN,0,I))
- QUIT
- SET X=^(I,0)
- Begin DoDot:1
- +5 if $Y'<INL(2)
- DO HD1
- IF $DATA(IND("QUIT"))
- SET I=99999
- QUIT
- +6 ;Write routine line
- DO WORL(X)
- +7 QUIT
- End DoDot:1
- +8 QUIT
- +9 ;
- WORL(D) ;Write one routine line
- +1 NEW J,L
- +2 ; GFT addition: Print Tammy's Documentation File
- IF $GET(ROU)
- SET J=$PIECE($PIECE(D," "),"(")
- if J]""
- SET TAG=J
- if J=""
- SET TAG=$PIECE(TAG,"+")_"+"_($PIECE(TAG,"+",2)+1)
- +3 SET L=$PIECE(D," ",1)
- SET D=$PIECE(D," ",2,999)
- +4 FOR J=8,9:0
- WRITE !,L,?J," "
- if $X>10
- WRITE "--",!,?10
- WRITE $EXTRACT(D,1,INL(4)-J)
- SET D=$EXTRACT(D,INL(4)-J+1,999)
- SET L=""
- if D=""
- QUIT
- +5 ; GFT ditto
- IF $GET(ROU)
- IF TAG]""
- SET L=$ORDER(^DIZ(1009.1,ROU,2,"B",TAG,0))
- IF L
- IF '$$WP^DIUTL($NAME(^DIZ(1009.1,ROU,2,L,1)),12,IOM)
- SET IND("QUIT")=1
- +6 QUIT
- +7 ;
- CHK IF $DATA(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET IND("QUIT")=1
- SET ZTSTOP=1
- +1 if $DATA(IND("QUIT"))
- SET RTN="~"
- +2 QUIT
- +3 ;
- B1 ;No data to show
- IF '$DATA(^UTILITY($JOB,1,RTN,0))
- QUIT
- +1 ; GFT Tammy Docs
- NEW ROU,TAG
- SET ROU=$ORDER(^DIZ(1009.1,"B",RTN,0))
- SET TAG=RTN
- +2 if INP(5)["N"
- SET OPT("NUM")=1
- +3 ;Show structured listing
- if INP(5)["S"!(INP(5)["B")
- DO ^XINDX8
- +4 if INP(5)["F"
- DO SC
- +5 ;Show normal listing
- if INP(5)["R"!(INP(5)["B")
- DO WR
- B2 ;
- +1 if 'INP(3)!('$DATA(^UTILITY($JOB,1,RTN,"E",0)))
- GOTO B3
- +2 SET HED="***** ERRORS & WARNINGS IN "_RTN_" *****"
- WRITE !,HED
- +3 ;Show errors
- DO WERR(0)
- B3 ;
- +1 SET INL(5)="***** INDEX OF "_RTN_" *****"
- WRITE !!,INL(5),!
- +2 SET HED="Local Variables Line Occurrences ( >> not killed explicitly)"
- SET HED(1)=$JUSTIFY("",40)_"( * Changed ! Killed ~ Newed)"
- DO P("L","")
- if $DATA(IND("QUIT"))
- QUIT
- +3 SET HED="Global Variables ( * Changed ! Killed)"
- DO P("G","")
- if $DATA(IND("QUIT"))
- QUIT
- +4 SET HED="Naked Globals"
- DO P("N","")
- if $DATA(IND("QUIT"))
- QUIT
- +5 SET HED="Cache Objects"
- DO P("O","")
- if $DATA(IND("QUIT"))
- QUIT
- +6 SET HED="Marked Items"
- DO P("MK","")
- if $DATA(IND("QUIT"))
- QUIT
- +7 SET HED="Label References"
- DO P("I","")
- if $DATA(IND("QUIT"))
- QUIT
- +8 SET HED="External References"
- DO P("X","^")
- if $DATA(IND("QUIT"))
- QUIT
- +9 WRITE !!,"***** END *****",!
- +10 QUIT
- +11 ;
- P(LOC,SYM) ;
- +1 SET L=""
- SET PC=""
- SET TAB=$SELECT("XG"[LOC:23,"O"[LOC:35,1:16)
- DO HD
- if $DATA(IND("QUIT"))
- QUIT
- P1 SET L=$ORDER(^UTILITY($JOB,1,RTN,LOC,L))
- if L=""
- GOTO PX
- +1 IF LOC="X"
- IF L?1L.LNP
- QUIT
- +2 SET PC(1)=$GET(^UTILITY($JOB,1,RTN,LOC,$PIECE(L,"(")))_$SELECT("^DT^DUZ^DTIME^IO^IOF^ION^IOM^IOSL^IOST^U^"[("^"_$PIECE(L,"(")_"^"):"!",1:" ")
- +3 SET PC(1)=(PC(1)["!")!(PC(1)["~")
- SET PC="*"
- +4 FOR J=0:1
- SET X=$SELECT($DATA(^UTILITY($JOB,1,RTN,LOC,L,J)):^(J),1:"")
- if X=""!$DATA(IND("QUIT"))
- QUIT
- DO P2
- DO P3
- +5 GOTO P1
- PX if PC=""
- WRITE !?3,"NONE"
- KILL HED
- +1 QUIT
- P2 IF $Y'<INL(2)
- DO HD
- SET PC="*"
- +1 if PC=L
- QUIT
- +2 IF LOC="L"
- WRITE !,$SELECT(('PC(1)):">> ",1:" "),SYM,L," ",?TAB
- QUIT
- +3 IF LOC'="X"
- WRITE !," ",SYM,L,?TAB
- QUIT
- +4 WRITE !?3,$PIECE(L," ",2),SYM,$PIECE(L," ",1)," ",?TAB
- +5 QUIT
- P3 if $X>TAB
- WRITE !,?TAB
- +1 SET PC=L
- FOR I=1:1
- SET ARG=$PIECE(X,",",I)
- if ARG=""
- QUIT
- if $X+$LENGTH(ARG)>INL(1)
- WRITE !?TAB
- if $X'=TAB
- WRITE ","
- WRITE ARG
- +2 ; GFT Tammy Docs
- IF $GET(ROU)
- IF LOC="L"
- SET I=$ORDER(^DIZ(1009.1,ROU,3,"B",L,0))
- IF I
- IF '$$WP^DIUTL($NAME(^DIZ(1009.1,ROU,3,I,1)),14,IOM)
- SET IND("QUIT")=1
- +3 QUIT
- HD if $Y'<INL(2)
- DO HD1
- DO HD2
- +1 QUIT
- HD1 if INL(3)
- DO WAIT
- SET PG=PG+1
- WRITE @IOF,!,INL(5)
- if (IOM-30)<$X
- WRITE !
- WRITE ?(IOM-30),INDXDT," page ",PG
- +1 QUIT
- HD2 WRITE !!,HED
- if $DATA(HED(1))
- WRITE !,HED(1)
- +1 QUIT
- CR SET INDB="C"
- USE IO(0)
- WRITE !!,"--- CROSS-REFERENCING ALL ROUTINES ---"
- USE IO
- +1 SET RTN="$"
- DO CRX^XINDX5
- +2 SET INL(5)="***** Cross Reference of all Routines *****"
- SET RTN="***"
- DO HD1
- +3 SET HED="Local Variables Routines ( >> not killed explicitly)"
- SET HED(1)=$JUSTIFY("",30)_"( * Changed ! Killed ~ Newed)"
- DO P("L","")
- if $DATA(IND("QUIT"))
- GOTO END
- +4 SET HED="Global Variables"
- DO P("G","")
- if $DATA(IND("QUIT"))
- GOTO END
- +5 SET HED="Naked Globals"
- DO P("N","")
- if $DATA(IND("QUIT"))
- QUIT
- +6 SET HED="Cache Objects"
- DO P("O","")
- if $DATA(IND("QUIT"))
- QUIT
- +7 SET HED="Marked Items"
- DO P("MK","")
- if $DATA(IND("QUIT"))
- GOTO END
- +8 SET HED="Routine Invokes:"
- DO P("Z","")
- if $DATA(IND("QUIT"))
- GOTO END
- +9 SET HED="Routine is Invoked by:"
- DO P("X","^")
- +10 WRITE !!,"***** END *****",!
- END KILL INL,HED
- QUIT
- SC ;Print a command chart
- +1 SET INL(5)=RTN_" Command chart"
- DO HD1
- +2 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,1,RTN,"COM",I))
- if I'>0
- QUIT
- WRITE !,^(I)
- +3 QUIT
- WAIT NEW %
- WRITE !," Press return to continue:"
- READ %:300
- if '$TEST
- SET %="^"
- +1 Press return to continue: IF %["?"
- WRITE !,"Press return to continue the report, ^ to exit the report"
- GOTO WAIT
- +2 if %="^"
- SET IND("QUIT")=1
- QUIT
