;Routine Save - 09:24 AM  May 7, 1997 (Open M [DTM] for MS-DOS/6.4/12APR96 NETWORK WS 32-BIT/Build 02)
;Saved From DVA: FROM GFT, 5 DIM* ROUTINES IN MSM/DSM FORMAT
DIM
DIM ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Main ;5/1/97  13:05
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12275;2166017;1384;
 ;
 S %X=X,%END="",%ERR=0,%LAST="" G ER:X'?.ANP
 ;
GC ; get next command on line (*)
 G ER:%ERR,LAST:";"[$E(%X),ER:"BCDEFGHIKLMNOQRSUWXZ"'[$E(%X)
 S %LAST=%X D SEP G ER:%ERR S %COM=$P(%ARG,":") ; command word
 I $L(%COM)>1 D  G ER:%ERR
 . I $T(COMMAND)'[(";"_%COM_";"),%COM'?1"Z"1.U S %ERR=1
 . E  S %COM=$E(%COM)
 S %=$P(%ARG,":",2,99),%COM(1)=% I %ARG[":",%="" G ER ; command postcond
 I %]"" D ^DIM1 G ER:%ERR
 D SEP G ER:%ERR I %ARG="","CDGMORSUWXZ"[%COM G ER ; argument list
 S %END=%ARG G @%COM
 ;
B G GC:%ARG=""&(%COM(1)=""),BK^DIM4
C G CL^DIM4
D G DG^DIM3
E G GC:%ARG=""&(%COM(1)=""),ER
F G ER:%COM(1)]"",GC:%ARG="",FR^DIM3
G G DG^DIM3
H G GC:%ARG=""&(%COM(1)="")&(%X]""),HN^DIM3:%ARG]"",ER Q
I G ER:%COM(1)]"",IX^DIM4
K G GC:%ARG=""&(%COM(1)="")&(%X]""),KL^DIM3:%ARG]"",ER
L G LK^DIM3
M G S
N G ER:%ARG=""&(%X=""),K
O G OP^DIM3
Q G ER:%ARG]"",GC:%ARG=""&(%COM(1)=""),BK^DIM4
R G RD^DIM4
S G ST^DIM4
U G OP^DIM3
W G WR^DIM4
X G IX^DIM4
Z G GC
 ;
SEP ; remove first " "-piece of %X into %ARG: parse commands (GC)
 F %I=1:1 S %C=$E(%X,%I) D:%C=""""  Q:" "[%C
 . N %OUT S %OUT=0 F  D  Q:%OUT!%ERR
 . . S %I=%I+1,%C=$E(%X,%I) I %C="" S %ERR=1 Q
 . . Q:%C'=""""  S %I=%I+1,%C=$E(%X,%I) Q:%C=""""  S %OUT=1
 S %ARG=$E(%X,1,%I-1),%I=%I+1,%X=$E(%X,%I,999)
 Q
 ;
COMMAND ;;BREAK;CLOSE;DO;ELSE;FOR;GOTO;HALT;HANG;IF;KILL;LOCK;MERGE;NEW;OPEN;QUIT;READ;SET;USE;WRITE;XECUTE;
 ;
LAST ; check to ensure no trailing "," or " " at end of command (GC)
 S %L=$L(%LAST),$E(%LAST,%L+1-$L(%X),%L)=""
 I $E(%END,$L(%END))="," G ER
 I $E(%X)="",$E(%LAST,%L)=" " G ER
 G END
 ;
ER K X
END K %,%A,%A1,%A2,%ARG,%C1,%C,%COM,%END,%ERR,%H,%I,%L,%LAST,%P,%X,%Z Q

DIM1
DIM1 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;5/1/97  12:17
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12276;6984801;3048;
 ;
 Q:%ERR  N %A,%A1 S (%I,%N,%ERR,%(-1,2),%(-1,3))=0
 ;
GG ; expr, expratom, expritem, subscript, parameter (called everywhere)
 D %INC G:%C="" FINISH^DIM2
 G E:%C=";"!($A(%C)>95)!($A(%C)<33)
 G QUOTE:%C="""",FUNC:%C="$",SUB^DIM2:%C="(",UP^DIM2:%C=")"
 G AR^DIM2:%C=",",SEL^DIM2:%C=":",GLO^DIM2:%C="^"
