source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/ZINDX8.m@ 1306

%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