- XINDX3 ;ISC/REL,GRK,RWF - PROCESS MERGE/SET/READ/KILL/NEW/OPEN COMMANDS ;06/24/08 15:44
- ;;7.3;TOOLKIT;**20,27,61,68,110,121,128,132,133,140,149,153**;Apr 25, 1995;Build 3
- ; Per VHA Directive 2004-038, this routine should not be modified.
- PEEK S Y=$G(LV(LV,LI+1)) Q
- PEEK2 S Y=$G(LV(LV,LI+2)) 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 ERR:$A(S)=10 Q
- DN S LI(LV)=LI,LI(LV,1)=AC,LV=LV+1,LI=LI(LV),AC=NOA
- Q
- UP ;Inc LI as we save to skip the $C(10).
- D PEEK S:$A(Y)=10 LI=LI+1 S LI(LV)=LI,LV=LV-1,LI=LI(LV),AC=LI(LV,1) Q
- PEEKDN S Y=$G(LV(LV+1,LI(LV+1)+1)) Q
- FIND F Y=LI:1:AC Q:L[$G(LV(LV,Y))
- ERR D E^XINDX1(43) S (S,S1,CH)="" Q
- Q
- Q
- S ;Set
- S STR=ARG,ARG="",RHS=0 D ^XINDX9
- S2 S GK="" D INC I S="" D:'RHS E^XINDX1(10) Q
- I CH=",","!""#&)*+-,./:;<=?\]_~"[$E(S1),RHS=1 D E^XINDX1(10) G S2 ;patch 121
- I CH="," S RHS=0 G S2
- I CH="=" S RHS=1 I "!#&)*,/:;<=?\]_~"[$E(S1) D:$E(S1,1,2)'="##" E^XINDX1(10) G S2 ;patch 119
- I CH="$",'RHS D D:% E^XINDX1(10) ;Can't be on left side of set.
- . S %=1
- . I "$E$P$X$Y"[$E(S,1,2) S %=0 Q
- . I "$EC$ET$QS"[$E(S,1,3) S %=0 Q
- . I "$ZE$ZT"[$E(S,1,3) S %=0 Q ;Pickup in XINDX9
- . Q
- I CH="^" D FL G S2
- I CH="@" S Y=$$ASM(LV,LI,",") S:Y'["=" RHS=1 D INC,ARG^XINDX2 G S2
- I CH="(",$D(LV(LV,"OBJ",LI-1)) D ARG^XINDX2 G S2
- I CH="(" D MULT G S2
- I CH="#",$E(S,1,2)="##" D ARG^XINDX2 G S2 ;Cache Objects
- D FL G S2
- ;NOA=number of arguments
- MULT D INC S NOA=S I S'>0 S ERR=5 G ^XINDX1
- D DN S AC=AC+LI F Q:AC'>LI S:'RHS GK="*" D INC,ARG^XINDX2
- D UP
- Q
- FL ;
- S:'RHS GK="*" D ARG^XINDX2
- Q
- VLNF(X) ;Drop into VLN
- VLN ;Valid Local Name > Variable
- S ERR=0
- Q:X?1(1U,1"%").15UN
- ;lower/mixed case, can't be namespaced ;p140 ;p153 change case and check
- I X?1(1A,1"%").15AN D:($E(RTN,1,2)=$E(X,1,2))!($E(RTN,1,2)=$$CASE^XINDX9($E(X,1,2))) E^XINDX1(57) Q
- D E^XINDX1(11) ;Too long or other problem
- Q
- VGN ;Valid Global Name
- S ERR=0 I X'?1(1U,1"%").7UN D E^XINDX1(12)
- Q
- KL ;Process KILL
- S STR=ARG,ARG(1)=ARG,ARG="" D ^XINDX9
- A D INC Q:S="" G A:CH="," S LOC="L" D @$S(CH="@":"KL1",CH="^":"KL2",CH="(":"KL4",1:"KL3") G A
- KL1 D INC,ARG^XINDX2 Q
- KL2 S GK="!"
- I S1'="(" S ERR=24 D ^XINDX1
- G ARG^XINDX2
- KL3 I "^DT^DTIME^DILOCKTM^DUZ^IOST^IOM^U^"[("^"_S_"^") S ERR=39,ERR(1)=S D ^XINDX1 ;p149
- I "IO"=S D:S1="(" PEEKDN S ERR=39,ERR(1)=S_$S(S1["(":S1_Y_")",1:"") D:S1'="(" ^XINDX1 I S1="(",("QC"'[$E(Y,2)) D ^XINDX1
- KL5 S GK="!" D ARG^XINDX2 Q ;KILL SUBS
- Q
- KL4 S NOA=S1 D DN,ARGS^XINDX2,UP,INC2 Q
- NE ;NEW
- S ERR=$S("("[$E(ARG):26,1:0) I ERR G ^XINDX1 ;look for null or (
- S STR=ARG D ^XINDX9 K ERTX
- N2 D INC Q:S="" G N2:CH=","
- ;I CH?1P,("%@()"'[CH)&("$E"'[$E(S,1,2)) D E^XINDX1(11) G N2
- ;check for "@", functions, special variables, or %variables
- I CH?1P,(CH'=S) D I $G(ERTX)]"" K ERTX G N2
- . Q:"@("[CH!(CH="%"&($E(S,2,8)?.1A.E)) ;check what's indirected on next pass or
- . ;if not $ET or $ES must use indirection
- . I "$"[CH Q:$E(S,1,3)="$ET"!($E(S,1,3)="$ES") I LI>1,(LV(LV,LI-1)="@") Q
- . D E^XINDX1(11)
- . Q
- S GK="~" D ARG^XINDX2
- G N2
- ;
- RD S STR=ARG D ^XINDX9 S ARG=""
- RD1 D INC Q:S=""
- ;I (CH="!")!(CH=",")!(CH=Q)!(CH="#") G RD1
- ;I CH="^" S ERR=11 D ^XINDX1
- I '((CH="%")!(CH?1A)!(CH="*")) D RD3 G RD1
- S Y=$$ASM(LV,LI,",") I Y'[":" S ERR=33,RDTIME=1 D ^XINDX1
- D RD2 G RD1
- RD2 Q:","[CH
- I "*#"[CH D E^XINDX1(41)
- I "#:"[CH D INC,ARG^XINDX2,INC G RD2
- I (CH="%")!(CH?1A) S LOC="L",GK="*" D ARG^XINDX2,INC G RD2
- D INC G RD2
- RD3 Q:","[CH I "!#?"[CH D INC G RD3
- I (CH="%")!(CH?1A)!(CH="@") D ARG^XINDX2,INC G RD3
- I CH="$" S ERR=21,RDTIME=1 D ^XINDX1
- Q
- O S STR=ARG,AC=99 D ^XINDX9,INC S ARG="" I S["@" D ARGS^XINDX2 Q
- D ARG^XINDX2,INC D D INC,ARGS^XINDX2 Q
- . F D INC Q:":"[S
- . Q
- Q
- ERRCP S ERR=5 D ^XINDX1 Q
- ST ;
- S:'$D(V(LOC,S)) V(LOC,S)="" S:V(LOC,S)'[GK V(LOC,S)=V(LOC,S)_GK,GK="" Q
- Q
- ASM(WL,SI,L,SEP) ;assemble line Y from LV array
- N %,CH,Y S SEP=$G(SEP),Y="" F %=SI:1 S CH=$G(LV(WL,%)) Q:L[CH S Y=Y_SEP_CH
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXINDX3 4064 printed Mar 13, 2025@21:45:04 Page 2
- XINDX3 ;ISC/REL,GRK,RWF - PROCESS MERGE/SET/READ/KILL/NEW/OPEN COMMANDS ;2018-02-22 12:56 PM
- +1 ;;7.3;TOOLKIT;**20,27,61,68,110,121,128,132,133,140,10001**;Apr 25, 1995;Build 4
- +2 ; Original routine authored by Department of Veterans Affairs
- +3 ; RD3+3 contributed by George Timson (date written unknown)
- PEEK SET Y=$GET(LV(LV,LI+1))
- QUIT
- PEEK2 SET Y=$GET(LV(LV,LI+2))
- 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)
- +1 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 QUIT
- UP ;Inc LI as we save to skip the $C(10).
- +1 DO PEEK
- if $ASCII(Y)=10
- SET LI=LI+1
- SET LI(LV)=LI
- 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
- FIND FOR Y=LI:1:AC
- if L[$GET(LV(LV,Y))
- QUIT
- ERR DO E^XINDX1(43)
- SET (S,S1,CH)=""
- QUIT
- +1 QUIT
- +2 QUIT
- S ;Set
- +1 SET STR=ARG
- SET ARG=""
- SET RHS=0
- DO ^XINDX9
- S2 SET GK=""
- DO INC
- IF S=""
- if 'RHS
- DO E^XINDX1(10)
- QUIT
- +1 ;patch 121
- IF CH=","
- IF "!""#&)*+-,./:;<=?\]_~"[$EXTRACT(S1)
- IF RHS=1
- DO E^XINDX1(10)
- GOTO S2
- +2 IF CH=","
- SET RHS=0
- GOTO S2
- +3 ;patch 119
- IF CH="="
- SET RHS=1
- IF "!#&)*,/:;<=?\]_~"[$EXTRACT(S1)
- if $EXTRACT(S1,1,2)'="##"
- DO E^XINDX1(10)
- GOTO S2
- +4 ;Can't be on left side of set.
- IF CH="$"
- IF 'RHS
- Begin DoDot:1
- +5 SET %=1
- +6 IF "$E$P$X$Y"[$EXTRACT(S,1,2)
- SET %=0
- QUIT
- +7 IF "$EC$ET$QS"[$EXTRACT(S,1,3)
- SET %=0
- QUIT
- +8 ;Pickup in XINDX9
- IF "$ZE$ZT"[$EXTRACT(S,1,3)
- SET %=0
- QUIT
- +9 QUIT
- End DoDot:1
- if %
- DO E^XINDX1(10)
- +10 IF CH="^"
- DO FL
- GOTO S2
- +11 IF CH="@"
- SET Y=$$ASM(LV,LI,",")
- if Y'["="
- SET RHS=1
- DO INC
- DO ARG^XINDX2
- GOTO S2
- +12 IF CH="("
- IF $DATA(LV(LV,"OBJ",LI-1))
- DO ARG^XINDX2
- GOTO S2
- +13 IF CH="("
- DO MULT
- GOTO S2
- +14 ;Cache Objects
- IF CH="#"
- IF $EXTRACT(S,1,2)="##"
- DO ARG^XINDX2
- GOTO S2
- +15 DO FL
- GOTO S2
- +16 ;NOA=number of arguments
- MULT DO INC
- SET NOA=S
- IF S'>0
- SET ERR=5
- GOTO ^XINDX1
- +1 DO DN
- SET AC=AC+LI
- FOR
- if AC'>LI
- QUIT
- if 'RHS
- SET GK="*"
- DO INC
- DO ARG^XINDX2
- +2 DO UP
- +3 QUIT
- FL ;
- +1 if 'RHS
- SET GK="*"
- DO ARG^XINDX2
- +2 QUIT
- VLNF(X) ;Drop into VLN
- VLN ;Valid Local Name > Variable
- +1 SET ERR=0
- +2 if X?1(1U,1"%").15UN
- QUIT
- +3 ;lower/mixed case, can't be namespaced ;p140
- +4 IF X?1(1A,1"%").15AN
- if $EXTRACT(RTN,1,2)=$EXTRACT(X,1,2)
- DO E^XINDX1(57)
- QUIT
- +5 ;Too long or other problem
- DO E^XINDX1(11)
- +6 QUIT
- VGN ;Valid Global Name
- +1 SET ERR=0
- IF X'?1(1U,1"%").7UN
- DO E^XINDX1(12)
- +2 QUIT
- KL ;Process KILL
- +1 SET STR=ARG
- SET ARG(1)=ARG
- SET ARG=""
- DO ^XINDX9
- A DO INC
- if S=""
- QUIT
- if CH=","
- GOTO A
- SET LOC="L"
- DO @$SELECT(CH="@":"KL1",CH="^":"KL2",CH="(":"KL4",1:"KL3")
- GOTO A
- KL1 DO INC
- DO ARG^XINDX2
- QUIT
- KL2 SET GK="!"
- +1 IF S1'="("
- SET ERR=24
- DO ^XINDX1
- +2 GOTO ARG^XINDX2
- KL3 IF "^DT^DTIME^DUZ^IOST^IOM^U^"[("^"_S_"^")
- SET ERR=39
- SET ERR(1)=S
- DO ^XINDX1
- +1 IF "IO"=S
- if S1="("
- DO PEEKDN
- SET ERR=39
- SET ERR(1)=S_$SELECT(S1["(":S1_Y_")",1:"")
- if S1'="("
- DO ^XINDX1
- IF S1="("
- IF ("QC"'[$EXTRACT(Y,2))
- DO ^XINDX1
- KL5 ;KILL SUBS
- SET GK="!"
- DO ARG^XINDX2
- QUIT
- +1 QUIT
- KL4 SET NOA=S1
- DO DN
- DO ARGS^XINDX2
- DO UP
- DO INC2
- QUIT
- NE ;NEW
- +1 ;look for null or (
- SET ERR=$SELECT("("[$EXTRACT(ARG):26,1:0)
- IF ERR
- GOTO ^XINDX1
- +2 SET STR=ARG
- DO ^XINDX9
- KILL ERTX
- N2 DO INC
- if S=""
- QUIT
- if CH=","
- GOTO N2
- +1 ;I CH?1P,("%@()"'[CH)&("$E"'[$E(S,1,2)) D E^XINDX1(11) G N2
- +2 ;check for "@", functions, special variables, or %variables
- +3 IF CH?1P
- IF (CH'=S)
- Begin DoDot:1
- +4 ;check what's indirected on next pass or
- if "@("[CH!(CH="%"&($EXTRACT(S,2,8)?.1A.E))
- QUIT
- +5 ;if not $ET or $ES must use indirection
- +6 IF "$"[CH
- if $EXTRACT(S,1,3)="$ET"!($EXTRACT(S,1,3)="$ES")
- QUIT
- IF LI>1
- IF (LV(LV,LI-1)="@")
- QUIT
- +7 DO E^XINDX1(11)
- +8 QUIT
- End DoDot:1
- IF $GET(ERTX)]""
- KILL ERTX
- GOTO N2
- +9 SET GK="~"
- DO ARG^XINDX2
- +10 GOTO N2
- +11 ;
- RD SET STR=ARG
- DO ^XINDX9
- SET ARG=""
- RD1 DO INC
- if S=""
- QUIT
- +1 ;I (CH="!")!(CH=",")!(CH=Q)!(CH="#") G RD1
- +2 ;I CH="^" S ERR=11 D ^XINDX1
- +3 IF '((CH="%")!(CH?1A)!(CH="*"))
- DO RD3
- GOTO RD1
- +4 SET Y=$$ASM(LV,LI,",")
- IF Y'[":"
- SET ERR=33
- SET RDTIME=1
- DO ^XINDX1
- +5 DO RD2
- GOTO RD1
- RD2 if ","[CH
- QUIT
- +1 IF "*#"[CH
- DO E^XINDX1(41)
- +2 IF "#:"[CH
- DO INC
- DO ARG^XINDX2
- DO INC
- GOTO RD2
- +3 IF (CH="%")!(CH?1A)
- SET LOC="L"
- SET GK="*"
- DO ARG^XINDX2
- DO INC
- GOTO RD2
- +4 DO INC
- GOTO RD2
- RD3 if ","[CH
- QUIT
- IF "!#?"[CH
- DO INC
- GOTO RD3
- +1 IF (CH="%")!(CH?1A)!(CH="@")
- DO ARG^XINDX2
- DO INC
- GOTO RD3
- +2 ;**MSC/EJ READ can't contain $$ (Erwin); READ $P is invalid.
- IF CH="$"
- SET ERR=21
- SET RDTIME=1
- DO ^XINDX1
- +3 QUIT
- O SET STR=ARG
- SET AC=99
- DO ^XINDX9
- DO INC
- SET ARG=""
- IF S["@"
- DO ARGS^XINDX2
- QUIT
- +1 DO ARG^XINDX2
- DO INC
- Begin DoDot:1
- +2 FOR
- DO INC
- if "
- QUIT
- +3 QUIT
- End DoDot:1
- DO INC
- DO ARGS^XINDX2
- QUIT
- +4 QUIT
- ERRCP SET ERR=5
- DO ^XINDX1
- QUIT
- ST ;
- +1 if '$DATA(V(LOC,S))
- SET V(LOC,S)=""
- if V(LOC,S)'[GK
- SET V(LOC,S)=V(LOC,S)_GK
- SET GK=""
- QUIT
- +2 QUIT
- ASM(WL,SI,L,SEP) ;assemble line Y from LV array
- +1 NEW %,CH,Y
- SET SEP=$GET(SEP)
- SET Y=""
- FOR %=SI:1
- SET CH=$GET(LV(WL,%))
- if L[CH
- QUIT
- SET Y=Y_SEP_CH
- +2 QUIT Y
