Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XINDX2

XINDX2.m

Go to the documentation of this file. 
  1. XINDX2 ;ISC/REL,GRK,RWF - PROCESS "GRB" ;4/2/08  16:35
  1.  ;;7.3;TOOLKIT;**20,27,48,110,121,133**;Apr 25, 1995;Build 16
  1.  ; Per VHA Directive 2004-038, this routine should not be modified.
  1. % 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']""
  1.  Q
  1.  ;Process argument
  1. ARGG D ^XINDX9 S I=0,AC=999 F %=0:0 S %=$O(LV(%)) Q:%'>0  S I(%)=0
  1. ARGS ;Proccess all agruments at this level
  1.  S AC=LI+AC F  Q:AC'>LI  D INC Q:S=""  D ARG
  1.  Q
  1.  ;
  1. ARG ;Process one argument
  1.  I CH="," D PEEK I ","[Y Q:$$OBJF()  D E^XINDX1(21):($$FNC()'="$$") Q  ;if ",," must be function of object method
  1.  Q:CH=Q
  1.  ;Cache Objects;  Package.Class.method or ##class(package.class).method
  1.  I $D(LV(LV,"OBJ",LI)) G OBJ2:CH=".",OBJ1
  1.  I CH="#",$E(S,1,2)="##" D OBJ Q
  1.  I S'[".",(CH?1A)!(CH="%") D LOC Q
  1.  I CH="^" S LOC="G" G NAK:S="^",EXTGLO:S["[",EXTGLO:S["|",GLO Q
  1.  I CH="$" D FUN Q
  1.  I CH="?" D PAT Q
  1.  I CH="(" D INC S NOA=S D DN,INC Q
  1.  Q
  1.  ;
  1. NAK S LOC="N"
  1.  G GLO
  1.  ;
  1. EXTGLO D E^XINDX1(50),EG,INC S S=U_S
  1.  G GLO
  1.  ;
  1. EG N GK,LOC S GK="",LOC="L" ;HANDLE EXTENDED GLOBAL
  1.  F  D INC Q:"]"[CH  Q:"|"[CH  D ARG
  1.  Q
  1. GLO S X=$E(S,2,99) I X]"",S'["^$",X'?1(1U,1"%").7UN D E^XINDX1(12)
  1.  I GK["*",$E(S,1,2)["^%" D E^XINDX1(45)
  1.  I S1="(" S S=S_S1 D PEEKDN S:(Y?1N.NP)!($A(Y)=34)!("^$J^$I^$H^"[(U_Y)) S=S_Y
  1.  D ST(LOC,S) I S1="(" D INC2 S NOA=S D DN,INC
  1.  Q
  1.  ;
  1. 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)
  1.  I S1="(" S S=S_S1 D PEEKDN S:(Y?1.N)!($A(Y)=34) S=S_Y
  1.  D ST(LOC,S) I S1="(" D INC2 S NOA=S D DN,INC
  1.  Q
  1. OBJ ;Cache Objects within ##class
  1.  S LOC="O"
  1.  I S1'="("  D E^XINDX1(3)
  1.  D PEEKDN S S=Y I S[".",'$$OBJTST(S) D E^XINDX1(64)
  1.  D ST(LOC,S),INC2 S NOA=S D DN,INC
  1.  Q
  1. OBJ1 ;Cache Objects not within ##class, contains "."
  1.  S LOC="O"
  1.  D ST(LOC,S)
  1.  Q
  1. OBJ2 ;Method
  1.  D PEEKDN
  1.  I 'Y D INC2 S NOA=S D DN,INC
  1.  Q
  1.  ;
  1. OBJF() ; return line where object has an open "(" for parameters
  1.  N %
  1.  Q:LV<2 0  ;must be down at least 1 level
  1.  S %=$O(LV(LV-1,"OBJ",""),-1) ;find last object at previous level
  1.  Q $S('%:0,LV(LV-1,%+1)="(":%,1:0) ; returns 0 if can't find object or object has no parameter
  1.  ;
  1. PEEK S Y=$G(LV(LV,LI+1))
  1.  Q
  1.  ;
  1. INC2 S LI=LI+1 ;Drop into INC
  1. INC S LI=LI+1,S=$G(LV(LV,LI)),S1=$G(LV(LV,LI+1)),CH=$E(S) G:$A(S)=10 ERR
  1.  Q
  1.  ;
  1. DN S LI(LV)=LI,LI(LV,1)=AC,LV=LV+1,LI=LI(LV),AC=NOA
  1.  D ARGS,UP
  1.  Q
  1. UP ;Inc LI as we save to skip the $C(10).
  1.  D PEEK D:$A(Y)'=10 ERR S LI(LV)=LI+1,LV=LV-1,LI=LI(LV),AC=LI(LV,1)
  1.  Q
  1.  ;
  1. PEEKDN S Y=$G(LV(LV+1,LI(LV+1)+1))
  1.  Q
  1.  ;
  1. ERR D E^XINDX1(43) S (S,S1,CH)="" Q
  1.  S Z=$P(LV(LV+1),$C(9),LI(LV+1),99),Z=$P(Z,$C(10)) W !,"COUNT=",$L(Z,",")
  1.  ;functions
  1. FUN N FUN S FUN=S G EXT:S["$$",PKG:S["$&",SPV:S1'["(" S NOA=$P(S,"^",2)
  1.  D INC2 I S'>0 D E^XINDX1(43) ;Sit on NOA
  1.  G:FUN["$TE" TEXT
  1.  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
  1.  I NOA,Y<NOA!(Y>$P(NOA,";",2)) D E^XINDX1(43)
  1.  S NOA=S D DN,INC
  1.  Q
  1.  ;
  1. TEXT ; process $T
  1.  N X1,X2
  1.  S Y=$$ASM^XINDX3(LV+1,LI(LV+1)+1,$C(10)) D ST("MK","$T("_$S($E(Y)'="+":Y,1:""))
  1.  I $$VT(Y) D ST("I",Y) ;internal label
  1.  ;check if external routine
  1.  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:""))
  1.  D FLUSH(LV+1)
  1.  Q
  1.  ;special variables
  1. SPV ;
  1.  I "^$D^$EC^$ES^$ET^$I^$K^$P^$Q^$ST^$SY^"[("^"_X_"^") D ST("MK",X)
  1.  Q
  1.  ;
  1. EXT ;Extrinsic functions
  1.  I $E(S1)="^" S Y=$E(S1,2,99)_" "_S D INC S S=Y ;Build S and fall thru
  1.  D ST($S(S[" ":"X",1:"I"),S) ;Internal, eXternal
  1.  I S1["(" D INC2 S NOA=S D DN,INC ;Process param.
  1.  Q
  1.  ;
  1. PKG ;External Package
  1.  D ST("X",S) ;Record External name
  1.  I S1["(" D INC2 S NOA=S D DN,INC ;Process param.
  1.  Q
  1.  ;
  1. PAT D INC I $E(S)="@" D INC,ARG Q
  1.  F  D REPCNT,PATCODE Q:$E(S)=""
  1.  Q
  1.  ;
  1. REPCNT F I=1:1 Q:("0123456789."'[$E(S,I))!($E(S,I)="")
  1.  S X=$E(S,1,I-1),S=$E(S,I,999) I ('$L(X))!($L(X,".")>2) S S="" D E^XINDX1(16)
  1.  Q
  1.  ;
  1. 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
  1.  F I=1:1 Q:("ACELNPUacelnpu()"'[$E(S,I))!($E(S,I)="")
  1.  S X=$E(S,1,I-1),S=$E(S,I,999) I I=1 S S="" D E^XINDX1(16)
  1.  I $E(S)="," S S=$E(S,2,999) ;Pull ',' out of alternation
  1.  Q
  1.  ;
  1. PATQ F I=I+1:1 S CH=$E(S,I) Q:CH=""!(CH=Q)
  1.  S I=I+1 D:CH="" E^XINDX1(6) S CH=$E(S,I) G:CH=Q PATQ
  1.  Q
  1.  ;
  1. 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
  1.  S GK=""
  1.  Q
  1.  ;
  1. VT(X) ;Check if a valid label
  1.  Q (X?1A.31AN)!(X?1"%".31UN)!(X?1.31N)
  1.  ;
  1. VA(X) ;Check if VA Standard label
  1.  Q (X?1U.7UN)!(X?1"%".7UN)!(X?1.8N)
  1.  ;
  1. FLUSH(L) ;Flush rest of list with this offset
  1.  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)
  1.  S LI(L)=I Q
  1.  ;
  1. FNC(NEW) ;Sets or returns the current function
  1.  I $D(NEW) S LV(LV+1,"FNC",LI)=NEW Q
  1.  N W
  1.  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
  1.  Q $G(LV(LV,"FNC",W))
  1.  ;
  1. OP(NEW) ;Sets or returns the current operator
  1.  I $D(NEW) S LV(LV,"OP",LI)=NEW Q
  1.  N W S W=+$S($D(LV(LV,"OP",LI)):LI,1:$O(LV(LV,"OP",LI),-1))
  1.  Q $G(LV(LV,"OP",W))
  1.  ;
  1. OBJTST(OBJ) ;test if OBJ exists, returns 1 if exists
  1.  Q:$G(OBJ)="" 0
  1.  Q ##class(%Dictionary.ClassDefinition).%ExistsId(""_OBJ_"")
  1.  ;