XINDX8.m

XINDX8 ;ISC/GRK - STRUCTURED INDEX ;01/04/2000  14:29 [ 12/18/2003  4:57 PM ]

 ;;7.3;TOOLKIT;**20,27,61,1002**;Apr 25, 1995

 S Q="""",(DDOT,LO)=0,PG=+$G(PG) D HDR

 F LC=1:1 Q:'$D(^UTILITY($J,1,RTN,0,LC))  S LIN=^(LC,0),ML=0,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('LO: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

 I $E(LIN)=" " S LIN=$E(LIN,2,9999) G EE ;Skip blanks

 D SEP S EOC=0,COM=$$CASE^XINDX52($P(ARG,":")),CM=$P($G(IND("CMD",COM)),"^") I CM="" G ERR

 I ARG[":" S OLD=CM,COM="IF",ARG=$P(ARG,":",2) D GRB S IDT=IDT+4,CM=OLD,EOC=4

 S COM=CM D SEP

 S:$E(COM)="H"&(ARG'="") COM="HANG" S X=$E(COM,1)

 D @$S("BCHKLMNOPQRUVWZ"[X:"GRB",X="S":"SET","DGX"[X:"DGX","IE"[X:"IFE",X="F":"FOR",1:"GRB") 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

 I $Y+2>IOSL D HDR

 W ?IDT," ",$S(ML:"...",1:COM)," ",ARG,! S ML=0 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)'?1A

 S X=$E(ARG,I+1,J-1),L=$L(X),CH=$E(ARG,I+1),TY=$S($E(ARG,J)="(":"FNC",1:"SVN")

 Q:CH="Z"  S X=$P($G(IND(TY,X)),"^")

 G:'$L(X) 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(DDOT)=IDT+4

 N LIN,I,COM,EOC,Y

 F LC=LC+1:1 S LIN=$G(^UTILITY($J,1,RTN,0,LC,0)),IDT=IDT(DDOT) Q:LIN=""  D  Q:X<DDOT  D CD

 . S Y=$P(LIN," "),LIN=$P(LIN," ",2,999)

 . F I=1:1:254 Q:". "'[$E(LIN,I)

 . S X=$L($E(LIN,1,I),".")-1,LIN=Y_" "_$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=1 K AGR

 Q

HDR S PG=PG+1

 W @IOF,RTN,"   ",+^UTILITY($J,1,RTN,0),"     printed  ",INDXDT,?(IOM-10)," Page ",PG,!!

 Q

 ;

UC(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

 ;

XCR ;Option entry point

 K ^UTILITY($J) D ASKRTN^XINDX6 G EXIT:NRO<1 S %ZIS="M" D ^%ZIS Q:POP  U IO(0)

 I $D(IO("Q")) S ZTRTN="XC2^XINDX8",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)

 D BUILD^XINDX7

 S RTN="" F  S RTN=$O(^UTILITY($J,RTN)) Q:RTN=""  D  D XINDX8

 . D LOAD^XINDEX

 . 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,PG,INDXDT

XINDX8    ;ISC/GRK - STRUCTURED INDEX ;01/04/2000  14:29 [ 12/18/2003  4:57 PM ]

 +1       ;;7.3;TOOLKIT;**20,27,61,1002**;Apr 25, 1995

 +2        SET Q=""""

           SET (DDOT,LO)=0

           SET PG=+$GET(PG)

           DO HDR

 +3        FOR LC=1:1

               IF '$DATA(^UTILITY($JOB,1,RTN,0,LC))

                   QUIT 

               SET LIN=^(LC,0)

               SET ML=0

               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('LO: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       ;Skip blanks

           IF $EXTRACT(LIN)=" "

               SET LIN=$EXTRACT(LIN,2,9999)

               GOTO EE

 +2        DO SEP

           SET EOC=0

           SET COM=$$CASE^XINDX52($PIECE(ARG,":"))

           SET CM=$PIECE($GET(IND("CMD",COM)),"^")

           IF CM=""

               GOTO ERR

 +3        IF ARG[":"

               SET OLD=CM

               SET COM="IF"

               SET ARG=$PIECE(ARG,":",2)

               DO GRB

               SET IDT=IDT+4

               SET CM=OLD

               SET EOC=4

 +4        SET COM=CM

           DO SEP

 +5        IF $EXTRACT(COM)="H"&(ARG'="")

               SET COM="HANG"

           SET X=$EXTRACT(COM,1)

 +6        DO @$SELECT("BCHKLMNOPQRUVWZ"[X:"GRB",X="S":"SET","DGX"[X:"DGX","IE"[X:"IFE",X="F":"FOR",1:"GRB")

           IF EOC

               SET IDT=IDT-EOC

           GOTO EE

 +7       ;

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        IF $Y+2>IOSL

               DO HDR

 +2        WRITE ?IDT," ",$SELECT(ML:"...",1:COM)," ",ARG,!

           SET ML=0

           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)'?1A

                   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)="(":"FNC",1:"SVN")

 +5        IF CH="Z"

               QUIT 

           SET X=$PIECE($GET(IND(TY,X)),"^")

 +6        IF '$LENGTH(X)

               GOTO ERR

           IF L=$LENGTH(X)

               QUIT 

 +7        IF $LENGTH(ARG)>245

               DO LEN

           SET ARG=$EXTRACT(ARG,1,I)_X_$EXTRACT(ARG,J,999)

           SET I=I+$LENGTH(X)-L

 +8        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(DDOT)=IDT+4

 +1        NEW LIN,I,COM,EOC,Y

 +2        FOR LC=LC+1:1

               SET LIN=$GET(^UTILITY($JOB,1,RTN,0,LC,0))

               SET IDT=IDT(DDOT)

               IF LIN=""

                   QUIT 

               Begin DoDot:1

 +3                SET Y=$PIECE(LIN," ")

                   SET LIN=$PIECE(LIN," ",2,999)

 +4                FOR I=1:1:254

                       IF ". "'[$EXTRACT(LIN,I)

                           QUIT 

 +5                SET X=$LENGTH($EXTRACT(LIN,1,I),".")-1

                   SET LIN=Y_" "_$EXTRACT(LIN,I,999)

               End DoDot:1

               IF X<DDOT

                   QUIT 

               DO CD

 +6        SET IDT=IDT-4

           SET LC=LC-1

           WRITE ?IDT," End DoDot:",DDOT,!

           SET DDOT=DDOT-1

 +7        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=1

           KILL AGR

 +1        QUIT 

HDR        SET PG=PG+1

 +1        WRITE @IOF,RTN,"   ",+^UTILITY($JOB,1,RTN,0),"     printed  ",INDXDT,?(IOM-10)," Page ",PG,!!

 +2        QUIT 

 +3       ;

UC(%)      QUIT $TRANSLATE(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

 +1       ;

XCR       ;Option entry point

 +1        KILL ^UTILITY($JOB)

           DO ASKRTN^XINDX6

           IF NRO<1

               GOTO EXIT

           SET %ZIS="M"

           DO ^%ZIS

           IF POP

               QUIT 

           USE IO(0)

 +2        IF $DATA(IO("Q"))

               SET ZTRTN="XC2^XINDX8"

               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        DO BUILD^XINDX7

 +2        SET RTN=""

           FOR 

               SET RTN=$ORDER(^UTILITY($JOB,RTN))

               IF RTN=""

                   QUIT 

               Begin DoDot:1

 +3                DO LOAD^XINDEX

 +4                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

 +5                SET ^UTILITY($JOB,1,RTN,0)=CCN

 +6                QUIT 

               End DoDot:1

               DO XINDX8

EXIT       DO ^%ZISC

           KILL ^UTILITY($JOB),RTN,T,CCN,I,PG,INDXDT