- XINDX5 ;SF-ISC/RWF - CROSS REFERENCE ALL ROUTINES ;03/26/2002 09:57
- ;;7.3;TOOLKIT;**20,27,61,121,133,140**;Apr 25, 1995;Build 40
- ; Per VHA Directive 2004-038, this routine should not be modified.
- G END:$D(IND("QUIT")) I INP(8) W !,"Called Routines",! D ^XINDX52 ;Get called routines
- K ARG,CCN,CH,COM,ERR,GK,GRB,I,INDDA,INDDS,L,LAB,LAB0,LC,LIN,LOC,PC,PRV,R,RTN,S,STR,TXT,V,X,Y
- D ^XINDX53:INP(7) ;Load routine file
- ;Check called tags and routines
- S RN="$",TXT="" W !!,"--- CROSS REFERENCING ---",!
- A S RN=$O(^UTILITY($J,RN)),L="",LABO=0 I RN="" G B
- F S L=$O(^UTILITY($J,1,RN,"X",L)) Q:L="" S XX2=^(L,0),XX1=$P(L," ",2),T=$P(XX1,"+",1),P=$P(L," ",1) D AA
- G A
- AA Q:P="" I '$D(^UTILITY($J,1,P)) D Q ;We can now check % routines
- . I (P["&")!(P["@") Q ;External subroutine
- . S:T["$" T=$E(T,3,99) S:P["(" P=$P(P,"(")
- . I '$$VTAG(P) S ERR=52,ERR(1)=P D AAER(.ERR,RN,"",0) Q
- . S X=$T(^@P) I X="" S ERR=52,ERR(1)=P D AAER(.ERR,RN,$P(XX2,","),0) Q
- . Q:T=""
- . I '$$VTAG(T) D AAER(37,RN,$P(XX2,","),0) Q
- . I $$VTAG(T),$T(@T^@P)="" S E=38,E(1)="MISSING LABEL "_XX1_"^"_P D AAER(.E,RN,"",0)
- . Q
- I T]"",$D(^UTILITY($J,1,P)) D
- . S:T["$$" T=$E(T,3,99) S:T["@" T=""
- . I T]"",'$D(^UTILITY($J,1,P,"T",T)) S E=38,E(1)="MISSING LABEL (see INVOKED BY list)." D AAER(.E,P,XX1,0)
- Q
- AAER(ERR,RTN,LAB,LABO) ;Report error. error code, routine, label, label offset
- D ^XINDX1
- Q
- VTAG(K) ;Check for a valid tag. works for routine name.
- Q (K?1(1"%",1A).15NA)!(K?1.16N)
- ;
- B D ^XINDX51
- END W:$D(IND("QUIT")) !!,"--- ",$S($D(ZTSTOP):"TASK ",1:""),"STOPPED ---" W !!,"--- END ---"
- I IO'=IO(0) U IO(0) W !,"--- D O N E ---" U IO
- D ^%ZISC
- S:$D(ZTQUEUED) ZTREQ="@"
- CLEAN ;Come here from XINDX6 if queued output.
- K %,%1,%2,%I1,%IN1,%UCN,A,ARG,C,C9,CCN,CH,COM,DA,DIC,DUOUT,ERR,ERTX,F,F1,G,GK,GRB,H,HED,HS
- K ^UTILITY($J),I,IND,INDB,INDC,INDDA,INDDS,INDF,INDFN,INDLC,INDPM,INDX,INDXDT,INDXJ,INP,IP,J,K,K1,K3,L,LAB,LABO,LBL,LC,LIN,LINE,LOC,NRO,OFF,P,PC,PGM,POP,POST,Q,R,RDTIME,RHS,ROU,RTN,S,S1,STR,SYM,TAB,TAG,TXT,TY,V,VZ,X,X1,X2,X3,Y
- Q
- CRX S RTN="$" F I=0:0 S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" F LOC="L","G","O","MK","N","X" D CR0 ;patch 121
- K VZ Q
- ;
- CR0 N VZ S S=-1 I LOC="X",'$D(^UTILITY($J,1,"***","X",RTN_" ")) S ^UTILITY($J,1,"***","X",RTN_" ")=""
- CR1 S S=$O(^UTILITY($J,1,RTN,LOC,S)) Q:S="" ;Loop
- S X=$G(^UTILITY($J,1,RTN,LOC,S))
- F J=1:1:$L(X) S:$G(^UTILITY($J,1,"***",LOC,S))'[$E(X,J) ^(S)=$G(^(S))_$E(X,J) ;Pass on flags
- F J=0:1 Q:'$D(^UTILITY($J,1,RTN,LOC,S,J)) D CR2
- G CR1
- ;
- CR2 S PC="" I LOC'="X" S:^UTILITY($J,1,RTN,LOC,S,J)["*" PC=PC_"*" S:^(J)["!" PC=PC_"!" S:^(J)["~" PC=PC_"~" D CR3(RTN,S,LOC) Q
- Q:$D(VZ(S)) S S1=$S($P(S," ",2)]"":$P(S," ",2)_"^",1:"")_$P(S," ",1),VZ(S)=""
- ;S X1=LOC,X2=S,X3=RTN,LOC="Z",S=RTN,RTN=S1 D CR3 S LOC=X1,S=X2,RTN=X3 K X1,X2,X3
- D CR3(S1,RTN,"Z"),CR3(RTN,S,LOC)
- Q
- CR3(X1,X2,X3) ;(RTN,REF,LOC)
- S K=0
- CR4 S ARG="" I $D(^UTILITY($J,1,"***",X3,X2,K)) S ARG=^(K) I $L(ARG)>230 S K=K+1 G CR4
- S ^UTILITY($J,1,"***",X3,X2,K)=ARG_X1_PC_"," Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXINDX5 3081 printed Feb 19, 2025@00:06:31 Page 2
- XINDX5 ;SF-ISC/RWF - CROSS REFERENCE ALL ROUTINES ;2018-02-22 12:56 PM
- +1 ;;7.3;TOOLKIT;**20,27,61,121,133,10001**;Apr 25, 1995;Build 4
- +2 ; Routine originally authored by Department of Veterans Affairs
- +3 ; VTAG+1 modified by John McCormack
- +4 ;Get called routines
- if $DATA(IND("QUIT"))
- GOTO END
- IF INP(8)
- WRITE !,"Called Routines",!
- DO ^XINDX52
- +5 KILL ARG,CCN,CH,COM,ERR,GK,GRB,I,INDDA,INDDS,L,LAB,LAB0,LC,LIN,LOC,PC,PRV,R,RTN,S,STR,TXT,V,X,Y
- +6 ;Load routine file
- if INP(7)
- DO ^XINDX53
- +7 ;Check called tags and routines
- +8 SET RN="$"
- SET TXT=""
- WRITE !!,"--- CROSS REFERENCING ---",!
- A SET RN=$ORDER(^UTILITY($JOB,RN))
- SET L=""
- SET LABO=0
- IF RN=""
- GOTO B
- +1 FOR
- SET L=$ORDER(^UTILITY($JOB,1,RN,"X",L))
- if L=""
- QUIT
- SET XX2=^(L,0)
- SET XX1=$PIECE(L," ",2)
- SET T=$PIECE(XX1,"+",1)
- SET P=$PIECE(L," ",1)
- DO AA
- +2 GOTO A
- AA ;We can now check % routines
- if P=""
- QUIT
- IF '$DATA(^UTILITY($JOB,1,P))
- Begin DoDot:1
- +1 ;External subroutine
- IF (P["&")!(P["@")
- QUIT
- +2 if T["$"
- SET T=$EXTRACT(T,3,99)
- if P["("
- SET P=$PIECE(P,"(")
- +3 IF '$$VTAG(P)
- SET ERR=52
- SET ERR(1)=P
- DO AAER(.ERR,RN,"",0)
- QUIT
- +4 SET X=$TEXT(^@P)
- IF X=""
- SET ERR=52
- SET ERR(1)=P
- DO AAER(.ERR,RN,$PIECE(XX2,","),0)
- QUIT
- +5 if T=""
- QUIT
- +6 IF '$$VTAG(T)
- DO AAER(37,RN,$PIECE(XX2,","),0)
- QUIT
- +7 IF $$VTAG(T)
- IF $TEXT(@T^@P)=""
- SET E=38
- SET E(1)="MISSING LABEL "_XX1_"^"_P
- DO AAER(.E,RN,"",0)
- +8 QUIT
- End DoDot:1
- QUIT
- +9 IF T]""
- IF $DATA(^UTILITY($JOB,1,P))
- Begin DoDot:1
- +10 if T["$$"
- SET T=$EXTRACT(T,3,99)
- if T["@"
- SET T=""
- +11 IF T]""
- IF '$DATA(^UTILITY($JOB,1,P,"T",T))
- SET E=38
- SET E(1)="MISSING LABEL (see INVOKED BY list)."
- DO AAER(.E,P,XX1,0)
- End DoDot:1
- +12 QUIT
- AAER(ERR,RTN,LAB,LABO) ;Report error. error code, routine, label, label offset
- +1 DO ^XINDX1
- +2 QUIT
- VTAG(K) ;Check for a valid tag. works for routine name.
- +1 QUIT (K?1(1"%",1A).15NA)!(K?1.16N)
- +2 ;
- B DO ^XINDX51
- END if $DATA(IND("QUIT"))
- WRITE !!,"--- ",$SELECT($DATA(ZTSTOP):"TASK ",1:""),"STOPPED ---"
- WRITE !!,"--- END ---"
- +1 IF IO'=IO(0)
- USE IO(0)
- WRITE !,"--- D O N E ---"
- USE IO
- +2 DO ^%ZISC
- +3 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- CLEAN ;Come here from XINDX6 if queued output.
- +1 KILL %,%1,%2,%I1,%IN1,%UCN,A,ARG,C,C9,CCN,CH,COM,DA,DIC,DUOUT,ERR,ERTX,F,F1,G,GK,GRB,H,HED,HS
- +2 --- END --- KILL ^UTILITY($JOB),I,IND,INDB,INDC,INDDA,INDDS,INDF,INDFN,INDLC,INDPM,INDX,INDXDT,INDXJ,INP,IP,J,K,K1,K3,L,LAB,LABO,LBL,LC,LIN,LINE,LOC,NRO,OFF,P,PC,PGM,POP,POST,Q,R,RDTIME,RHS,ROU,RTN,S,S1,STR,SYM,TAB,TAG,TXT,TY,V,VZ,X,X1,X2,X3,Y
- +3 QUIT
- CRX ;patch 121
- SET RTN="$"
- FOR I=0:0
- SET RTN=$ORDER(^UTILITY($JOB,RTN))
- if RTN=""
- QUIT
- FOR LOC="L","G","O","MK","N","X"
- DO CR0
- +1 KILL VZ
- QUIT
- +2 ;
- CR0 NEW VZ
- SET S=-1
- IF LOC="X"
- IF '$DATA(^UTILITY($JOB,1,"***","X",RTN_" "))
- SET ^UTILITY($JOB,1,"***","X",RTN_" ")=""
- CR1 ;Loop
- SET S=$ORDER(^UTILITY($JOB,1,RTN,LOC,S))
- if S=""
- QUIT
- +1 SET X=$GET(^UTILITY($JOB,1,RTN,LOC,S))
- +2 ;Pass on flags
- FOR J=1:1:$LENGTH(X)
- if $GET(^UTILITY($JOB,1,"***",LOC,S))'[$EXTRACT(X,J)
- SET ^(S)=$GET(^(S))_$EXTRACT(X,J)
- +3 FOR J=0:1
- if '$DATA(^UTILITY($JOB,1,RTN,LOC,S,J))
- QUIT
- DO CR2
- +4 GOTO CR1
- +5 ;
- CR2 SET PC=""
- IF LOC'="X"
- if ^UTILITY($JOB,1,RTN,LOC,S,J)["*"
- SET PC=PC_"*"
- if ^(J)["!"
- SET PC=PC_"!"
- if ^(J)["~"
- SET PC=PC_"~"
- DO CR3(RTN,S,LOC)
- QUIT
- +1 if $DATA(VZ(S))
- QUIT
- SET S1=$SELECT($PIECE(S," ",2)]"":$PIECE(S," ",2)_"^",1:"")_$PIECE(S," ",1)
- SET VZ(S)=""
- +2 ;S X1=LOC,X2=S,X3=RTN,LOC="Z",S=RTN,RTN=S1 D CR3 S LOC=X1,S=X2,RTN=X3 K X1,X2,X3
- +3 DO CR3(S1,RTN,"Z")
- DO CR3(RTN,S,LOC)
- +4 QUIT
- CR3(X1,X2,X3) ;(RTN,REF,LOC)
- +1 SET K=0
- CR4 SET ARG=""
- IF $DATA(^UTILITY($JOB,1,"***",X3,X2,K))
- SET ARG=^(K)
- IF $LENGTH(ARG)>230
- SET K=K+1
- GOTO CR4
- +1 SET ^UTILITY($JOB,1,"***",X3,X2,K)=ARG_X1_PC_","
- QUIT
