- 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 ---[H[J[2J[HXINDX4 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