%INDX4 ;ISC/REL,GRK - PROCESS DO, GO TO, WRITE & FOR COMMANDS ;8/17/92 16:32 ;
;;7.3;TOOLKIT;;Apr 25, 1995
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)
I CH="+" S (J,S)=I+1,ERR=30 D ^%INDX1:$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 PRM]"" S GRB=GRB_$C(9)_PRM D PC
S:OFF'="" LBL=LBL_"+"_OFF
S S="",LOC="I" I PGM'="" S S=S_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 ^%INDX1 Q
QUOTE F I=I+1:1 S CH=$E(ARG,I) Q:CH=""!(CH=Q)
I CH="" S ERR=6 G ^%INDX1
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 ^%INDX1
S GK="*",STR=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999) D ARGG^%INDX2
Q
WR S STR=ARG D ^%INDX9 S ARG=""
F D INC^%INDX2 Q:S="" D
. I S="?" S ERR=49 D:","[S1 ^%INDX1 Q
. D ARG^%INDX2
. Q
Q
ERRCP S ERR=5 D ^%INDX1 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 S GRB=GRB_$C(9)_ARG,ARG="" Q
Q ;QUIT
D SEP(LIN," ",.S)
I IND("PP") S ERR=$S(ARG?1A&(S>1):9,$E(ARG)=";":49,1:0) D:ERR ^%INDX1 Q
S ERR=$S(ARG?1A&(S>1):9,$E(ARG)=";":9,$L(ARG)>1&(S<2):0,S=0:0,1:9) S:ERR LIN=ARG_" "_LIN,ARG="" S:$E(ARG)=";" ARG="" G:ERR ^%INDX1
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 M,N
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZINDX4 2940 printed Oct 16, 2024@18:43:10 Page 2
%INDX4 ;ISC/REL,GRK - PROCESS DO, GO TO, WRITE & FOR COMMANDS ;8/17/92 16:32 ;
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
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 IF CH="+"
SET (J,S)=I+1
SET ERR=30
if $EXTRACT(ARG)'="@"
DO ^%INDX1
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
+3 IF CH="^"
SET S=I+1
DO LOOP
SET PGM=$EXTRACT(ARG,S,I-1)
+4 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
+5 SET ARG=$EXTRACT(ARG,I+1,999)
+6 IF $EXTRACT(LBL)="@"
SET GRB=GRB_$CHAR(9)_$EXTRACT(LBL,2,999)
SET LBL="@("
+7 IF $EXTRACT(PGM)="@"
SET GRB=GRB_$CHAR(9)_$EXTRACT(PGM,2,999)
SET PGM="@("
+8 IF LBL[")"
SET PRM=$$INSIDE(LBL,"(",")")
SET LBL=$PIECE(LBL,"(")
+9 IF PGM[")"
SET PRM=$$INSIDE(PGM,"(",")")
SET PGM=$PIECE(PGM,"(")
+10 IF PRM]""
SET GRB=GRB_$CHAR(9)_PRM
DO PC
+11 if OFF'=""
SET LBL=LBL_"+"_OFF
+12 SET S=""
SET LOC="I"
IF PGM'=""
SET S=S_PGM_" "
SET LOC="X"
+13 if LBL'=""
SET S=S_LBL
IF S'=""
DO ST
+14 if ARG'=""
GOTO DG
KILL LBL,PGM,OFF,PRM
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 ^%INDX1
QUIT
QUOTE FOR I=I+1:1
SET CH=$EXTRACT(ARG,I)
if CH=""!(CH=Q)
QUIT
+1 IF CH=""
SET ERR=6
GOTO ^%INDX1
+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 ^%INDX1
+1 SET GK="*"
SET STR=$EXTRACT(ARG,1,I-1)
SET ARG=$EXTRACT(ARG,I+1,999)
DO ARGG^%INDX2
+2 QUIT
WR SET STR=ARG
DO ^%INDX9
SET ARG=""
+1 FOR
DO INC^%INDX2
if S=""
QUIT
Begin DoDot:1
+2 IF S="?"
SET ERR=49
if ","[S1
DO ^%INDX1
QUIT
+3 DO ARG^%INDX2
+4 QUIT
End DoDot:1
+5 QUIT
ERRCP SET ERR=5
DO ^%INDX1
QUIT
SET SET ARG=$EXTRACT(ARG,1,I-1)_","_$EXTRACT(ARG,I+1,999)
QUIT
XE SET GRB=GRB_$CHAR(9)_ARG
SET ARG=""
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
GOTO REP
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)
GOTO ZR
LO SET GRB=GRB_$CHAR(9)_ARG
SET ARG=""
QUIT
Q ;QUIT
+1 DO SEP(LIN," ",.S)
+2 IF IND("PP")
SET ERR=$SELECT(ARG?1A&(S>1):9,$EXTRACT(ARG)=";":49,1:0)
if ERR
DO ^%INDX1
QUIT
+3 SET ERR=$SELECT(ARG?1A&(S>1):9,$EXTRACT(ARG)=";":9,$LENGTH(ARG)>1&(S<2):0,S=0:0,1:9)
if ERR
SET LIN=ARG_" "_LIN
SET ARG=""
if $EXTRACT(ARG)=";"
SET ARG=""
if ERR
GOTO ^%INDX1
+4 QUIT
PT(X) ;Tag for parameter passing
+1 SET ^UTILITY($JOB,1,RTN,"P",LAB)=X
QUIT
PC ;Parameter passing call
+1 NEW LOC
SET LOC="P"
DO ST
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)
SEP(ST,SP,RV) ;String,Separters,Return array)
+1 ;N M,N
+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)
QUIT
SQT FOR N=N+1:1
if Q[$EXTRACT(ST,N)
QUIT
+1 QUIT
