%INDX8 ;ISC/GRK - STRUCTURED INDEX ;02/07/95 13:18
;;7.3;TOOLKIT;;Apr 25, 1995
W #!,RTN," ",+^UTILITY($J,1,RTN,0)," printed ",INDXDT,!! S Q="""",(DDOT,LO)=0
F LC=1:1 Q:'$D(^UTILITY($J,1,RTN,0,LC)) S LIN=^(LC,0),ML="",IDT=10 D CD
K AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY
Q
CD S LAB=$P(LIN," ",1),LIN=$P(LIN," ",2,999),LO=$S(LAB="":LO+1,1:0)
W $S(LAB'="":LAB,1:" +"_LO)
G:LIN'[";" EE S STR=1,L=";",ARG=LIN D LOOP I CH'=";" G EE
W ?10,$E(LIN,I,999),! Q:I<2 S LIN=$E(LIN,1,I-2)
EE I LIN="" Q
S COM=$E(LIN,1),EOC=0 I COM=" " S LIN=$E(LIN,2,9999) G EE
I "BCDEFGHIKLNOPQRSUVWXZ"'[COM G ERR
D SEP I ARG[":" S OLD=$P(ARG,":",1),COM="IF",ARG=$P(ARG,":",2) D GRB S IDT=IDT+4,ARG=OLD,EOC=4
S COM=ARG I $L(COM)>1,$E(COM,1)'="Z",$P($T(CMD),";",2,999)'[(","_COM_",") G ERR
I $E(COM,1)="Z" S X=COM
E S COM=$E(COM,1) F I=2:1 S X=$P($T(CMD),",",I) Q:X="" Q:$E(X,1)=COM
S:COM="H"&(ARG'="") X="HANG" S COM=X,X=$E(X,1)
D SEP D GRB:"BCHKLNOPQRUVWZ"[X,SET:X="S",DGX:"DGX"[X,IFE:"IE"[X,FOR:X="F" S:EOC IDT=IDT-EOC G EE
GRB I ARG["$" F I=1:1 S CH=$E(ARG,I) Q:CH="" D QUOTE:CH=Q I CH="$" D FUN
W ?IDT," ",$S(ML=0:"...",1:COM)," ",ARG,! S ML="" Q
FUN I $E(ARG,I,I+1)="$$" D S I=J-1 Q ;Handle Extrinsics
. F J=I+2:1 Q:"(,"[$E(ARG,J)
. Q
F J=I+1:1 Q:$E(ARG,J)'?1U
S X=$E(ARG,I+1,J-1),L=$L(X),CH=$E(ARG,I+1),TY=$S($E(ARG,J)="(":$T(FNC),1:$T(SPC))
Q:CH="Z" S %=0 F PC=2:1 S JJ=$P(TY,",",PC) Q:JJ="" S %=($P(JJ,":")_":")[(X_":") S:% X=$P(JJ,":",2) I (":"_$P(JJ,":",2))[(":"_X) S %=PC Q
G:'% ERR
Q:L=$L(X) D:$L(ARG)>245 LEN S ARG=$E(ARG,1,I)_X_$E(ARG,J,999),I=I+$L(X)-L Q
ERR W !,"*** ERROR ***",! Q
IFE I ARG=""!(X="E") W ?IDT,"IF " W:X="E" "'" W "$TEST",! S IDT=IDT+4 Q
SET S STR=1,L="," D LOOP S SAV=ARG,ARG=$E(ARG,1,I-1),IP=I+1
D GRB S ARG=$E(SAV,IP,999) S:COM="IF" IDT=IDT+4 Q:ARG="" G SET
FOR D GRB S IDT=IDT+4 Q
DGX I ARG="",$E(COM)="D" D DDOT Q
S STR=1,L=":," D LOOP I CH="" G GRB
I CH="," S SAV=ARG,ARG=$E(ARG,1,I-1),IP=I+1 D GRB G D1
S SAV=ARG,STR=I+1,L="," D LOOP S IP=I+1
S OLD=COM,ARG=$E(ARG,STR,I-1),COM="IF" D GRB
S IDT=IDT+4,ARG=$E(SAV,1,STR-2),COM=OLD D GRB S IDT=IDT-4
D1 S ARG=$E(SAV,IP,999) Q:ARG="" G DGX
DDOT S DDOT=DDOT+1 W ?IDT," Begin DoDot",DDOT,! S IDT=IDT+4
N LIN,I,COM,EOC
F LC=LC+1:1 S LIN=$G(^UTILITY($J,1,RTN,0,LC,0)) Q:LIN="" D Q:X<DDOT D CD
. F I=1:1:254 Q:". "'[$E(LIN,I)
. S X=$L($E(LIN,1,I),".")-1,LIN=" "_$E(LIN,I,999)
S IDT=IDT-4,LC=LC-1 W ?IDT," End DoDot",DDOT,! S DDOT=DDOT-1
Q
LOOP F I=STR:1 S CH=$E(ARG,I) D QUOTE:CH=Q,PAREN:CH="(" Q:L[CH
Q
PAREN S PC=1
F I=I+1:1 S CH=$E(ARG,I) Q:PC=0!(CH="") I "()"""[CH D QUOTE:CH=Q S:"()"[CH PC=PC+$S(CH="(":1,1:-1)
Q
QUOTE F I=I+1:1 S CH=$E(ARG,I) Q:CH=""!(CH=Q)
Q
SEP F I=1:1 S CH=$E(LIN,I) D SEPQ:CH=Q Q:"; "[CH
S ARG=$E(LIN,1,I-1) S:CH=" " I=I+1 S LIN=$E(LIN,I,999) Q
SEPQ S I=I+1,CH=$E(LIN,I) I CH="" G ERR Q
G SEPQ:CH'=Q S I=I+1,CH=$E(LIN,I) G:CH=Q SEPQ Q
LEN S AGR=$E(ARG,1,I-1) W ?IDT,COM," ",AGR_"...",! S ARG=$E(ARG,I)_$E(ARG,J-1,999),I=1,J=3,ML=0 K AGR
Q
CMD ;,BREAK,CLOSE,DO,ELSE,FOR,GOTO,HALT,HANG,IF,KILL,LOCK,NEW,OPEN,PRINT,QUIT,READ,SET,USE,VIEW,WRITE,XECUTE,
;Put 2 char codes after 1 char to keep N: from finding FN:
FNC ;,A:ASCII,C:CHAR,D:DATA,E:EXTRACT,F:FIND,G:GET,J:JUSTIFY,L:LENGTH,N:NEXT,O:ORDER,P:PIECE,Q:QUERY,R:RANDOM,S:SELECT,T:TEXT,V:VIEW,FN:FNUMBER,TR:TRANSLATE
SPC ;,H:HOROLOG,I:IO,J:JOB,S:STORAGE,T:TEST,X:X,Y:Y,
;
XCR ;Option entry point
K ^UTILITY($J) D ASKRTN^%INDX6 G EXIT:NRO<1 S %ZIS="M" D ^%ZIS Q:POP U IO(0)
I $D(IO("Q")) S ZTRTN="XC2^%INDX8",ZTSAVE("^UTILITY($J,")="",ZTDESC="Structured print" D ^%ZTLOAD G EXIT
XC2 U IO I '$D(INDXDT) D NOW^%DTC S INDXDT=$E(%,2,3)_"/"_$E(4,5)_"/"_$E(%,6,7)
S RTN="" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" D D %INDX8
. D LOAD^%INDEX
. S CCN=0 F I=1:1:+^UTILITY($J,1,RTN,0,0) S CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2
. S ^UTILITY($J,1,RTN,0)=CCN
. Q
EXIT D ^%ZISC K ^UTILITY($J),RTN,T,CCN,I
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZINDX8 3962 printed Apr 09, 2024@21:43:45 Page 2
%INDX8 ;ISC/GRK - STRUCTURED INDEX ;02/07/95 13:18
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
+2 WRITE #!,RTN," ",+^UTILITY($JOB,1,RTN,0)," printed ",INDXDT,!!
SET Q=""""
SET (DDOT,LO)=0
+3 FOR LC=1:1
if '$DATA(^UTILITY($JOB,1,RTN,0,LC))
QUIT
SET LIN=^(LC,0)
SET ML=""
SET IDT=10
DO CD
+4 KILL AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY
+5 QUIT
CD SET LAB=$PIECE(LIN," ",1)
SET LIN=$PIECE(LIN," ",2,999)
SET LO=$SELECT(LAB="":LO+1,1:0)
+1 WRITE $SELECT(LAB'="":LAB,1:" +"_LO)
+2 if LIN'[";"
GOTO EE
SET STR=1
SET L=";"
SET ARG=LIN
DO LOOP
IF CH'=";"
GOTO EE
+3 WRITE ?10,$EXTRACT(LIN,I,999),!
if I<2
QUIT
SET LIN=$EXTRACT(LIN,1,I-2)
EE IF LIN=""
QUIT
+1 SET COM=$EXTRACT(LIN,1)
SET EOC=0
IF COM=" "
SET LIN=$EXTRACT(LIN,2,9999)
GOTO EE
+2 IF "BCDEFGHIKLNOPQRSUVWXZ"'[COM
GOTO ERR
+3 DO SEP
IF ARG[":"
SET OLD=$PIECE(ARG,":",1)
SET COM="IF"
SET ARG=$PIECE(ARG,":",2)
DO GRB
SET IDT=IDT+4
SET ARG=OLD
SET EOC=4
+4 SET COM=ARG
IF $LENGTH(COM)>1
IF $EXTRACT(COM,1)'="Z"
IF $PIECE($TEXT(CMD),";",2,999)'[(","_COM_",")
GOTO ERR
+5 IF $EXTRACT(COM,1)="Z"
SET X=COM
+6 IF '$TEST
SET COM=$EXTRACT(COM,1)
FOR I=2:1
SET X=$PIECE($TEXT(CMD),",",I)
if X=""
QUIT
if $EXTRACT(X,1)=COM
QUIT
+7 if COM="H"&(ARG'="")
SET X="HANG"
SET COM=X
SET X=$EXTRACT(X,1)
+8 DO SEP
if "BCHKLNOPQRUVWZ"[X
DO GRB
if X="S"
DO SET
if "DGX"[X
DO DGX
if "IE"[X
DO IFE
if X="F"
DO FOR
if EOC
SET IDT=IDT-EOC
GOTO EE
GRB IF ARG["$"
FOR I=1:1
SET CH=$EXTRACT(ARG,I)
if CH=""
QUIT
if CH=Q
DO QUOTE
IF CH="$"
DO FUN
+1 WRITE ?IDT," ",$SELECT(ML=0:"...",1:COM)," ",ARG,!
SET ML=""
QUIT
FUN ;Handle Extrinsics
IF $EXTRACT(ARG,I,I+1)="$$"
Begin DoDot:1
+1 FOR J=I+2:1
if "(,"[$EXTRACT(ARG,J)
QUIT
+2 QUIT
End DoDot:1
SET I=J-1
QUIT
+3 FOR J=I+1:1
if $EXTRACT(ARG,J)'?1U
QUIT
+4 SET X=$EXTRACT(ARG,I+1,J-1)
SET L=$LENGTH(X)
SET CH=$EXTRACT(ARG,I+1)
SET TY=$SELECT($EXTRACT(ARG,J)="(":$TEXT(FNC),1:$TEXT(SPC))
+5 if CH="Z"
QUIT
SET %=0
FOR PC=2:1
SET JJ=$PIECE(TY,",",PC)
if JJ=""
QUIT
SET %=($PIECE(JJ,":")_":")[(X_":")
if %
SET X=$PIECE(JJ,":",2)
IF (":"_$PIECE(JJ,":",2))[(":"_X)
SET %=PC
QUIT
+6 if '%
GOTO ERR
+7 if L=$LENGTH(X)
QUIT
if $LENGTH(ARG)>245
DO LEN
SET ARG=$EXTRACT(ARG,1,I)_X_$EXTRACT(ARG,J,999)
SET I=I+$LENGTH(X)-L
QUIT
ERR WRITE !,"*** ERROR ***",!
QUIT
IFE IF ARG=""!(X="E")
WRITE ?IDT,"IF "
if X="E"
WRITE "'"
WRITE "$TEST",!
SET IDT=IDT+4
QUIT
SET SET STR=1
SET L=","
DO LOOP
SET SAV=ARG
SET ARG=$EXTRACT(ARG,1,I-1)
SET IP=I+1
+1 DO GRB
SET ARG=$EXTRACT(SAV,IP,999)
if COM="IF"
SET IDT=IDT+4
if ARG=""
QUIT
GOTO SET
FOR DO GRB
SET IDT=IDT+4
QUIT
DGX IF ARG=""
IF $EXTRACT(COM)="D"
DO DDOT
QUIT
+1 SET STR=1
SET L=":,"
DO LOOP
IF CH=""
GOTO GRB
+2 IF CH=","
SET SAV=ARG
SET ARG=$EXTRACT(ARG,1,I-1)
SET IP=I+1
DO GRB
GOTO D1
+3 SET SAV=ARG
SET STR=I+1
SET L=","
DO LOOP
SET IP=I+1
+4 SET OLD=COM
SET ARG=$EXTRACT(ARG,STR,I-1)
SET COM="IF"
DO GRB
+5 SET IDT=IDT+4
SET ARG=$EXTRACT(SAV,1,STR-2)
SET COM=OLD
DO GRB
SET IDT=IDT-4
D1 SET ARG=$EXTRACT(SAV,IP,999)
if ARG=""
QUIT
GOTO DGX
DDOT SET DDOT=DDOT+1
WRITE ?IDT," Begin DoDot",DDOT,!
SET IDT=IDT+4
+1 NEW LIN,I,COM,EOC
+2 FOR LC=LC+1:1
SET LIN=$GET(^UTILITY($JOB,1,RTN,0,LC,0))
if LIN=""
QUIT
Begin DoDot:1
+3 FOR I=1:1:254
if ". "'[$EXTRACT(LIN,I)
QUIT
+4 SET X=$LENGTH($EXTRACT(LIN,1,I),".")-1
SET LIN=" "_$EXTRACT(LIN,I,999)
End DoDot:1
if X<DDOT
QUIT
DO CD
+5 SET IDT=IDT-4
SET LC=LC-1
WRITE ?IDT," End DoDot",DDOT,!
SET DDOT=DDOT-1
+6 QUIT
LOOP FOR I=STR:1
SET CH=$EXTRACT(ARG,I)
if CH=Q
DO QUOTE
if CH="("
DO PAREN
if L[CH
QUIT
+1 QUIT
PAREN SET PC=1
+1 FOR I=I+1:1
SET CH=$EXTRACT(ARG,I)
if PC=0!(CH="")
QUIT
IF "()"""[CH
if CH=Q
DO QUOTE
if "()"[CH
SET PC=PC+$SELECT(CH="(":1,1:-1)
+2 QUIT
QUOTE FOR I=I+1:1
SET CH=$EXTRACT(ARG,I)
if CH=""!(CH=Q)
QUIT
+1 QUIT
SEP FOR I=1:1
SET CH=$EXTRACT(LIN,I)
if CH=Q
DO SEPQ
if "; "[CH
QUIT
+1 SET ARG=$EXTRACT(LIN,1,I-1)
if CH=" "
SET I=I+1
SET LIN=$EXTRACT(LIN,I,999)
QUIT
SEPQ SET I=I+1
SET CH=$EXTRACT(LIN,I)
IF CH=""
GOTO ERR
QUIT
+1 if CH'=Q
GOTO SEPQ
SET I=I+1
SET CH=$EXTRACT(LIN,I)
if CH=Q
GOTO SEPQ
QUIT
LEN SET AGR=$EXTRACT(ARG,1,I-1)
WRITE ?IDT,COM," ",AGR_"...",!
SET ARG=$EXTRACT(ARG,I)_$EXTRACT(ARG,J-1,999)
SET I=1
SET J=3
SET ML=0
KILL AGR
+1 QUIT
CMD ;,BREAK,CLOSE,DO,ELSE,FOR,GOTO,HALT,HANG,IF,KILL,LOCK,NEW,OPEN,PRINT,QUIT,READ,SET,USE,VIEW,WRITE,XECUTE,
+1 ;Put 2 char codes after 1 char to keep N: from finding FN:
FNC ;,A:ASCII,C:CHAR,D:DATA,E:EXTRACT,F:FIND,G:GET,J:JUSTIFY,L:LENGTH,N:NEXT,O:ORDER,P:PIECE,Q:QUERY,R:RANDOM,S:SELECT,T:TEXT,V:VIEW,FN:FNUMBER,TR:TRANSLATE
SPC ;,H:HOROLOG,I:IO,J:JOB,S:STORAGE,T:TEST,X:X,Y:Y,
+1 ;
XCR ;Option entry point
+1 KILL ^UTILITY($JOB)
DO ASKRTN^%INDX6
if NRO<1
GOTO EXIT
SET %ZIS="M"
DO ^%ZIS
if POP
QUIT
USE IO(0)
+2 IF $DATA(IO("Q"))
SET ZTRTN="XC2^%INDX8"
SET ZTSAVE("^UTILITY($J,")=""
SET ZTDESC="Structured print"
DO ^%ZTLOAD
GOTO EXIT
XC2 USE IO
IF '$DATA(INDXDT)
DO NOW^%DTC
SET INDXDT=$EXTRACT(%,2,3)_"/"_$EXTRACT(4,5)_"/"_$EXTRACT(%,6,7)
+1 SET RTN=""
FOR
SET RTN=$ORDER(^UTILITY($JOB,RTN))
if RTN=""
QUIT
Begin DoDot:1
+2 DO LOAD^%INDEX
+3 SET CCN=0
FOR I=1:1:+^UTILITY($JOB,1,RTN,0,0)
SET CCN=CCN+$LENGTH(^UTILITY($JOB,1,RTN,0,I,0))+2
+4 SET ^UTILITY($JOB,1,RTN,0)=CCN
+5 QUIT
End DoDot:1
DO %INDX8
EXIT DO ^%ZISC
KILL ^UTILITY($JOB),RTN,T,CCN,I
