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 Nov 22, 2024@17:49:57 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
