DIM1 ;SFISC/JFW,GFT,TOAD - M Syntax Checker, Exprs ; Dec 13, 2009
;;22.2;VA FileMan;**18**;Jan 05, 2016;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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.15AN,%C1'?1"%".15AN G E
S %C=$P(%C,"^") I %C]"",%C'?1U.15AN,%C'?1"%".15AN,%C'?1.16N G E ;p18
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIM1 3949 printed Apr 09, 2024@21:51:52 Page 2
DIM1 ;SFISC/JFW,GFT,TOAD - M Syntax Checker, Exprs ; Dec 13, 2009
+1 ;;22.2;VA FileMan;**18**;Jan 05, 2016;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 if %ERR
QUIT
NEW %A,%A1
SET (%I,%N,%ERR,%(-1,2),%(-1,3))=0
+8 ;
GG ; expr, expratom, expritem, subscript, parameter (called everywhere)
+1 DO %INC
if %C=""
GOTO FINISH^DIM2
+2 if %C=";"!($ASCII(%C)>95)!($ASCII(%C)<33)
GOTO E
+3 if %C=""""
GOTO QUOTE
if %C="$"
GOTO FUNC
if %C="("
GOTO SUB^DIM2
if %C=")"
GOTO UP^DIM2
+4 if %C=","
GOTO AR^DIM2
if %C=":"
GOTO SEL^DIM2
if %C="^"
GOTO GLO^DIM2
EXP IF %C="E"
IF $EXTRACT(%,%I-1)?1N
Begin DoDot:1
+1 SET %L1=$EXTRACT(%,%I+1)
+2 IF %L1'?1(1N,1"+",1"-")
SET %ERR=1
QUIT
+3 NEW %OUT
SET %OUT=0
FOR %I=%I+2:1
Begin DoDot:2
+4 SET %C=$EXTRACT(%,%I)
+5 IF "<>=!&'[]+-*/\#_?,:)"[%C
SET %OUT=1
QUIT
+6 IF %C'?1N
SET %ERR=1
QUIT
End DoDot:2
if %ERR!%OUT
QUIT
End DoDot:1
if %ERR
GOTO E
SET %I=%I-1
GOTO GG
+7 IF %C?1(1U,1"%")
DO VAR^DIM2
+8 if %ERR
GOTO E
if %C=""
GOTO GG
+9 if %C="?"
GOTO PAT^DIM2
if "=[]<>&!"[%C
GOTO BINOP^DIM2
if "/\*#_"[%C
GOTO MTHOP^DIM2
+10 if "'+-"[%C
GOTO UNOP^DIM2
if %C="@"
GOTO IND^DIM2
PERIOD IF %C="."
Begin DoDot:1
+1 IF $PIECE($GET(%(%N-1,0)),"^")="P"
Begin DoDot:2
+2 ; decimal pass by value
NEW %C
SET %C=$EXTRACT(%,%I+1)
IF %C?1N
QUIT
+3 ; bad pass by reference
IF %C'="@"
IF %C'?1U
IF %C'="%"
SET %ERR=1
End DoDot:2
QUIT
+4 DO %INC
NEW %L1,%P
SET %L1=$EXTRACT(%,%I-2)
SET %P="':=+-\/<>[](,*&!_#"
+5 ; 4.2
IF %L1?1N
IF %C?1N
QUIT
+6 ; +.2
IF %P[%L1
IF %C?1N
QUIT
+7 ; illegal period
SET %ERR=1
End DoDot:1
if %ERR
GOTO E
+8 IF %C?1N
IF $EXTRACT(%,%I+1)]""
if $EXTRACT(%,%I+1)'?1(1NP,1"E")
GOTO E
GG1 ;
+1 IF %C]""
IF "$(),:"""[%C
SET %I=%I-1
+2 GOTO GG
+3 ;
QUOTE ; strlit (GG)
+1 FOR %J=0:0
DO %INC
if %C=""!(%C="""")
QUIT
+2 if %C=""!("[]()><\/+-=&!_#*,;:'"""'[$EXTRACT(%,%I+1))
GOTO E
if $DATA(%(%N-1,"F"))
if %(%N-1,"F")["FN"
DO FN
if %ERR
GOTO E
GOTO GG
+3 ;
FUNC ; intrinsics & extrinsics, mainly intrinsic functions (GG)
+1 DO %INC
if %C="$"
GOTO EXT
if %C'?1U
GOTO E
if $EXTRACT(%,%I,999)'?.U1"(".E
GOTO SPV
if %C="Z"!($EXTRACT(%,%I+1)="(")
GOTO FUNC1
+2 SET %T=$EXTRACT(%,%I,$FIND(%,"(",%I)-2)
+3 ; SAC
IF %T="ST"!(%T="STACK")
GOTO E
+4 FOR %F1="FNUMBER^2;3","TRANSLATE^2;3","NAME^1;2","QLENGTH^1;1","QSUBSCRIPT^2;2","REVERSE^1;1"
if $EXTRACT(%F1,1,2)=%T
GOTO FUNC2
if $PIECE(%F1,"^")=%T
GOTO FUNC2
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
+1 if $TEXT(FNC)'[(","_%T_"^")
GOTO E
FUNC1 SET %F1=$PIECE($TEXT(FNC),",",$FIND("ACDEFGJLOPQRSTVZ",%C))
if %F1=""
GOTO E
FUNC2 SET %I=$FIND(%,"(",%I)-1
SET %(%N,0)="1^"_$PIECE(%F1,"^",2)
SET %(%N,1)=0
SET %(%N,2)=0
SET %(%N,3)=0
SET %(%N,"F")=%F1
SET %N=%N+1
if $EXTRACT(%F1)="S"
SET %(%N-1,2)=1
+1 IF ",DATA,NAME,ORDER,QUERY,GET,"[(","_$PIECE(%F1,"^")_",")
GOTO DATA^DIM2
+2 IF $EXTRACT(%F1)="T"
IF $EXTRACT(%F1,2)'="R"
Begin DoDot:1
+3 SET %A=%I
SET %I=$FIND(%,")",%A)-1
SET %N=%N-1
SET %A=$PIECE($EXTRACT(%,%A,%I-1),"(",2,99)
+4 IF %A?1"+"1N.E
SET %A=$EXTRACT(%A,2,999)
+5 NEW %,%I,%N
SET %=%A
DO LABEL^DIM3(1)
End DoDot:1
IF %ERR
GOTO ERR^DIM2
+6 GOTO GG
+7 ;
SPV ; intrinsic special variables (FUNC)
+1 IF $EXTRACT(%,%I+1)?1U
SET %I=%I+1
SET %C=%C_$EXTRACT(%,%I)
GOTO SPV
+2 ; SAC
IF ",D,EC,ES,ET,K,P,Q,ST,SY,TL,TR,"[(","_%C_",")
GOTO E
+3 IF "HIJSTXYZ"[%C&(%C?1U)!(%C?1"Z".U)
GOTO GG
+4 IF "[],)><=_&#!'+-*\/?"'[$EXTRACT(%,%I+1)
GOTO E
+5 ; SAC
IF ",DEVICE,ECODE,ESTACK,ETRAP,KEY,PRINCIPAL,QUIT,STACK,SYSTEM,TLEVEL,TRESTART,"[(","_%C_",")
GOTO E
+6 IF ",HOROLOG,IO,JOB,STORAGE,TEST,"[(","_%C_",")
GOTO GG
E GOTO ERR^DIM2
+1 ;
%INC SET %I=%I+1
SET %C=$EXTRACT(%,%I)
QUIT
+1 ;
FN ; literal string argument 2 of $FNUMBER (QUOTE)
+1 if %(%N-1,1)'=1
QUIT
FOR %FZ=%I-1:-1
SET %FN=$EXTRACT(%,%FZ)
if %FN=""""
QUIT
+2 SET %FN=$TRANSLATE($EXTRACT(%,%FZ+1,%I-1),"pt","PT")
+3 FOR %FZ=1:1
if $EXTRACT(%FN,%FZ)=""
QUIT
IF "+-,TP"'[$EXTRACT(%FN,%FZ)
SET %ERR=1
QUIT
+4 if %ERR
QUIT
IF %FN["P"
FOR %FZ=1:1
if $EXTRACT(%FN,%FZ)=""
QUIT
IF "+-T"[$EXTRACT(%FN,%FZ)
SET %ERR=1
QUIT
+5 QUIT
+6 ;
EXT ; extrinsic functions and variables (FUNC)
+1 DO %INC
+2 FOR %I=%I+1:1
SET %C1=$EXTRACT(%,%I)
if %C1?1PC&("^%"'[%C1)!(%C1="")
QUIT
SET %C=%C_%C1
+3 if %C=""
GOTO E
if %C?.E1"^"
GOTO E
if %C["^^"
GOTO E
+4 SET %C1=$PIECE(%C,"^",2)
IF %C1]""
IF %C1'?1U.15AN
IF %C1'?1"%".15AN
GOTO E
+5 ;p18
SET %C=$PIECE(%C,"^")
IF %C]""
IF %C'?1U.15AN
IF %C'?1"%".15AN
IF %C'?1.16N
GOTO E
+6 IF $EXTRACT(%,%I)="("
IF $EXTRACT(%,%I+1)'=")"
SET %(%N,0)="P^"
SET (%(%N,1),%(%N,2),%(%N,3))=0
SET %N=%N+1
GOTO GG
+7 SET %I=%I+$SELECT($EXTRACT(%,%I,%I+1)="()":1,1:-1)
+8 if "[],)><=_&#!'+-*/\?:"[$EXTRACT(%,%I+1)
GOTO GG
GOTO E
