- %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 Feb 19, 2025@00:09:08 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