- %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
- %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
