XINDEX ;ISC/REL,GFT,GRK,RWF - INDEX & CROSS-REFERENCE ;08/04/08 13:19
;;7.3;TOOLKIT;**20,27,48,61,66,68,110,121,128,132,133**;Apr 25, 1995;Build 16
; Per VHA Directive 2004-038, this routine should not be modified.
G ^XINDX6
SEP F I=1:1 S CH=$E(LIN,I) D QUOTE:CH=Q Q:" "[CH
S ARG=$E(LIN,1,I-1) S:CH=" " I=I+1 S LIN=$E(LIN,I,999) Q
QUOTE F I=I+1:1 S CH=$E(LIN,I) Q:CH=""!(CH=Q)
Q:CH]"" S ERR=6 G ^XINDX1
ALIVE ;enter here from taskman
D SETUP^XINDX7 ;Get ready to process
A2 S RTN=$O(^UTILITY($J,RTN)) G ^XINDX5:RTN=""
S INDLC=(RTN?1"|"1.4L.NP) D LOAD:'INDLC&'$D(^UTILITY($J,1,RTN,0))
I $D(ZTQUEUED),$$S^%ZTLOAD S RTN="~",IND("QUIT")=1,ZTSTOP=1 G A2
I 'INDDS,INDLC W !!?10,"Data Dictionaries",! S INDDS=1
D BEG
G A2
;
LOAD S X=RTN,XCNP=0,DIF="^UTILITY("_$J_",1,RTN,0," X ^%ZOSF("TEST") Q:'$T X ^%ZOSF("LOAD") S ^UTILITY($J,1,RTN,0,0)=XCNP-1
I $D(^UTILITY($J,1,RTN,0,0)) S ^UTILITY($J,1,RTN,"RSUM")="B"_$$SUMB^XPDRSUM($NA(^UTILITY($J,1,RTN,0)))
Q
BEG ;
S %=INDLC*5 W:$X+10+%>IOM ! W RTN,$J("",10+%-$L(RTN))
S (IND("DO"),IND("SZT"),IND("SZC"),LABO)=0,LC=$G(^UTILITY($J,1,RTN,0,0))
I LC="" W !,">>>Routine '",RTN,"' not found <<<",! Q
S TXT="",LAB=$P(^UTILITY($J,1,RTN,0,1,0)," ") I RTN'=$P(LAB,"(") D E^XINDX1(17)
I 'INDLC,LAB["(" D E^XINDX1(55) S LAB=$P(LAB,"(")
;if M routine(not compiled template or DD) and has more than 2 lines, check lines 1 & 2
I 'INDLC,LC>2 D
. N LABO S LABO=1
. S LIN=$G(^UTILITY($J,1,RTN,0,1,0)),TXT=1
. ;check 1st line (site/dev - ) patch 128
. I $P(LIN,";",2,4)'?.E1"/".E.1"-".E D E^XINDX1(62)
. S LIN=$G(^UTILITY($J,1,RTN,0,2,0)),TXT=2
. ;check 2nd line (;;nn.nn[TV]nn;package;.anything)
. I $P(LIN,";",3,99)'?1.2N1"."1.2N.1(1"T",1"V").2N1";"1A.APN1";".E D E^XINDX1(44) ;patch 132
. I $L(INP(11)) X INP(11) ;Version number check
. I $L(INP(12)) X INP(12) ;Patch number check
B5 F TXT=1:1:LC S LIN=^UTILITY($J,1,RTN,0,TXT,0),LN=$L(LIN),IND("SZT")=IND("SZT")+LN+2 D LN,ST ;Process Line
S LAB="",LABO=0,TXT=0,^UTILITY($J,1,RTN,0)=IND("SZT")_"^"_LC_"^"_IND("SZC")
I IND("SZT")>INP("MAX"),'INDLC S ERR=35,ERR(1)=IND("SZT") D ^XINDX1
I IND("SZT")-IND("SZC")>INP("CMAX"),'INDLC S ERR=58,ERR(1)=IND("SZT")-IND("SZC") D ^XINDX1
D POSTRTN
Q
;Proccess one line, LN = Length, LIN = Line.
LN K V S (ARG,GRB,IND("COM"),IND("DOL"),IND("F"))="",X=$P(LIN," ")
I '$L(X) S LABO=LABO+1 G CD
S (IND("COM"),LAB)=$P(X,"("),ARG=$P($P(X,"(",2),")"),LABO=0,IND("PP")=X?1.8E1"(".E1")"
D:$L(ARG) NE^XINDX3 ;Process formal parameters as New list.
I 'INDLC,'$$VT^XINDX2(LAB) D E^XINDX1($S(LAB=$$CASE^XINDX52(LAB):37,1:55)) ;Check for bad labels
I $D(^UTILITY($J,1,RTN,"T",LAB)) D E^XINDX1(15) G CD ;DUP label
S ^UTILITY($J,1,RTN,"T",LAB)=""
CD I LN>245 D:'(LN=246&($E(RTN,1,3)="|dd")) E^XINDX1(19) ;patch 119
D:LIN'?1.ANP E^XINDX1(18)
S LIN=$P(LIN," ",2,999),IND("LCC")=1
I LIN="" D E^XINDX1(42) Q ;Blank line ;p110
S I=0 ;Watch the scope of I, counts dots
I " ."[$E(LIN) D S X=$L($E(LIN,1,I),".")-1,LIN=$E(LIN,I,999)
. F I=1:1:245 Q:". "'[$E(LIN,I)
. Q
;check dots against Do level IND("DO"), IND("DOL")=dot level
D:'I&$G(IND("DO1")) E^XINDX1(51) S IND("DO1")=0 S:'I IND("DO")=0
I I D:X>IND("DO") E^XINDX1(51) S (IND("DO"),IND("DOL"))=X
;Count Comment lines, skip ;; lines
I $E(LIN)=";",$E(LIN,2)'=";" S IND("SZC")=IND("SZC")+$L(LIN) ;p110
;Process commands on line.
EE I LIN="" D ^XINDX2 Q
S COM=$E(LIN),GK="",ARG=""
I COM=";" S LIN="" G EE ;p110
I COM=" " S ERR=$S(LIN?1." ":13,1:0),LIN=$S(ERR:"",1:$E(LIN,2,999)) D:ERR ^XINDX1 G EE
D SEP
S CM=$P(ARG,":",1),POST=$P(ARG,":",2,999),IND("COM")=IND("COM")_$C(9)_COM,ERR=48
D:ARG[":"&(POST']"") ^XINDX1 S:POST]"" GRB=GRB_$C(9)_POST,IND("COM")=IND("COM")_":"
;SAC now allows lowercase commands
I CM?.E1L.E S CM=$$CASE^XINDX52(CM),COM=$E(CM) ;I IND("LCC") S IND("LCC")=0 D E^XINDX1(47)
I CM="" D E^XINDX1(21) G EE ;Missing command
S CX=$G(IND("CMD",CM)) I CX="" D G:CX="" EE
. I $E(CM)="Z" S CX="^Z" Q ;Proccess Z commands
. D E^XINDX1(1) S LIN="" Q
S CX=$P(CX,"^",2,9)
D SEP I '$L(LIN),CH=" " D E^XINDX1(13) ;trailing space
I ARG="","CGJMORSUWX"[COM S ERR=49 G ^XINDX1
I CX>0 D E^XINDX1(CX) S CX=""
D:$L(CX) @CX S:ARG'="" GRB=GRB_$C(9)_ARG G EE
B S ERR=25 G ^XINDX1
C S ERR=29 G ^XINDX1
D G DG1^XINDX4
E Q:ARG="" S ERR=7 G ^XINDX1
F G:ARG]"" FR^XINDX4 S IND("F")=1 Q
G G DG^XINDX4
H Q:ARG'="" S ERR=32 G ^XINDX1
J S ERR=36,ARG="" G ^XINDX1
K S ERR=$S(ARG?1"(".E:22,ARG?." ":23,1:0) D:ERR ^XINDX1
G KL^XINDX3
L G LO^XINDX4
M G S^XINDX3
N G NE^XINDX3
O S ERR=34 D ^XINDX1,O^XINDX3 Q
Q Q:ARG="" G Q^XINDX4
R S RDTIME=0 G RD^XINDX3
S G S^XINDX3
TR Q ;What to process. p110
U S ARG=$S("$"'=$E(ARG):$P(ARG,":"),1:ARG) Q
V S ARG="",ERR=20 G ^XINDX1
W G WR^XINDX4
X G XE^XINDX4
Z S ERR=2 D ^XINDX1 G ZC^XINDX4
;
;Save off items from line.
ST S R=LAB_$S(LABO:"+"_LABO,1:"")
;Local variable, Global, Marked Items, Naked global, Internal ref, eXternal ref., Tag ref.
S LOC="" F S LOC=$O(V(LOC)),S="" Q:LOC="" F S S=$O(V(LOC,S)) Q:S="" D SET
S ^UTILITY($J,1,RTN,"COM",TXT)=IND("COM")
Q
;
SET I V(LOC,S)]"" F %="!","~" I V(LOC,S)[%,$G(^UTILITY($J,1,RTN,LOC,S))'[% S ^(S)=$G(^(S))_%
S %=0
SE2 S ARG=$G(^UTILITY($J,1,RTN,LOC,S,%)) I $L(ARG)>230 S %=%+1 G SE2
S ^UTILITY($J,1,RTN,LOC,S,%)=ARG_R_V(LOC,S)_","
Q
;
POSTRTN ;Do more overall checking
N V,E,T,T1,T2
S T="" ;Check for missing Labels
F S T=$O(^UTILITY($J,1,RTN,"I",T)),T2=T Q:T="" S T1=$G(^(T,0)) D
. Q:$E(T2,1,2)="@("
. S:$E(T2,1,2)="$$" T2=$E(T2,3,99)
. I T2]"",'$D(^UTILITY($J,1,RTN,"T",$P(T2,"+",1))) D
. . F I=1:1:$L(T1,",")-1 S LAB=$P(T1,",",I),LABO=+$P(LAB,"+",2),LAB=$P(LAB,"+"),E=14,E(1)=T D E^XINDX1(.E)
. . Q
. Q
S LAB="",LABO=0 ;Check for valid label names
I 'INDLC F S LAB=$O(^UTILITY($J,1,RTN,"T",LAB)) Q:LAB="" D
. I '$$VA^XINDX2(LAB) D E^XINDX1(55) Q
. D:'$$VT^XINDX2(LAB) E^XINDX1(37)
. Q
S LAB="",LABO=0 ;Check for valid variable names.
F S LAB=$O(^UTILITY($J,1,RTN,"L",LAB)) Q:LAB="" D
. D VLNF^XINDX3($P(LAB,"("))
. Q
Q
;
QUICK ;Quick, Just get a routine an print the results
D QUICK^XINDX6()
Q
XINDEX ;ISC/REL,GFT,GRK,RWF - INDEX & CROSS-REFERENCE ;08/04/08 13:19
+1 ;;7.3;TOOLKIT;**20,27,48,61,66,68,110,121,128,132,133**;Apr 25, 1995;Build 16
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 GOTO ^XINDX6
SEP FOR I=1:1
SET CH=$EXTRACT(LIN,I)
IF CH=Q
DO QUOTE
IF " "[CH
QUIT
+1 SET ARG=$EXTRACT(LIN,1,I-1)
IF CH=" "
SET I=I+1
SET LIN=$EXTRACT(LIN,I,999)
QUIT
QUOTE FOR I=I+1:1
SET CH=$EXTRACT(LIN,I)
IF CH=""!(CH=Q)
QUIT
+1 IF CH]""
QUIT
SET ERR=6
GOTO ^XINDX1
ALIVE ;enter here from taskman
+1 ;Get ready to process
DO SETUP^XINDX7
A2 SET RTN=$ORDER(^UTILITY($JOB,RTN))
IF RTN=""
GOTO ^XINDX5
+1 SET INDLC=(RTN?1"|"1.4L.NP)
IF 'INDLC&'$DATA(^UTILITY($JOB,1,RTN,0))
DO LOAD
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET RTN="~"
SET IND("QUIT")=1
SET ZTSTOP=1
GOTO A2
+3 IF 'INDDS
IF INDLC
WRITE !!?10,"Data Dictionaries",!
SET INDDS=1
+4 DO BEG
+5 GOTO A2
+6 ;
LOAD SET X=RTN
SET XCNP=0
SET DIF="^UTILITY("_$JOB_",1,RTN,0,"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
XECUTE ^%ZOSF("LOAD")
SET ^UTILITY($JOB,1,RTN,0,0)=XCNP-1
+1 IF $DATA(^UTILITY($JOB,1,RTN,0,0))
SET ^UTILITY($JOB,1,RTN,"RSUM")="B"_$$SUMB^XPDRSUM($NAME(^UTILITY($JOB,1,RTN,0)))
+2 QUIT
BEG ;
+1 SET %=INDLC*5
IF $X+10+%>IOM
WRITE !
WRITE RTN,$JUSTIFY("",10+%-$LENGTH(RTN))
+2 SET (IND("DO"),IND("SZT"),IND("SZC"),LABO)=0
SET LC=$GET(^UTILITY($JOB,1,RTN,0,0))
+3 IF LC=""
WRITE !,">>>Routine '",RTN,"' not found <<<",!
QUIT
+4 SET TXT=""
SET LAB=$PIECE(^UTILITY($JOB,1,RTN,0,1,0)," ")
IF RTN'=$PIECE(LAB,"(")
DO E^XINDX1(17)
+5 IF 'INDLC
IF LAB["("
DO E^XINDX1(55)
SET LAB=$PIECE(LAB,"(")
+6 ;if M routine(not compiled template or DD) and has more than 2 lines, check lines 1 & 2
+7 IF 'INDLC
IF LC>2
Begin DoDot:1
+8 NEW LABO
SET LABO=1
+9 SET LIN=$GET(^UTILITY($JOB,1,RTN,0,1,0))
SET TXT=1
+10 ;check 1st line (site/dev - ) patch 128
+11 IF $PIECE(LIN,";",2,4)'?.E1"/".E.1"-".E
DO E^XINDX1(62)
+12 SET LIN=$GET(^UTILITY($JOB,1,RTN,0,2,0))
SET TXT=2
+13 ;check 2nd line (;;nn.nn[TV]nn;package;.anything)
+14 ;patch 132
IF $PIECE(LIN,";",3,99)'?1.2N1"."1.2N.1(1"T",1"V").2N1";"1A.APN1";".E
DO E^XINDX1(44)
+15 ;Version number check
IF $LENGTH(INP(11))
XECUTE INP(11)
+16 ;Patch number check
IF $LENGTH(INP(12))
XECUTE INP(12)
End DoDot:1
B5 ;Process Line
FOR TXT=1:1:LC
SET LIN=^UTILITY($JOB,1,RTN,0,TXT,0)
SET LN=$LENGTH(LIN)
SET IND("SZT")=IND("SZT")+LN+2
DO LN
DO ST
+1 SET LAB=""
SET LABO=0
SET TXT=0
SET ^UTILITY($JOB,1,RTN,0)=IND("SZT")_"^"_LC_"^"_IND("SZC")
+2 IF IND("SZT")>INP("MAX")
IF 'INDLC
SET ERR=35
SET ERR(1)=IND("SZT")
DO ^XINDX1
+3 IF IND("SZT")-IND("SZC")>INP("CMAX")
IF 'INDLC
SET ERR=58
SET ERR(1)=IND("SZT")-IND("SZC")
DO ^XINDX1
+4 DO POSTRTN
+5 QUIT
+6 ;Proccess one line, LN = Length, LIN = Line.
LN KILL V
SET (ARG,GRB,IND("COM"),IND("DOL"),IND("F"))=""
SET X=$PIECE(LIN," ")
+1 IF '$LENGTH(X)
SET LABO=LABO+1
GOTO CD
+2 SET (IND("COM"),LAB)=$PIECE(X,"(")
SET ARG=$PIECE($PIECE(X,"(",2),")")
SET LABO=0
SET IND("PP")=X?1.8E1"(".E1")"
+3 ;Process formal parameters as New list.
IF $LENGTH(ARG)
DO NE^XINDX3
+4 ;Check for bad labels
IF 'INDLC
IF '$$VT^XINDX2(LAB)
DO E^XINDX1($SELECT(LAB=$$CASE^XINDX52(LAB):37,1:55))
+5 ;DUP label
IF $DATA(^UTILITY($JOB,1,RTN,"T",LAB))
DO E^XINDX1(15)
GOTO CD
+6 SET ^UTILITY($JOB,1,RTN,"T",LAB)=""
CD ;patch 119
IF LN>245
IF '(LN=246&($EXTRACT(RTN,1,3)="|dd"))
DO E^XINDX1(19)
+1 IF LIN'?1.ANP
DO E^XINDX1(18)
+2 SET LIN=$PIECE(LIN," ",2,999)
SET IND("LCC")=1
+3 ;Blank line ;p110
IF LIN=""
DO E^XINDX1(42)
QUIT
+4 ;Watch the scope of I, counts dots
SET I=0
+5 IF " ."[$EXTRACT(LIN)
Begin DoDot:1
+6 FOR I=1:1:245
IF ". "'[$EXTRACT(LIN,I)
QUIT
+7 QUIT
End DoDot:1
SET X=$LENGTH($EXTRACT(LIN,1,I),".")-1
SET LIN=$EXTRACT(LIN,I,999)
+8 ;check dots against Do level IND("DO"), IND("DOL")=dot level
+9 IF 'I&$GET(IND("DO1"))
DO E^XINDX1(51)
SET IND("DO1")=0
IF 'I
SET IND("DO")=0
+10 IF I
IF X>IND("DO")
DO E^XINDX1(51)
SET (IND("DO"),IND("DOL"))=X
+11 ;Count Comment lines, skip ;; lines
+12 ;p110
IF $EXTRACT(LIN)=";"
IF $EXTRACT(LIN,2)'=";"
SET IND("SZC")=IND("SZC")+$LENGTH(LIN)
+13 ;Process commands on line.
EE IF LIN=""
DO ^XINDX2
QUIT
+1 SET COM=$EXTRACT(LIN)
SET GK=""
SET ARG=""
+2 ;p110
IF COM=";"
SET LIN=""
GOTO EE
+3 IF COM=" "
SET ERR=$SELECT(LIN?1." ":13,1:0)
SET LIN=$SELECT(ERR:"",1:$EXTRACT(LIN,2,999))
IF ERR
DO ^XINDX1
GOTO EE
+4 DO SEP
+5 SET CM=$PIECE(ARG,":",1)
SET POST=$PIECE(ARG,":",2,999)
SET IND("COM")=IND("COM")_$CHAR(9)_COM
SET ERR=48
+6 IF ARG["
DO ^XINDX1
IF POST]""
SET GRB=GRB_$CHAR(9)_POST
SET IND("COM")=IND("COM")_":"
+7 ;SAC now allows lowercase commands
+8 ;I IND("LCC") S IND("LCC")=0 D E^XINDX1(47)
IF CM?.E1L.E
SET CM=$$CASE^XINDX52(CM)
SET COM=$EXTRACT(CM)
+9 ;Missing command
IF CM=""
DO E^XINDX1(21)
GOTO EE
+10 SET CX=$GET(IND("CMD",CM))
IF CX=""
Begin DoDot:1
+11 ;Proccess Z commands
IF $EXTRACT(CM)="Z"
SET CX="^Z"
QUIT
+12 DO E^XINDX1(1)
SET LIN=""
QUIT
End DoDot:1
IF CX=""
GOTO EE
+13 SET CX=$PIECE(CX,"^",2,9)
+14 ;trailing space
DO SEP
IF '$LENGTH(LIN)
IF CH=" "
DO E^XINDX1(13)
+15 IF ARG=""
IF "CGJMORSUWX"[COM
SET ERR=49
GOTO ^XINDX1
+16 IF CX>0
DO E^XINDX1(CX)
SET CX=""
+17 IF $LENGTH(CX)
DO @CX
IF ARG'=""
SET GRB=GRB_$CHAR(9)_ARG
GOTO EE
B SET ERR=25
GOTO ^XINDX1
C SET ERR=29
GOTO ^XINDX1
D GOTO DG1^XINDX4
E IF ARG=""
QUIT
SET ERR=7
GOTO ^XINDX1
F IF ARG]""
GOTO FR^XINDX4
SET IND("F")=1
QUIT
G GOTO DG^XINDX4
H IF ARG'=""
QUIT
SET ERR=32
GOTO ^XINDX1
J SET ERR=36
SET ARG=""
GOTO ^XINDX1
K SET ERR=$SELECT(ARG?1"(".E:22,ARG?." ":23,1:0)
IF ERR
DO ^XINDX1
+1 GOTO KL^XINDX3
L GOTO LO^XINDX4
M GOTO S^XINDX3
N GOTO NE^XINDX3
O SET ERR=34
DO ^XINDX1
DO O^XINDX3
QUIT
Q IF ARG=""
QUIT
GOTO Q^XINDX4
R SET RDTIME=0
GOTO RD^XINDX3
S GOTO S^XINDX3
TR ;What to process. p110
QUIT
U SET ARG=$SELECT("$"'=$EXTRACT(ARG):$PIECE(ARG,":"),1:ARG)
QUIT
V SET ARG=""
SET ERR=20
GOTO ^XINDX1
W GOTO WR^XINDX4
X GOTO XE^XINDX4
Z SET ERR=2
DO ^XINDX1
GOTO ZC^XINDX4
+1 ;
+2 ;Save off items from line.
ST SET R=LAB_$SELECT(LABO:"+"_LABO,1:"")
+1 ;Local variable, Global, Marked Items, Naked global, Internal ref, eXternal ref., Tag ref.
+2 SET LOC=""
FOR
SET LOC=$ORDER(V(LOC))
SET S=""
IF LOC=""
QUIT
FOR
SET S=$ORDER(V(LOC,S))
IF S=""
QUIT
DO SET
+3 SET ^UTILITY($JOB,1,RTN,"COM",TXT)=IND("COM")
+4 QUIT
+5 ;
SET IF V(LOC,S)]""
FOR %="!","~"
IF V(LOC,S)[%
IF $GET(^UTILITY($JOB,1,RTN,LOC,S))'[%
SET ^(S)=$GET(^(S))_%
+1 SET %=0
SE2 SET ARG=$GET(^UTILITY($JOB,1,RTN,LOC,S,%))
IF $LENGTH(ARG)>230
SET %=%+1
GOTO SE2
+1 SET ^UTILITY($JOB,1,RTN,LOC,S,%)=ARG_R_V(LOC,S)_","
+2 QUIT
+3 ;
POSTRTN ;Do more overall checking
+1 NEW V,E,T,T1,T2
+2 ;Check for missing Labels
SET T=""
+3 FOR
SET T=$ORDER(^UTILITY($JOB,1,RTN,"I",T))
SET T2=T
IF T=""
QUIT
SET T1=$GET(^(T,0))
Begin DoDot:1
+4 IF $EXTRACT(T2,1,2)="@("
QUIT
+5 IF $EXTRACT(T2,1,2)="$$"
SET T2=$EXTRACT(T2,3,99)
+6 IF T2]""
IF '$DATA(^UTILITY($JOB,1,RTN,"T",$PIECE(T2,"+",1)))
Begin DoDot:2
+7 FOR I=1:1:$LENGTH(T1,",")-1
SET LAB=$PIECE(T1,",",I)
SET LABO=+$PIECE(LAB,"+",2)
SET LAB=$PIECE(LAB,"+")
SET E=14
SET E(1)=T
DO E^XINDX1(.E)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 ;Check for valid label names
SET LAB=""
SET LABO=0
+11 IF 'INDLC
FOR
SET LAB=$ORDER(^UTILITY($JOB,1,RTN,"T",LAB))
IF LAB=""
QUIT
Begin DoDot:1
+12 IF '$$VA^XINDX2(LAB)
DO E^XINDX1(55)
QUIT
+13 IF '$$VT^XINDX2(LAB)
DO E^XINDX1(37)
+14 QUIT
End DoDot:1
+15 ;Check for valid variable names.
SET LAB=""
SET LABO=0
+16 FOR
SET LAB=$ORDER(^UTILITY($JOB,1,RTN,"L",LAB))
IF LAB=""
QUIT
Begin DoDot:1
+17 DO VLNF^XINDX3($PIECE(LAB,"("))
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
QUICK ;Quick, Just get a routine an print the results
+1 DO QUICK^XINDX6()
+2 QUIT