EXP I %C="E",$E(%,%I-1)?1N D  G E:%ERR S %I=%I-1 G GG
 . S %L1=$E(%,%I+1)
 . I %L1'?1(1N,1"+",1"-") S %ERR=1 Q
 . N %OUT S %OUT=0 F %I=%I+2:1 D  Q:%ERR!%OUT
 . . S %C=$E(%,%I)
 . . I "<>=!&'[]+-*/\#_?,:)"[%C S %OUT=1 Q
 . . I %C'?1N S %ERR=1 Q
 I %C?1(1U,1"%") D VAR^DIM2
 G E:%ERR,GG:%C=""
 G PAT^DIM2:%C="?",BINOP^DIM2:"=[]<>&!"[%C,MTHOP^DIM2:"/\*#_"[%C
 G UNOP^DIM2:"'+-"[%C,IND^DIM2:%C="@"
PERIOD I %C="." D  G E:%ERR
 . I $P($G(%(%N-1,0)),"^")="P" D  Q
 . . N %C S %C=$E(%,%I+1) I %C?1N Q  ; decimal pass by value
 . . I %C'="@",%C'?1U,%C'="%" S %ERR=1 ; bad pass by reference
 . D %INC N %L1,%P S %L1=$E(%,%I-2),%P="':=+-\/<>[],)*&!_#"
 . I %L1?1N,%C?1N Q  ; 4.2
 . I %P[%L1,%C?1N Q  ; +.2
 . S %ERR=1 ; illegal period
 I %C?1N,$E(%,%I+1)]"" G E:$E(%,%I+1)'?1(1NP,1"E")
GG1 ;
 I %C]"","$(),:"""[%C S %I=%I-1
 G GG
 ;
QUOTE ; strlit (GG)
 F %J=0:0 D %INC Q:%C=""!(%C="""")
 G E:%C=""!("[]()><\/+-=&!_#*,;:'"""'[$E(%,%I+1)) D:$D(%(%N-1,"F")) FN:%(%N-1,"F")["FN" G E:%ERR,GG
 ;
FUNC ; intrinsics & extrinsics, mainly intrinsic functions (GG)
 D %INC G EXT:%C="$",E:%C'?1U,SPV:$E(%,%I,999)'?.U1"(".E,FUNC1:%C="Z"!($E(%,%I+1)="(")
 S %T=$E(%,%I,$F(%,"(",%I)-2)
 I %T="ST"!(%T="STACK") G E ; SAC
 F %F1="FNUMBER^2;3","TRANSLATE^2;3","NAME^1;2","QLENGTH^1;1","QSUBSCRIPT^2;2","REVERSE^1;1" G FUNC2:$E(%F1,1,2)=%T,FUNC2:$P(%F1,"^")=%T
FNC ;;,ASCII^1;2,CHAR^1;999,DATA^1;1,EXTRACT^1;3,FIND^2;3,GET^1;2,JUSTIFY^2;3,LENGTH^1;2,ORDER^1;2,PIECE^2;4,QUERY^1;1,RANDOM^1;1,SELECT^1;999,TEXT^1;1,VIEW^1;999,ZFUNC^1;999
 G E:$T(FNC)'[(","_%T_"^")
FUNC1 S %F1=$P($T(FNC),",",$F("ACDEFGJLOPQRSTVZ",%C)) G E:%F1=""
FUNC2 S %I=$F(%,"(",%I)-1,%(%N,0)="1^"_$P(%F1,"^",2),%(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%(%N,"F")=%F1,%N=%N+1 S:$E(%F1)="S" %(%N-1,2)=1
 I ",DATA,NAME,ORDER,QUERY,GET,"[(","_$P(%F1,"^")_",") G DATA^DIM2
 I $E(%F1)="T",$E(%F1,2)'="R" D  I %ERR G ERR^DIM2
 . S %A=%I,%I=$F(%,")",%A)-1,%N=%N-1,%A=$P($E(%,%A,%I-1),"(",2,99)
 . I %A?1"+"1N.E S %A=$E(%A,2,999)
 . N %,%I,%N S %=%A D LABEL^DIM3(1)
 G GG
 ;
SPV ; intrinsic special variables (FUNC)
 I $E(%,%I+1)?1U S %I=%I+1,%C=%C_$E(%,%I) G SPV
 I ",D,EC,ES,ET,K,P,Q,ST,SY,TL,TR,"[(","_%C_",") G E ; SAC
 I "HIJSTXYZ"[%C&(%C?1U)!(%C?1"Z".U) G GG
 I "[],)><=_&#!'+-*\/?"'[$E(%,%I+1) G E
 I ",DEVICE,ECODE,ESTACK,ETRAP,KEY,PRINCIPAL,QUIT,STACK,SYSTEM,TLEVEL,TRESTART,"[(","_%C_",") G E ; SAC
 I ",HOROLOG,IO,JOB,STORAGE,TEST,"[(","_%C_",") G GG
E G ERR^DIM2
 ;
%INC S %I=%I+1,%C=$E(%,%I) Q
 ;
FN ; literal string argument 2 of $FNUMBER (QUOTE)
 Q:%(%N-1,1)'=1  F %FZ=%I-1:-1 S %FN=$E(%,%FZ) Q:%FN=""""
 S %FN=$TR($E(%,%FZ+1,%I-1),"pt","PT")
 F %FZ=1:1 Q:$E(%FN,%FZ)=""  I "+-,TP"'[$E(%FN,%FZ) S %ERR=1 Q
 Q:%ERR  I %FN["P" F %FZ=1:1 Q:$E(%FN,%FZ)=""  I "+-T"[$E(%FN,%FZ) S %ERR=1 Q
 Q
 ;
EXT ; extrinsic functions and variables (FUNC)
 D %INC
 F %I=%I+1:1 S %C1=$E(%,%I) Q:%C1?1PC&("^%"'[%C1)!(%C1="")  S %C=%C_%C1
 G:%C="" E G:%C?.E1"^" E G:%C["^^" E
 S %C1=$P(%C,"^",2) I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN G E
 S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N G E
 I $E(%,%I)="(",$E(%,%I+1)'=")" S %(%N,0)="P^",(%(%N,1),%(%N,2),%(%N,3))=0,%N=%N+1 G GG
 S %I=%I+$S($E(%,%I,%I+1)="()":1,1:-1)
 G GG:"[],)><=_&#!'+-*/\?"[$E(%,%I+1),E

DIM2
DIM2 ;SFISC/XAK,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;5/1/97  15:28
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12277;5560907;3466;
 ;
SUB ; "(": open paren situations (GG^DIM1)
 F %J=%I-1:-1 S %C1=$E(%,%J) Q:%C1'?1(1UN,1"%")
 S %C1=$E(%,%J+1,%I-1)
 I %C1]"",%C1'?1U.UN,$E(%,%J,%I-1)'?1"%".UN G ERR
 I %C1]"",%[("."_%C1) G ERR
 S %(%N,0)=$S(%C1]""!($E(%,%J)="^"):"V^",$E(%,%J)="@":"@^",1:"0^")
 S %(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%N=%N+1 G 1
 ;
UP ; ")": close paren situations (GG^DIM1)
 I %N=0 G ERR
 I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR
 I $E(%,%I+1)]"","<>_[]:/\?'+-=!&#*),"""'[$E(%,%I+1) G ERR
 S %N=%N-1,%(%N,1)=%(%N,1)+1,%F=$P(%(%N,0),"^") I %F D  G ERR:%ERR
 . S %F=$P(%(%N,0),"^",2),%F1=%(%N,1)
 . I %F1<+%F S %ERR=1 Q  ; not enough commas for this function
 . I %F1>$P(%F,";",2) S %ERR=1 Q  ; too many commas for this function
 . I %(%N,2),'%(%N,3) S %ERR=1 ; we're in $S and haven't yet hit a :
 K %(%N+1)
 I '%F,%F'["V",%F'["@",%F'["P",%(%N,1)>1 G ERR
 G 1
 ;
AR ; ",": comma situations -- "P" below means "parameters" (GG^DIM1)
 I %N<1 G ERR
 I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR
 I '%(%N-1,3),%(%N-1,2) G ERR
 I "@("[$E(%,1,2) G ERR
 S %(%N-1,1)=%(%N-1,1)+1,%(%N-1,3)=0 G 1
 ;
SEL ; ":": $SELECT delimiter (GG^DIM1)
 S %(%N-1,3)=%(%N-1,3)+1 G ERR:'%(%N-1,2)!(%(%N-1,3)>1),1
 ;
GLO ; "^": global reference (GG^DIM1)
 D %INC G ERR:$E(%,%I,999)'?1U.UN.P.E&("%("'[%C)
 G ERR:"=+-\/<>(,#!&*':@[]_"'[$E(%,%I-2)
 S %I=%I-1 G 1
 ;
PAT ; "?": pattern match (GG^DIM1)
 G ERR:%I=1,1:$E(%,%I+1)="@" D %INC,PATTERN G ERR:%ERR S %I=%I-1 G 1
 ;
PATTERN F  D PATATOM Q:%C'?1N&(%C'=".")!%ERR
 Q
PATATOM D REPCOUNT Q:%ERR
 I %C="""" D STRLIT,%INC:'%ERR Q
 I %C="(" D ALTRN8 Q
 D PATCODE
 Q
REPCOUNT ;
 I %C'?1N,%C'="." S %ERR=1 Q
 I %C?1N D INTLIT Q:%ERR
 I %C="." D %INC
 I %C?1N D INTLIT
 Q
INTLIT I %C'?1N S %ERR=1 Q
 F  D %INC Q:%C'?1N
 Q
STRLIT F  D %INC Q:%C=""  I %C="""" Q:$E(%,%I+1)'=""""  S %I=%I+1
 I %C="" S %ERR=1
 Q
PATCODE I "ACELNPU"'[%C S %ERR=1 Q
 F  D %INC Q:%C=""  Q:"ACELNPU"'[%C
 Q
ALTRN8 I %C'="(" S %ERR=1 Q
 D %INC,PATATOM Q:%ERR
 F  Q:","'[%C  D %INC,PATATOM Q:%ERR
 I %C'=")" S %ERR=1 Q
 D %INC
 Q
 ;
BINOP ; binary operator (GG^DIM1)
 S %Z1=""")%'",%Z2="""($+-^%@'." G OPCHK
 ;
MTHOP ; math or relational operator (GG^DIM1)
 S %Z1=""")%",%Z2="""($+-^%@'." G OPCHK
 ;
UNOP ; unary operator (GG^DIM1)
 S %Z1=""":<>+-'\/()%@#&!*=_][,"
 S %Z2="""($+-=&!^%.@'" I %C="'" S %Z2=%Z2_"<>?[]"
 G OPCHK
 ;
IND ; "@": indirection (GG^DIM1)
 I $E(%COM)="F" G ERR
 S %Z1="^?@(%+-=\/#*!&'_<>[]:,.",%Z2="""(+^-'$@%" G OPCHK
 ;
OPCHK ; ensure that the characters before and after the operator are OK
 S %L1=$E(%,%I-1),%L2=$E(%,%I+1) I %L1="'","[]&!<>="[%C S %L1=$E(%,%I-2)
 I %L1="","+-'@"'[%C G ERR ;              binary: require before
 I %L1'?1UN,%Z1'[%L1 G ERR ;              all: screen before
 F %F="*","]" I %C=%F,%L2=%F S %I=%I+1,%L2=$E(%,%I+1) Q
 I %L2="" G ERR ;                         all: require after
 I %L2'?1UN,%Z2'[%L2 G ERR ;              all: screen after
 I %C="'","!&[]?=<>"'[%L2,%L1?1UN G ERR ; unary ': not binary
 G 1
 ;
1 ; common exit point for all of ^DIM2
 G GG^DIM1
 ;
DATA ; glvn arguments of $D,$G,$NA,$O, & $Q functions (FUNC^DIM1)
 D %INC G ERR:%C="",ERR:%C=")",DATA:"^@"[%C D VAR
 G ERR:"@(,)"'[%C!%ERR,GG1^DIM1
 ;
VAR ; variables encountered while parsing exprs (DATA, GG^DIM1)
 N %START S %START=%I-1 I $E(%,%START)="^" S %START=%START-1
 I %C="%" D %INC
 N OUT S OUT=0 F %J=%I:1 S %C=$E(%,%J) D  Q:OUT
 . I ",<>?/\[]+-=_()*&#!':"[%C S OUT=1 Q
 . I %C="@",$E(%,%J+1)="(",$E(%,%START)="@" S OUT=1 Q
 . I %C'?1UN S %ERR=1
 . I %C="^",$D(%(%N-1,"F")),%(%N-1,"F")["TEXT" S %ERR=0,OUT=1
 Q:%ERR
 I %C="@" S %I=%J Q
 S %F=$E(%,%I,%J-1)
 I %F="^",$E(%,%J)'="(" S %ERR=1
 I %F]"",%F'?1U.UN,$E(%,%I-1,%J-1)'?1"%".UN S %ERR=1
 S %I=%J Q
 ;
%INC S %I=%I+1,%C=$E(%,%I)
 Q
 ;
ERR S %ERR=1,%N=0
FINISH G ERR:%N'=0 K %C,%,%F,%F1,%I,%J,%L1,%L2,%N,%T,%Z1,%Z2,%FN,%FZ
Q Q

DIM3
DIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/1/97  12:52
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12278;5200663;2989;
 ;
DG ; DO and GET (D^DIM and G^DIM)
 G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR
 S %L=":" D PARS1 G ER:%ERR I %C=%L G ER:%A1="" S %=%A1 D ^DIM1
 I %A["@^" S %=%A D ^DIM1 G DG
 I %A["(",$E(%A)'="@",$E($P(%A,"^",2))'="@" D  G ER:%ERR
 . I %COM'="D" S %ERR=1 Q
 . S %=%A
 . I %'?.E1"(".E1")" S %ERR=1 Q
 . S %C=$P(%,"("),%C1=$P(%C,"^",2,999),%I=$F(%,"(")-1
 . I %C=""!(%C?.E1"^") S %ERR=1 Q
 . I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN S %ERR=1 Q
 . S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N S %ERR=1 Q
 . Q:$E(%,%I,%I+1)="()"
 . S (%(-1,2),%(-1,3))=0,%N=1,%(0,0)="P^",(%(0,1),%(0,2),%(0,3))=0
 . D GG^DIM1
 E  D LABEL(0)
 G DG
 ;
LABEL(OFFSET) ; labelref, entryref, and $TEXT argument (DG and TEXT^DIM1)
 S %L="^" D PARS1 Q:%ERR
 I %C=%L S:%A1=""!($E(%A1)="^") %ERR=1 S %=%A1 D VV,^DIM1 Q:%ERR
 S %=%A D VV:%'=+%&'OFFSET,^DIM1 Q
 ;
KL ; KILL, LOCK, and NEW (K^DIM and LK)
 D PARS G ER:%ERR
 I %A="",%C="," G ER
 I %A?1"^"1UP.UN,%COM'="L" G ER
 I %A?1"(".E1")" D  G KL
 . S %ARG("E")=$L(%ARG)
 . S %A=$E(%A,2,$L(%A)-1) S %ARG=%A_$S(%ARG]"":","_%ARG,1:"")
 S %=%A I %COM="L","+-"[$E(%A) S $E(%A)=""
 I %COM="N",'$$LNAME(%) G ER
 I %COM="K",$D(%ARG("E")),'$$LNAME(%) G ER
 I $D(%ARG("E")),$L(%ARG)'>%ARG("E") K %ARG("E")
 D VV,^DIM1 G GC^DIM:%ARG=""!%ERR
 G KL
 ;
LK ; LOCK (L^DIM)
 S %A=%ARG,%L=":" S:"+-"[$E(%A) %A=$E(%A,2,999) D PARS1
 I %C=%L G ER:%A1="" S %=%A1 D ^DIM1
 S %ARG=%A G GC^DIM:%A="",KL
 ;
HN ; HANG (H^DIM)
 S %=%ARG D ^DIM1 G GC^DIM
 ;
OP ; OPEN and USE (O^DIM and U^DIM)
 G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR!(%C=","&(%A=""))
 G US:%COM="U" S %L=":" D PARS1 S %A2=%A,%A=%A1 S:%C=%L&(%A="") %ERR=1 D PARS1 G ER:%ERR!(%C=%L&(%A1=""))
 F %L="%A1","%A2" S %=@%L D ^DIM1 G OP:%ERR
 G OP
US S %L=":" D PARS1 G ER:%C=%L&(%A1="") S %=%A D ^DIM1
 S %A=%A1 D PARS1 G ER:%C]"",OP
 ;
FR ; FOR (F^DIM)
 S %L="=",%A=%ARG D PARS1 G ER:%ERR!(%A1="")!(%A="") S %ARG=%A1
 S %=%A G ER:%A?1"^".E D VV,^DIM1 G ER:%ERR
FR1 G GC^DIM:%ARG=""!%ERR D PARS
 S %L=":" F %A=%A,%A1 D PARS1 G ER:%ERR!(%A=""&(%C=%L)) S %=%A D ^DIM1
 I %A1]"" S %=%A1 D ^DIM1
 G FR1
 ;
PARS S (%A,%C)="" Q:%ERR  S (%ERR,%I)=0
INC D %INC D QT:%C="""",PARAN:%C="(" Q:%ERR  G OUT:","[%C,INC
QT D %INC Q:%C=""""  G QT:%C]"" S %ERR=1 Q
PARAN S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q
%INC S %I=%I+1,%C=$E(%ARG,%I) Q
 ;
PARS1 S (%A1,%C)="" Q:%ERR  S (%ERR,%I)=0
INCR D %INC1 D QT1:%C="""",PARAN1:%C="(" Q:%ERR=1  G OUT1:%L[%C,INCR
OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q
QT1 D %INC1 Q:%C=""""  G QT1:%C]"" S %ERR=1 Q
PARAN1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
%INC1 S %I=%I+1,%C=$E(%A,%I) Q
 ;
VV ; variable, label, or routine name (LABEL, KL, and FR)
 I '%ERR,%]"",%'["@",%'?1U.UN,%'?1U.UN1"(".E1")",%'?1"%".UN1"(".E1")",%'?1"%".UN,%'?1"^"1U.UN1"(".E1")",%'?1"^%".UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.UN S %ERR=1
 S:%["?@" %ERR=1 Q
 ;
LNAME(%) ; lname (KL)
 I %?1(1A,1"%").7UN Q 1
 I %?1"@".E Q 1
 Q 0
 ;
ER G ER^DIM

DIM4
DIM4 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/1/97  08:52
 ;;21.0;VA FileMan;;Dec 28, 1994
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;12279;3358037;2573;
 ;
BK ; BREAK and QUIT (B^DIM and Q^DIM)
 I %ARG]"" S %=%ARG D ^DIM1 G ER:%ERR
 G GC^DIM
 ;
CL ; CLOSE (C^DIM)
 G ER:%ERR I %ARG]"" F %Z=0:0 D S S %=%A D ^DIM1 G:%ARG=""!%ERR GC^DIM
 G GC^DIM
 ;
IX ; IF and XECUTE (I^DIM and X^DIM)
 G GC^DIM:%ARG=""!%ERR D S S %L=":" D S1 I %C=%L S %=%A1 D ^DIM1 G ER:%A1=""!%ERR
 S %=%A D ^DIM1 G IX
 ;
ST ; SET and MERGE (S^DIM and M^DIM)
 G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=","))
 I %A?1"@".E S %=%A D ^DIM1 G ST
 S %L="=" D S1 G ER:(%A="")!(%A1="") S %=%A1 G ER:%COM="M"&'$$GLVN(%) D ^DIM1 G ER:%ERR
 I %A?1"(".E1")" S %A=$E(%A,2,$L(%A)-1) G ER:%COM="M",STM
 D VV G ST
 ;
STM ; SET (x,y)=... (ST)
 G ST:%ERR!(%A=""),ER:%A?1",".E S %L="," D S1 G ER:%ERR!(%C=%L&(%A1=""))
 D VV S %A=%A1 G STM
 ;
RD ; READ (R^DIM)
 G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%C=","&(%A=""))
 I "!#?"[$E(%A,1) S %I=0 D FRM G RD
 I %A?1"""".E G ER:$P(%A,"""",3)'="" S %=%A D ^DIM1 G RD
 I %A?1"*".E S %A=$E(%A,2,999)
 I $E(%A)="^","^TMP^XTMP^"'[$P(%A,"(") G ER
 F %L=":","#" D  G ER:%ERR
 . D S1 Q:%ERR
 . I %A="" S %ERR=1 Q
 . I %A1="",%C=%L S %ERR=1 Q
 . S %=%A1 D ^DIM1
 D VV G ER:%ERR,RD
 ;
WR ; WRITE (W^DIM)
 G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=","))
 I "!#?/"[$E(%A) S %I=0 D FRM G WR
 S:%A?1"*".E %A=$E(%A,2,999) S %=%A D ^DIM1 G WR
 ;
FRM ; format (RD and WR)
 S %I=%I+1,%C=$E(%A,%I) Q:%C=""  G FRM:"!#"[%C
 S %=$E(%A,%I+1,999) I %]"",%C="?" D ^DIM1 Q
 I %C="/",%COM="W" S:%?1"?".E %="A"_$E(%,2,999) I %?1AN.E D ^DIM1 Q
 S %ERR=1 Q
 ;
S ; split at first comma: end of first argument (*)
 S (%A,%C)="" Q:%ERR  S (%ERR,%I)=0
INC D %INC D QT:%C="""",P:%C="(" Q:%ERR  G OUT:","[%C,INC
QT D %INC Q:%C=""""  G QT:%C]"" S %ERR=1 Q
P S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q
%INC S %I=%I+1,%C=$E(%ARG,%I) Q
 ;
S1 ; split at first instance of %L (*)
 S (%A1,%C)="" Q:%ERR  S (%ERR,%I)=0
INCR D %INC1 D QT1:%C="""",P1:%C="(" Q:%ERR  G OUT1:%L[%C,INCR
OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q
QT1 D %INC1 Q:%C=""""  G QT1:%C]"" S %ERR=1 Q
P1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P  I %C="" S %ERR=1 Q
 Q
%INC1 S %I=%I+1,%C=$E(%A,%I) Q
 ;
VV ; glvn or setleft (ST, STM, and RD)
 S %=%A Q:%ERR
 I %]"",$$GLVN(%)=0 D
 .I %COM'="S" S %ERR=1 Q
 .I %["(",(%?1"$P".E)!(%?1"$E".E) Q
 .I %="$X"!(%="$Y") Q
 .I %="$D"!(%="$DEVICE")!(%="$K")!(%="$KEY")!(%="$EC")!(%="$ECODE")!(%="$ET")!(%="$ETRAP") S %ERR=1 Q  ; SAC
 .S %ERR=1
 D ^DIM1:'%ERR Q
 ;
GLVN(%) ; glvn (not counting subscript syntax)
 I %?.1"^"1U.UN Q 1
 I %?.1"^"1U.UN1"("1.E1")" Q 1
 I %?.1"^"1"%".UN Q 1
 I %?.1"^"1"%".UN1"("1.E1")" Q 1
 I %?1"^("1.E1")" Q 1
 I %?1"^$"1.U1"("1.E1")" Q 1
 I %?1"@"1.E Q 1
 Q 0
 ;
ER G ER^DIM