%INDX2 ;ISC/REL,GRK,RWF - PROCESS "GRB" ;8/18/93 11:38 ;
;;7.3;TOOLKIT;;Apr 25, 1995
% S LINE=GRB,COM="" F I=0:0 S STR=$P(LINE,$C(9),1),LINE=$P(LINE,$C(9),2,999),NOA=0 D:STR]"" ARGG Q:LINE']""
Q
;Process argument
ARGG D ^%INDX9 S I=0,AC=999 F %=0:0 S %=$O(LV(%)) Q:%'>0 S I(%)=0
ARGS ;Proccess all agruments at this level
S AC=LI+AC F Q:AC'>LI D INC Q:S="" D ARG
Q
;
ARG ;Process one argument
I CH="," D PEEK,E^%INDX1(21):","[Y Q
Q:CH=Q
I (CH?1A)!(CH="%") D LOC Q
I CH="^" S LOC="G" G NAK:S="^",EXTGLO:S["[",GLO Q
I CH="$" D FUN Q
I CH="?" D PAT Q
I CH="(" D INC S NOA=S D DN,INC Q
Q
;
NAK S LOC="N" G GLO
EXTGLO D E^%INDX1(50),EG,INC S S=U_S G GLO
EG N GK,LOC S GK="",LOC="L" ;HANDLE EXTENDED GLOBAL
F D INC Q:"]"[CH D ARG
Q
GLO S X=$E(S,2,99) I X]"",X'?1.8UN,X'?1"%".7UN D E^%INDX1(12)
I GK["*",$E(S,1,2)["^%" D E^%INDX1(45)
I S1="(" S S=S_S1 D PEEKDN S:(Y?1.N)!($A(Y)=34)!("^$J^$I^$H^"[(U_Y)) S=S_Y
D ST(LOC,S) I S1="(" D INC2 S NOA=S D DN,INC
Q
LOC S LOC="L" I S'?1.8UN,S'?1"%".7UN,S'?1.8LN,S'?1"%".7LN D E^%INDX1(11)
I S1="(" S S=S_S1 D PEEKDN S:(Y?1.N)!($A(Y)=34) S=S_Y
D ST(LOC,S) I S1="(" D INC2 S NOA=S D DN,INC
Q
PEEK S Y=$G(LV(LV,LI+1)) Q
INC2 S LI=LI+1 ;Drop into INC
INC S LI=LI+1,S=$G(LV(LV,LI)),S1=$G(LV(LV,LI+1)),CH=$E(S) G:$A(S)=10 ERR Q
DN S LI(LV)=LI,LI(LV,1)=AC,LV=LV+1,LI=LI(LV),AC=NOA
D ARGS,UP Q
UP ;Inc LI as we save to skip the $C(10).
D PEEK D:$A(Y)'=10 ERR S LI(LV)=LI+1,LV=LV-1,LI=LI(LV),AC=LI(LV,1) Q
PEEKDN S Y=$G(LV(LV+1,LI(LV+1)+1)) Q
ERR D E^%INDX1(43) S (S,S1,CH)="" Q
S Z=$P(LV(LV+1),$C(9),LI(LV+1),99),Z=$P(Z,$C(10)) W !,"COUNT=",$L(Z,",")
;functions
FUN N FUN S FUN=S G EXT:S["$$",SPV:S1'["(" S NOA=$P(S,"^",2)
D INC2 I S'>0 D E^%INDX1(43) ;Sit on NOA
G:FUN["$TE" TEXT I FUN["$N" D ST("MK","$N")
S Y=1 F Z1=LI(LV+1)+1:1 S X=$G(LV(LV+1,Z1)) Q:$A(X)=10!(X="") S:X="," Y=Y+1
I NOA,Y<NOA!(Y>$P(NOA,";",2)) D E^%INDX1(43)
S NOA=S D DN,INC Q
;
TEXT S Y=$$ASM^%INDX3(LV+1,LI(LV+1)+1,$C(10)) D ST("MK","$T("_$S($E(Y)'="+":Y,1:""))
I $$VT(Y) D ST("I",Y)
I Y["^",$$VT($P(Y,"^",2)) N X1,X2 S X1=$P(Y,"^"),X2=$P(Y,"^",2) D ST("X",X2_$S($$VT(X1):" "_X1,1:""))
D FLUSH(1) Q
;special variables
SPV ;
Q
EXT ;Extrinsic functions
I $E(S1)="^" S Y=$E(S1,2,99)_" "_S D INC S S=Y ;Build S and fall thru
D ST($S(S[" ":"X",1:"I"),S) ;Internal, eXternal
I S1["(" D INC2 S NOA=S D DN,INC ;Process param.
Q
PAT D INC I $E(S)="@" D INC,ARG Q
F D REPCNT,PATCODE Q:$E(S)=""
Q
REPCNT F I=1:1 Q:("0123456789."'[$E(S,I))!($E(S,I)="")
S X=$E(S,1,I-1),S=$E(S,I,999) I ('$L(X))!($L(X,".")>2) S S="" D E^%INDX1(16)
Q
PATCODE I $E(S)=Q S I=1 D PATQ S S=$E(S,I,999) Q
F I=1:1 Q:("ACELNPU"'[$E(S,I))!($E(S,I)="")
S X=$E(S,1,I-1),S=$E(S,I,999) I I=1 S S="" D E^%INDX1(16)
Q
PATQ F I=I+1:1 S CH=$E(S,I) Q:CH=""!(CH=Q)
S I=I+1 D:CH="" E^%INDX1(6) S CH=$E(S,I) G:CH=Q PATQ Q
ST(LOC,S) S:'$D(V(LOC,S)) V(LOC,S)="" I $D(GK),GK]"",V(LOC,S)'[GK S V(LOC,S)=V(LOC,S)_GK
S GK="" Q
VT(X) ;Check if a valid name
Q (X?1A.7AN)!(X?1"%".7AN)!(X?1.8N)
FLUSH(FL) ;Flush rest of list with this offset
N I S FL=LV+FL,I=LI(FL)+1 F I=I:1 Q:$C(10)[$G(LV(FL,I))
S LI(FL)=I Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZINDX2 3195 printed Nov 22, 2024@17:52:26 Page 2
%INDX2 ;ISC/REL,GRK,RWF - PROCESS "GRB" ;8/18/93 11:38 ;
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
% SET LINE=GRB
SET COM=""
FOR I=0:0
SET STR=$PIECE(LINE,$CHAR(9),1)
SET LINE=$PIECE(LINE,$CHAR(9),2,999)
SET NOA=0
if STR]""
DO ARGG
if LINE']""
QUIT
+1 QUIT
+2 ;Process argument
ARGG DO ^%INDX9
SET I=0
SET AC=999
FOR %=0:0
SET %=$ORDER(LV(%))
if %'>0
QUIT
SET I(%)=0
ARGS ;Proccess all agruments at this level
+1 SET AC=LI+AC
FOR
if AC'>LI
QUIT
DO INC
if S=""
QUIT
DO ARG
+2 QUIT
+3 ;
ARG ;Process one argument
+1 IF CH=","
DO PEEK
if ","[Y
DO E^%INDX1(21)
QUIT
+2 if CH=Q
QUIT
+3 IF (CH?1A)!(CH="%")
DO LOC
QUIT
+4 IF CH="^"
SET LOC="G"
if S="^"
GOTO NAK
if S["["
GOTO EXTGLO
GOTO GLO
QUIT
+5 IF CH="$"
DO FUN
QUIT
+6 IF CH="?"
DO PAT
QUIT
+7 IF CH="("
DO INC
SET NOA=S
DO DN
DO INC
QUIT
+8 QUIT
+9 ;
NAK SET LOC="N"
GOTO GLO
EXTGLO DO E^%INDX1(50)
DO EG
DO INC
SET S=U_S
GOTO GLO
EG ;HANDLE EXTENDED GLOBAL
NEW GK,LOC
SET GK=""
SET LOC="L"
+1 FOR
DO INC
if "]"[CH
QUIT
DO ARG
+2 QUIT
GLO SET X=$EXTRACT(S,2,99)
IF X]""
IF X'?1.8UN
IF X'?1"%".7UN
DO E^%INDX1(12)
+1 IF GK["*"
IF $EXTRACT(S,1,2)["^%"
DO E^%INDX1(45)
+2 IF S1="("
SET S=S_S1
DO PEEKDN
if (Y?1.N)!($ASCII(Y)=34)!("^$J^$I^$H^"[(U_Y))
SET S=S_Y
+3 DO ST(LOC,S)
IF S1="("
DO INC2
SET NOA=S
DO DN
DO INC
+4 QUIT
LOC SET LOC="L"
IF S'?1.8UN
IF S'?1"%".7UN
IF S'?1.8LN
IF S'?1"%".7LN
DO E^%INDX1(11)
+1 IF S1="("
SET S=S_S1
DO PEEKDN
if (Y?1.N)!($ASCII(Y)=34)
SET S=S_Y
+2 DO ST(LOC,S)
IF S1="("
DO INC2
SET NOA=S
DO DN
DO INC
+3 QUIT
PEEK SET Y=$GET(LV(LV,LI+1))
QUIT
INC2 ;Drop into INC
SET LI=LI+1
INC SET LI=LI+1
SET S=$GET(LV(LV,LI))
SET S1=$GET(LV(LV,LI+1))
SET CH=$EXTRACT(S)
if $ASCII(S)=10
GOTO ERR
QUIT
DN SET LI(LV)=LI
SET LI(LV,1)=AC
SET LV=LV+1
SET LI=LI(LV)
SET AC=NOA
+1 DO ARGS
DO UP
QUIT
UP ;Inc LI as we save to skip the $C(10).
+1 DO PEEK
if $ASCII(Y)'=10
DO ERR
SET LI(LV)=LI+1
SET LV=LV-1
SET LI=LI(LV)
SET AC=LI(LV,1)
QUIT
PEEKDN SET Y=$GET(LV(LV+1,LI(LV+1)+1))
QUIT
ERR DO E^%INDX1(43)
SET (S,S1,CH)=""
QUIT
+1 SET Z=$PIECE(LV(LV+1),$CHAR(9),LI(LV+1),99)
SET Z=$PIECE(Z,$CHAR(10))
WRITE !,"COUNT=",$LENGTH(Z,",")
+2 ;functions
FUN NEW FUN
SET FUN=S
if S["$$"
GOTO EXT
if S1'["("
GOTO SPV
SET NOA=$PIECE(S,"^",2)
+1 ;Sit on NOA
DO INC2
IF S'>0
DO E^%INDX1(43)
+2 if FUN["$TE"
GOTO TEXT
IF FUN["$N"
DO ST("MK","$N")
+3 SET Y=1
FOR Z1=LI(LV+1)+1:1
SET X=$GET(LV(LV+1,Z1))
if $ASCII(X)=10!(X="")
QUIT
if X=","
SET Y=Y+1
+4 IF NOA
IF Y<NOA!(Y>$PIECE(NOA,";",2))
DO E^%INDX1(43)
+5 SET NOA=S
DO DN
DO INC
QUIT
+6 ;
TEXT SET Y=$$ASM^%INDX3(LV+1,LI(LV+1)+1,$CHAR(10))
DO ST("MK","$T("_$SELECT($EXTRACT(Y)'="+":Y,1:""))
+1 IF $$VT(Y)
DO ST("I",Y)
+2 IF Y["^"
IF $$VT($PIECE(Y,"^",2))
NEW X1,X2
SET X1=$PIECE(Y,"^")
SET X2=$PIECE(Y,"^",2)
DO ST("X",X2_$SELECT($$VT(X1):" "_X1,1:""))
+3 DO FLUSH(1)
QUIT
+4 ;special variables
SPV ;
+1 QUIT
EXT ;Extrinsic functions
+1 ;Build S and fall thru
IF $EXTRACT(S1)="^"
SET Y=$EXTRACT(S1,2,99)_" "_S
DO INC
SET S=Y
+2 ;Internal, eXternal
DO ST($SELECT(S[" ":"X",1:"I"),S)
+3 ;Process param.
IF S1["("
DO INC2
SET NOA=S
DO DN
DO INC
+4 QUIT
PAT DO INC
IF $EXTRACT(S)="@"
DO INC
DO ARG
QUIT
+1 FOR
DO REPCNT
DO PATCODE
if $EXTRACT(S)=""
QUIT
+2 QUIT
REPCNT FOR I=1:1
if ("0123456789."'[$EXTRACT(S,I))!($EXTRACT(S,I)="")
QUIT
+1 SET X=$EXTRACT(S,1,I-1)
SET S=$EXTRACT(S,I,999)
IF ('$LENGTH(X))!($LENGTH(X,".")>2)
SET S=""
DO E^%INDX1(16)
+2 QUIT
PATCODE IF $EXTRACT(S)=Q
SET I=1
DO PATQ
SET S=$EXTRACT(S,I,999)
QUIT
+1 FOR I=1:1
if ("ACELNPU"'[$EXTRACT(S,I))!($EXTRACT(S,I)="")
QUIT
+2 SET X=$EXTRACT(S,1,I-1)
SET S=$EXTRACT(S,I,999)
IF I=1
SET S=""
DO E^%INDX1(16)
+3 QUIT
PATQ FOR I=I+1:1
SET CH=$EXTRACT(S,I)
if CH=""!(CH=Q)
QUIT
+1 SET I=I+1
if CH=""
DO E^%INDX1(6)
SET CH=$EXTRACT(S,I)
if CH=Q
GOTO PATQ
QUIT
ST(LOC,S) if '$DATA(V(LOC,S))
SET V(LOC,S)=""
IF $DATA(GK)
IF GK]""
IF V(LOC,S)'[GK
SET V(LOC,S)=V(LOC,S)_GK
+1 SET GK=""
QUIT
VT(X) ;Check if a valid name
+1 QUIT (X?1A.7AN)!(X?1"%".7AN)!(X?1.8N)
FLUSH(FL) ;Flush rest of list with this offset
+1 NEW I
SET FL=LV+FL
SET I=LI(FL)+1
FOR I=I:1
if $CHAR(10)[$GET(LV(FL,I))
QUIT
+2 SET LI(FL)=I
QUIT
