XINDX51 ;ISC/REL,GRK,RWF - PRINT ROUTINE ;06/24/08 16:06
;;7.3;TOOLKIT;**20,48,61,110,133**;Apr 25, 1995;Build 16
; 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,8)_" * * "_$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
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
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=""
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
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
S PC(1)=$G(^UTILITY($J,1,RTN,LOC,$P(L,"(")))_$S("^DT^DUZ^DTIME^IO^IOF^ION^IOM^IOSL^IOST^U^"[("^"_$P(L,"(")_"^"):"!",1:" ")
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
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
XINDX51 ;ISC/REL,GRK,RWF - PRINT ROUTINE ;06/24/08 16:06
+1 ;;7.3;TOOLKIT;**20,48,61,110,133**;Apr 25, 1995;Build 16
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;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
+1 QUIT $EXTRACT(R_" ",1,8)_" * * "_$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 FOR I=1:1
IF '$DATA(^UTILITY($JOB,1,RTN,0,I))
QUIT
SET X=^(I,0)
Begin DoDot:1
+4 IF $Y'<INL(2)
DO HD1
IF $DATA(IND("QUIT"))
SET I=99999
QUIT
+5 ;Write routine line
DO WORL(X)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
WORL(D) ;Write one routine line
+1 NEW J,L
+2 SET L=$PIECE(D," ",1)
SET D=$PIECE(D," ",2,999)
+3 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
+4 QUIT
+5 ;
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 ;Show structured listing
IF INP(5)["S"!(INP(5)["B")
DO ^XINDX8
+2 IF INP(5)["F"
DO SC
+3 ;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 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 %
READ %:300
IF '$TEST
SET %="^"
+1 IF %["?"
WRITE !,"Press return to continue the report, ^ to exit the report"
GOTO WAIT
+2 IF %="^"
SET IND("QUIT")=1
QUIT
