XINDX4.m

XINDX4 ;ISC/REL,GRK - PROCESS DO, GO TO, WRITE & FOR COMMANDS ;08/05/08  13:59

 ;;7.3;TOOLKIT;**20,61,68,110,128,133,147**;Apr 25, 1995;Build 1

 ; Per VHA Directive 2004-038, this routine should not be modified.

 ;DO and GO; IND("DO1") checks if we already checked a DO at this level

DG1 I ARG="" S:'IND("DO1") IND("DO")=IND("DO")+1,IND("DO1")=1 Q

DG S (LBL,PGM,OFF,PRM)="",S=1,L="+^:," S:$E(ARG,1,2)="@^" S=3

 D LOOP S LBL=$E(ARG,1,I-1)

 ;Cache Object method contain ".", check if label is an object or begins with ##

 I $P(LBL,"(")["."!($E(LBL,1,2)="##") Q

 I CH="+" S (J,S)=I+1,ERR=30 D ^XINDX1:$E(ARG)'="@" S:$E(ARG,I)="^" S=I+1 D LOOP S OFF=$E(ARG,J,I-1) I OFF'?.N S GRB=GRB_$C(9)_OFF

 I CH="^" S S=I+1 D LOOP S PGM=$E(ARG,S,I-1)

 I CH=":" S S=I+1,L="," D LOOP S S=$E(ARG,S,I-1) I S'="" S GRB=GRB_$C(9)_S

 S ARG=$E(ARG,I+1,999)

 I $E(LBL)="@" S GRB=GRB_$C(9)_$E(LBL,2,999),LBL="@("

 I $E(PGM)="@" S GRB=GRB_$C(9)_$E(PGM,2,999),PGM="@("

 I LBL[")" S PRM=$$INSIDE(LBL,"(",")"),LBL=$P(LBL,"(")

 I PGM[")" S PRM=$$INSIDE(PGM,"(",")"),PGM=$P(PGM,"(")

 I $L(PRM) S GRB=GRB_$C(9)_$$PRUNE($$CNG(PRM,",,",","),",") ;strip null parameters

 I $G(IND("DOL")),CM="G",PGM]"" D E^XINDX1(63) ;can't goto another routine out of block structure

 S:OFF'="" LBL=LBL_"+"_OFF

 S S="",LOC="I" I PGM'="" S S=PGM_" ",LOC="X"

 S:LBL_PGM["&" LOC="X"

 S:LBL'="" S=S_LBL I S'="" D ST

 G:ARG'="" DG K LBL,PGM,OFF,PRM

 Q

LOOP F I=S:1 S CH=$E(ARG,I) D QUOTE:CH=Q,PAREN:CH="(",ERRCP: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 PC=PC+$S("("[CH:1,")"[CH:-1,1:0)

 S ERR=5 D:PC ^XINDX1

 Q

QUOTE F I=I+1:1 S CH=$E(ARG,I) Q:CH=""!(CH=Q)

 I CH="" S ERR=6 G ^XINDX1

 Q

ST S R=$F(S,"(") S:R>1 S=$E(S,1,R-1) S:"IX"[LOC IND("COM")=IND("COM")_","_S

 S:'$D(V(LOC,S)) V(LOC,S)="" S:LOC="L"&(V(LOC,S)'["*") V(LOC,S)=V(LOC,S)_"*" Q

 Q

FR Q:$E(ARG,1)="@"  S S=2,L="=" D LOOP I CH="" S ERR=8 G ^XINDX1

 S GK="*",STR=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999) D ARGG^XINDX2

 Q

WR N S0,WR S STR=ARG,WR="#!,",S0="" ;Need to handle /controlmnemonic

 D ^XINDX9 S ARG=""

 F  D INC^XINDX2 Q:S=""  D  S S0=S

 . I S="?" D:WR[S1 E^XINDX1(49) Q

 . I S="!",WR'[$E(S0) D E^XINDX1(59) Q  ;Look for var!

 . I S="!","#!?,"'[$E(S1) D E^XINDX1(59) Q  ;Look for !var

 . D ARG^XINDX2

 . Q

 Q

ERRCP S ERR=5 D ^XINDX1

 Q

SET S ARG=$E(ARG,1,I-1)_","_$E(ARG,I+1,999)

 Q

XE S GRB=GRB_$C(9)_ARG,ARG=""

 Q

REP S L=",:",S=1 D LOOP I CH=":" S ARG=$E(ARG,I+1,999),L="," D LOOP

 S ARG=$E(ARG,I+1,999) Q:ARG=""

 G REP

 ;

ZC I "ILRS"'[$E(CM,2)!($E(CM,2)="") S ARG="" Q  ;Zcommands

 S COM=$E(CM,1,2) Q:CM="ZI"  G:CM="ZR" ZR

U1 S L=",",S=1 D LOOP S S=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999)

 S:$E(S,1)="@" S=$E(S,2,999),GRB=GRB_$C(9)_S Q:ARG=""  G U1

ZR Q:ARG=""  S L=":,",S=1 D LOOP S S=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999)

 I $E(S,1)="@" S GRB=GRB_$C(9)_S G ZR

 S:S["+" GRB=GRB_$C(9)_$P(S,"+",2,999)

 G ZR

LO ;Lock -- Look for timeouts

 N LK

 I ARG="" D E^XINDX1(61) Q  ;p147 - Lock with no argument

 S S=1

 F  D  Q:CH=""

 . I "+-"'[$E(ARG,S) D E^XINDX1(61)

 . S L="-:,",LK=0 D LOOP S S=I+1

 . I CH="-" S L="," D LOOP S S=I+1 Q

 . I CH=":" S L=",",LK=1 D LOOP S S=I+1

 . I CH="," D:'LK E^XINDX1(60) S LK=0 Q

 . I CH="" D:'LK E^XINDX1(60) Q

 . Q

 S GRB=GRB_$C(9)_ARG,ARG=""

 Q

Q ;QUIT followed by comment or in structure Do or For loop, must have 2 spaces

 I $E(ARG)=";"!$G(IND("DOL"))!$G(IND("F")) S ARG="",ERR=9 G ^XINDX1

 Q

PT(X) ;Tag for parameter passing

 S ^UTILITY($J,1,RTN,"P",LAB)=X

 Q

PC ;Parameter passing call

 N LOC S LOC="P" D ST

 Q

INSIDE(X,X1,X2) ;Return the data inside the param x1,x2

 S J=$L(X,X2)-1,J=$S(J<1:1,1:J)

 Q $P($P(X,X2,1,J),X1,2,99)

 ;

SEP(ST,SP,RV) ;String,Separters,Return array)

 N %,N,Q S Q=$C(34) ;QUOTE

 F N=1:1 S %=$E(ST,N) D SQT:%=Q Q:SP[%

 S RV=N-1,RV(1)=$E(ST,1,N)

 Q

 ;

SQT F N=N+1:1 Q:Q[$E(ST,N)

 Q

CNG(S1,S2,S3) ;String,replace,with

 ;

 F  Q:S1'[S2  S S1=$P(S1,S2)_S3_$P(S1,S2,2,999)

 Q S1

PRUNE(S1,S2) ;String,prune char from front and back

 F  Q:$E(S1)'=S2  S S1=$E(S1,2,999)

 F  Q:$E(S1,$L(S1))'=S2  S S1=$E(S1,1,$L(S1)-1)

 Q S1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XINDX4   4092     printed  Feb 19, 2025@00:06:30                                                                                                                                                                                                      Page 2

XINDX4    ;ISC/REL,GRK - PROCESS DO, GO TO, WRITE & FOR COMMANDS ;08/05/08  13:59

 +1       ;;7.3;TOOLKIT;**20,61,68,110,128,133**;Apr 25, 1995;Build 4

 +2       ; Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;DO and GO; IND("DO1") checks if we already checked a DO at this level

DG1        IF ARG=""

               if 'IND("DO1")

                   SET IND("DO")=IND("DO")+1

                   SET IND("DO1")=1

               QUIT 

DG         SET (LBL,PGM,OFF,PRM)=""

           SET S=1

           SET L="+^:,"

           if $EXTRACT(ARG,1,2)="@^"

               SET S=3

 +1        DO LOOP

           SET LBL=$EXTRACT(ARG,1,I-1)

 +2       ;Cache Object method contain ".", check if label is an object or begins with ##

 +3        IF $PIECE(LBL,"(")["."!($EXTRACT(LBL,1,2)="##")

               QUIT 

 +4        IF CH="+"

               SET (J,S)=I+1

               SET ERR=30

               if $EXTRACT(ARG)'="@"

                   DO ^XINDX1

               if $EXTRACT(ARG,I)="^"

                   SET S=I+1

               DO LOOP

               SET OFF=$EXTRACT(ARG,J,I-1)

               IF OFF'?.N

                   SET GRB=GRB_$CHAR(9)_OFF

 +5        IF CH="^"

               SET S=I+1

               DO LOOP

               SET PGM=$EXTRACT(ARG,S,I-1)

 +6        IF CH=":"

               SET S=I+1

               SET L=","

               DO LOOP

               SET S=$EXTRACT(ARG,S,I-1)

               IF S'=""

                   SET GRB=GRB_$CHAR(9)_S

 +7        SET ARG=$EXTRACT(ARG,I+1,999)

 +8        IF $EXTRACT(LBL)="@"

               SET GRB=GRB_$CHAR(9)_$EXTRACT(LBL,2,999)

               SET LBL="@("

 +9        IF $EXTRACT(PGM)="@"

               SET GRB=GRB_$CHAR(9)_$EXTRACT(PGM,2,999)

               SET PGM="@("

 +10       IF LBL[")"

               SET PRM=$$INSIDE(LBL,"(",")")

               SET LBL=$PIECE(LBL,"(")

 +11       IF PGM[")"

               SET PRM=$$INSIDE(PGM,"(",")")

               SET PGM=$PIECE(PGM,"(")

 +12      ;strip null parameters

           IF $LENGTH(PRM)

               SET GRB=GRB_$CHAR(9)_$$PRUNE($$CNG(PRM,",,",","),",")

 +13      ;can't goto another routine out of block structure

           IF $GET(IND("DOL"))

               IF CM="G"

                   IF PGM]""

                       DO E^XINDX1(63)

 +14       if OFF'=""

               SET LBL=LBL_"+"_OFF

 +15       SET S=""

           SET LOC="I"

           IF PGM'=""

               SET S=PGM_" "

               SET LOC="X"

 +16       if LBL_PGM["&"

               SET LOC="X"

 +17       if LBL'=""

               SET S=S_LBL

           IF S'=""

               DO ST

 +18       if ARG'=""

               GOTO DG

           KILL LBL,PGM,OFF,PRM

 +19       QUIT 

LOOP       FOR I=S:1

               SET CH=$EXTRACT(ARG,I)

               if CH=Q

                   DO QUOTE

               if CH="("

                   DO PAREN

               if CH=")"

                   DO ERRCP

               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

                   SET PC=PC+$SELECT("("[CH:1,")"[CH:-1,1:0)

 +2        SET ERR=5

           if PC

               DO ^XINDX1

 +3        QUIT 

QUOTE      FOR I=I+1:1

               SET CH=$EXTRACT(ARG,I)

               if CH=""!(CH=Q)

                   QUIT 

 +1        IF CH=""

               SET ERR=6

               GOTO ^XINDX1

 +2        QUIT 

ST         SET R=$FIND(S,"(")

           if R>1

               SET S=$EXTRACT(S,1,R-1)

           if "IX"[LOC

               SET IND("COM")=IND("COM")_","_S

 +1        if '$DATA(V(LOC,S))

               SET V(LOC,S)=""

           if LOC="L"&(V(LOC,S)'["*")

               SET V(LOC,S)=V(LOC,S)_"*"

           QUIT 

 +2        QUIT 

FR         if $EXTRACT(ARG,1)="@"

               QUIT 

           SET S=2

           SET L="="

           DO LOOP

           IF CH=""

               SET ERR=8

               GOTO ^XINDX1

 +1        SET GK="*"

           SET STR=$EXTRACT(ARG,1,I-1)

           SET ARG=$EXTRACT(ARG,I+1,999)

           DO ARGG^XINDX2

 +2        QUIT 

WR        ;Need to handle /controlmnemonic

           NEW S0,WR

           SET STR=ARG

           SET WR="#!,"

           SET S0=""

 +1        DO ^XINDX9

           SET ARG=""

 +2        FOR 

               DO INC^XINDX2

               if S=""

                   QUIT 

               Begin DoDot:1

 +3                IF S="?"

                       if WR[S1

                           DO E^XINDX1(49)

                       QUIT 

 +4       ;Look for var!

                   IF S="!"

                       IF WR'[$EXTRACT(S0)

                           DO E^XINDX1(59)

                           QUIT 

 +5       ;Look for !var

                   IF S="!"

                       IF "#!?,"'[$EXTRACT(S1)

                           DO E^XINDX1(59)

                           QUIT 

 +6                DO ARG^XINDX2

 +7                QUIT 

               End DoDot:1

               SET S0=S

 +8        QUIT 

ERRCP      SET ERR=5

           DO ^XINDX1

 +1        QUIT 

SET        SET ARG=$EXTRACT(ARG,1,I-1)_","_$EXTRACT(ARG,I+1,999)

 +1        QUIT 

XE         SET GRB=GRB_$CHAR(9)_ARG

           SET ARG=""

 +1        QUIT 

REP        SET L=",:"

           SET S=1

           DO LOOP

           IF CH=":"

               SET ARG=$EXTRACT(ARG,I+1,999)

               SET L=","

               DO LOOP

 +1        SET ARG=$EXTRACT(ARG,I+1,999)

           if ARG=""

               QUIT 

 +2        GOTO REP

 +3       ;

ZC        ;Zcommands

           IF "ILRS"'[$EXTRACT(CM,2)!($EXTRACT(CM,2)="")

               SET ARG=""

               QUIT 

 +1        SET COM=$EXTRACT(CM,1,2)

           if CM="ZI"

               QUIT 

           if CM="ZR"

               GOTO ZR

U1         SET L=","

           SET S=1

           DO LOOP

           SET S=$EXTRACT(ARG,1,I-1)

           SET ARG=$EXTRACT(ARG,I+1,999)

 +1        if $EXTRACT(S,1)="@"

               SET S=$EXTRACT(S,2,999)

               SET GRB=GRB_$CHAR(9)_S

           if ARG=""

               QUIT 

           GOTO U1

ZR         if ARG=""

               QUIT 

           SET L=":,"

           SET S=1

           DO LOOP

           SET S=$EXTRACT(ARG,1,I-1)

           SET ARG=$EXTRACT(ARG,I+1,999)

 +1        IF $EXTRACT(S,1)="@"

               SET GRB=GRB_$CHAR(9)_S

               GOTO ZR

 +2        if S["+"

               SET GRB=GRB_$CHAR(9)_$PIECE(S,"+",2,999)

 +3        GOTO ZR

LO        ;Lock -- Look for timeouts

 +1        NEW LK

 +2        IF ARG=""

               QUIT 

 +3        SET S=1

 +4        FOR 

               Begin DoDot:1

 +5                IF "+-"'[$EXTRACT(ARG,S)

                       DO E^XINDX1(61)

 +6                SET L="-:,"

                   SET LK=0

                   DO LOOP

                   SET S=I+1

 +7                IF CH="-"

                       SET L=","

                       DO LOOP

                       SET S=I+1

                       QUIT 

 +8                IF CH=":"

                       SET L=","

                       SET LK=1

                       DO LOOP

                       SET S=I+1

 +9                IF CH=","

                       if 'LK

                           DO E^XINDX1(60)

                       SET LK=0

                       QUIT 

 +10               IF CH=""

                       if 'LK

                           DO E^XINDX1(60)

                       QUIT 

 +11               QUIT 

               End DoDot:1

               if CH=""

                   QUIT 

 +12       SET GRB=GRB_$CHAR(9)_ARG

           SET ARG=""

 +13       QUIT 

Q         ;QUIT followed by comment or in structure Do or For loop, must have 2 spaces

 +1        IF $EXTRACT(ARG)=";"!$GET(IND("DOL"))!$GET(IND("F"))

               SET ARG=""

               SET ERR=9

               GOTO ^XINDX1

 +2        QUIT 

PT(X)     ;Tag for parameter passing

 +1        SET ^UTILITY($JOB,1,RTN,"P",LAB)=X

 +2        QUIT 

PC        ;Parameter passing call

 +1        NEW LOC

           SET LOC="P"

           DO ST

 +2        QUIT 

INSIDE(X,X1,X2) ;Return the data inside the param x1,x2

 +1        SET J=$LENGTH(X,X2)-1

           SET J=$SELECT(J<1:1,1:J)

 +2        QUIT $PIECE($PIECE(X,X2,1,J),X1,2,99)

 +3       ;

SEP(ST,SP,RV) ;String,Separters,Return array)

 +1       ;QUOTE

           NEW %,N,Q

           SET Q=$CHAR(34)

 +2        FOR N=1:1

               SET %=$EXTRACT(ST,N)

               if %=Q

                   DO SQT

               if SP[%

                   QUIT 

 +3        SET RV=N-1

           SET RV(1)=$EXTRACT(ST,1,N)

 +4        QUIT 

 +5       ;

SQT        FOR N=N+1:1

               if Q[$EXTRACT(ST,N)

                   QUIT 

 +1        QUIT 

CNG(S1,S2,S3) ;String,replace,with

 +1       ;

 +2        FOR 

               if S1'[S2

                   QUIT 

               SET S1=$PIECE(S1,S2)_S3_$PIECE(S1,S2,2,999)

 +3        QUIT S1

PRUNE(S1,S2) ;String,prune char from front and back

 +1        FOR 

               if $EXTRACT(S1)'=S2

                   QUIT 

               SET S1=$EXTRACT(S1,2,999)

 +2        FOR 

               if $EXTRACT(S1,$LENGTH(S1))'=S2

                   QUIT 

               SET S1=$EXTRACT(S1,1,$LENGTH(S1)-1)

 +3        QUIT S1