XINDX2 ;ISC/REL,GRK,RWF - PROCESS "GRB" ;4/2/08 16:35
;;7.3;TOOLKIT;**20,27,48,110,121,133,140**;Apr 25, 1995;Build 40
; Per VHA Directive 2004-038, this routine should not be modified.
% S LINE=GRB,(CM,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 ^XINDX9 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 I ","[Y Q:$$OBJF() D E^XINDX1(21):($$FNC()'="$$") Q ;if ",," must be function of object method
Q:CH=Q
;Cache Objects; Package.Class.method or ##class(package.class).method
I $D(LV(LV,"OBJ",LI)) G OBJ2:CH=".",OBJ1
I CH="#",$E(S,1,2)="##" D OBJ Q
I S'[".",(CH?1A)!(CH="%") D LOC Q
I CH="^" S LOC="G" G NAK:S="^",EXTGLO: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^XINDX1(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 Q:"|"[CH D ARG
Q
GLO S X=$E(S,2,99) I X]"",S'["^$",X'?1(1U,1"%").7UN D E^XINDX1(12)
I GK["*",$E(S,1,2)["^%" D E^XINDX1(45)
I S1="(" S S=S_S1 D PEEKDN S:(Y?1N.NP)!($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" ;Check variables at end. I S'?1.8UN,S'?1"%".7UN,S'?1.8LN,S'?1"%".7LN D E^XINDX1(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
OBJ ;Cache Objects within ##class
S LOC="O"
I S1'="(" D E^XINDX1(3)
D PEEKDN S S=Y I S[".",'$$OBJTST(S) D E^XINDX1(64)
D ST(LOC,S),INC2 S NOA=S D DN,INC
Q
OBJ1 ;Cache Objects not within ##class, contains "."
S LOC="O"
D ST(LOC,S)
Q
OBJ2 ;Method
D PEEKDN
I 'Y D INC2 S NOA=S D DN,INC
Q
;
OBJF() ; return line where object has an open "(" for parameters
N %
Q:LV<2 0 ;must be down at least 1 level
S %=$O(LV(LV-1,"OBJ",""),-1) ;find last object at previous level
Q $S('%:0,LV(LV-1,%+1)="(":%,1:0) ; returns 0 if can't find object or object has no parameter
;
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^XINDX1(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["$$",PKG:S["$&",SPV:S1'["(" S NOA=$P(S,"^",2)
D INC2 I S'>0 D E^XINDX1(43) ;Sit on NOA
G:FUN["$TE" TEXT
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^XINDX1(43)
S NOA=S D DN,INC
Q
;
TEXT ; process $T
N X1,X2
S Y=$$ASM^XINDX3(LV+1,LI(LV+1)+1,$C(10)) D ST("MK","$T("_$S($E(Y)'="+":Y,1:""))
I $$VT(Y) D ST("I",Y) ;internal label
;check if external routine
I Y["^",$$VT($P(Y,"^",2)) S X1=$P(Y,"^"),X2=$P(Y,"^",2),Y=X1 D ST("X",X2_$S($$VT(X1):" "_X1,1:""))
D FLUSH(LV+1)
Q
;special variables
SPV ;
I "^$D^$EC^$ES^$ET^$I^$K^$P^$Q^$ST^$SY^"[("^"_X_"^") D ST("MK",X)
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
;
PKG ;External Package
D ST("X",S) ;Record External name
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^XINDX1(16)
Q
;
PATCODE I $E(S)=Q S I=1 D PATQ S S=$E(S,I,999) S:$L(CH)&(",)"[CH) S=$E(S,2,999) Q
F I=1:1 Q:("ACELNPUacelnpu()"'[$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^XINDX1(16)
I $E(S)="," S S=$E(S,2,999) ;Pull ',' out of alternation
Q
;
PATQ F I=I+1:1 S CH=$E(S,I) Q:CH=""!(CH=Q)
S I=I+1 D:CH="" E^XINDX1(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 label
Q (X?1A.31AN)!(X?1"%".31UN)!(X?1.31N)
;
VA(X) ;Check if VA Standard label ;P140
Q (X?1U.15UN)!(X?1"%".15UN)!(X?1.16N)
;
FLUSH(L) ;Flush rest of list with this offset
N I,CH S I=LI(L)+1 F I=I:1 S CH=$G(LV(L,I)) Q:$C(10)[CH D:CH="(" FLUSH(L+1)
S LI(L)=I Q
;
FNC(NEW) ;Sets or returns the current function
I $D(NEW) S LV(LV+1,"FNC",LI)=NEW Q
N W
S W=+$S($D(LV(LV,"FNC",LI)):LI,$O(LV(LV,"FNC",LI),-1):$O(LV(LV,"FNC",LI),-1),1:$O(LV(LV,"FNC",LI))) ;patch 119,121
Q $G(LV(LV,"FNC",W))
;
OP(NEW) ;Sets or returns the current operator
I $D(NEW) S LV(LV,"OP",LI)=NEW Q
N W S W=+$S($D(LV(LV,"OP",LI)):LI,1:$O(LV(LV,"OP",LI),-1))
Q $G(LV(LV,"OP",W))
;
OBJTST(OBJ) ;test if OBJ exists, returns 1 if exists
Q:^%ZOSF("OS")'["OpenM" 1
Q:$G(OBJ)="" 0
Q ##class(%Dictionary.ClassDefinition).%ExistsId(""_OBJ_"")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXINDX2 5429 printed Apr 09, 2024@21:42:20 Page 2
XINDX2 ;ISC/REL,GRK,RWF - PROCESS "GRB" ;2018-02-28 10:30 AM
+1 ;;7.3;TOOLKIT;**20,27,48,110,121,133,140,10001**;Apr 25, 1995;Build 4
+2 ; Original routine authored by U.S. Department of Veterans Affairs
+3 ; OBJTEST+1:3 by Kitware/Jason Li
% SET LINE=GRB
SET (CM,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 ^XINDX9
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 ",," must be function of object method
IF CH=","
DO PEEK
IF ","[Y
if $$OBJF()
QUIT
if ($$FNC()'="$$")
DO E^XINDX1(21)
QUIT
+2 if CH=Q
QUIT
+3 ;Cache Objects; Package.Class.method or ##class(package.class).method
+4 IF $DATA(LV(LV,"OBJ",LI))
if CH="."
GOTO OBJ2
GOTO OBJ1
+5 IF CH="#"
IF $EXTRACT(S,1,2)="##"
DO OBJ
QUIT
+6 IF S'["."
IF (CH?1A)!(CH="%")
DO LOC
QUIT
+7 IF CH="^"
SET LOC="G"
if S="^"
GOTO NAK
if S["["
GOTO EXTGLO
if S["|"
GOTO EXTGLO
GOTO GLO
QUIT
+8 IF CH="$"
DO FUN
QUIT
+9 IF CH="?"
DO PAT
QUIT
+10 IF CH="("
DO INC
SET NOA=S
DO DN
DO INC
QUIT
+11 QUIT
+12 ;
NAK SET LOC="N"
+1 GOTO GLO
+2 ;
EXTGLO DO E^XINDX1(50)
DO EG
DO INC
SET S=U_S
+1 GOTO GLO
+2 ;
EG ;HANDLE EXTENDED GLOBAL
NEW GK,LOC
SET GK=""
SET LOC="L"
+1 FOR
DO INC
if "]"[CH
QUIT
if "|"[CH
QUIT
DO ARG
+2 QUIT
GLO SET X=$EXTRACT(S,2,99)
IF X]""
IF S'["^$"
IF X'?1(1U,1"%").7UN
DO E^XINDX1(12)
+1 IF GK["*"
IF $EXTRACT(S,1,2)["^%"
DO E^XINDX1(45)
+2 IF S1="("
SET S=S_S1
DO PEEKDN
if (Y?1N.NP)!($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
+5 ;
LOC ;Check variables at end. I S'?1.8UN,S'?1"%".7UN,S'?1.8LN,S'?1"%".7LN D E^XINDX1(11)
SET LOC="L"
+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
OBJ ;Cache Objects within ##class
+1 SET LOC="O"
+2 IF S1'="("
DO E^XINDX1(3)
+3 DO PEEKDN
SET S=Y
IF S["."
IF '$$OBJTST(S)
DO E^XINDX1(64)
+4 DO ST(LOC,S)
DO INC2
SET NOA=S
DO DN
DO INC
+5 QUIT
OBJ1 ;Cache Objects not within ##class, contains "."
+1 SET LOC="O"
+2 DO ST(LOC,S)
+3 QUIT
OBJ2 ;Method
+1 DO PEEKDN
+2 IF 'Y
DO INC2
SET NOA=S
DO DN
DO INC
+3 QUIT
+4 ;
OBJF() ; return line where object has an open "(" for parameters
+1 NEW %
+2 ;must be down at least 1 level
if LV<2
QUIT 0
+3 ;find last object at previous level
SET %=$ORDER(LV(LV-1,"OBJ",""),-1)
+4 ; returns 0 if can't find object or object has no parameter
QUIT $SELECT('%:0,LV(LV-1,%+1)="(":%,1:0)
+5 ;
PEEK SET Y=$GET(LV(LV,LI+1))
+1 QUIT
+2 ;
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
+1 QUIT
+2 ;
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
+2 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)
+2 QUIT
+3 ;
PEEKDN SET Y=$GET(LV(LV+1,LI(LV+1)+1))
+1 QUIT
+2 ;
ERR DO E^XINDX1(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 S["$&"
GOTO PKG
if S1'["("
GOTO SPV
SET NOA=$PIECE(S,"^",2)
+1 ;Sit on NOA
DO INC2
IF S'>0
DO E^XINDX1(43)
+2 if FUN["$TE"
GOTO TEXT
+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^XINDX1(43)
+5 SET NOA=S
DO DN
DO INC
+6 QUIT
+7 ;
TEXT ; process $T
+1 NEW X1,X2
+2 SET Y=$$ASM^XINDX3(LV+1,LI(LV+1)+1,$CHAR(10))
DO ST("MK","$T("_$SELECT($EXTRACT(Y)'="+":Y,1:""))
+3 ;internal label
IF $$VT(Y)
DO ST("I",Y)
+4 ;check if external routine
+5 IF Y["^"
IF $$VT($PIECE(Y,"^",2))
SET X1=$PIECE(Y,"^")
SET X2=$PIECE(Y,"^",2)
SET Y=X1
DO ST("X",X2_$SELECT($$VT(X1):" "_X1,1:""))
+6 DO FLUSH(LV+1)
+7 QUIT
+8 ;special variables
SPV ;
+1 IF "^$D^$EC^$ES^$ET^$I^$K^$P^$Q^$ST^$SY^"[("^"_X_"^")
DO ST("MK",X)
+2 QUIT
+3 ;
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
+5 ;
PKG ;External Package
+1 ;Record External name
DO ST("X",S)
+2 ;Process param.
IF S1["("
DO INC2
SET NOA=S
DO DN
DO INC
+3 QUIT
+4 ;
PAT DO INC
IF $EXTRACT(S)="@"
DO INC
DO ARG
QUIT
+1 FOR
DO REPCNT
DO PATCODE
if $EXTRACT(S)=""
QUIT
+2 QUIT
+3 ;
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^XINDX1(16)
+2 QUIT
+3 ;
PATCODE IF $EXTRACT(S)=Q
SET I=1
DO PATQ
SET S=$EXTRACT(S,I,999)
if $LENGTH(CH)&(",)"[CH)
SET S=$EXTRACT(S,2,999)
QUIT
+1 FOR I=1:1
if ("ACELNPUacelnpu()"'[$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^XINDX1(16)
+3 ;Pull ',' out of alternation
IF $EXTRACT(S)=","
SET S=$EXTRACT(S,2,999)
+4 QUIT
+5 ;
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^XINDX1(6)
SET CH=$EXTRACT(S,I)
if CH=Q
GOTO PATQ
+2 QUIT
+3 ;
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=""
+2 QUIT
+3 ;
VT(X) ;Check if a valid label
+1 QUIT (X?1A.31AN)!(X?1"%".31UN)!(X?1.31N)
+2 ;
VA(X) ;Check if VA Standard label ;P140
+1 QUIT (X?1U.15UN)!(X?1"%".15UN)!(X?1.16N)
+2 ;
FLUSH(L) ;Flush rest of list with this offset
+1 NEW I,CH
SET I=LI(L)+1
FOR I=I:1
SET CH=$GET(LV(L,I))
if $CHAR(10)[CH
QUIT
if CH="("
DO FLUSH(L+1)
+2 SET LI(L)=I
QUIT
+3 ;
FNC(NEW) ;Sets or returns the current function
+1 IF $DATA(NEW)
SET LV(LV+1,"FNC",LI)=NEW
QUIT
+2 NEW W
+3 ;patch 119,121
SET W=+$SELECT($DATA(LV(LV,"FNC",LI)):LI,$ORDER(LV(LV,"FNC",LI),-1):$ORDER(LV(LV,"FNC",LI),-1),1:$ORDER(LV(LV,"FNC",LI)))
+4 QUIT $GET(LV(LV,"FNC",W))
+5 ;
OP(NEW) ;Sets or returns the current operator
+1 IF $DATA(NEW)
SET LV(LV,"OP",LI)=NEW
QUIT
+2 NEW W
SET W=+$SELECT($DATA(LV(LV,"OP",LI)):LI,1:$ORDER(LV(LV,"OP",LI),-1))
+3 QUIT $GET(LV(LV,"OP",W))
+4 ;
OBJTST(OBJ) ;test if OBJ exists, returns 1 if exists
+1 ;; Begin Change (OSEHRA/JL) Return 1 for non-Cache system
+2 if ^%ZOSF("OS")'["OpenM"
QUIT 1
+3 ;; END Change (OSEHRA/JL)
+4 if $GET(OBJ)=""
QUIT 0
+5 QUIT ##class(%Dictionary.ClassDefinition).%ExistsId(""_OBJ_"")
+6 ;
