- 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 Feb 19, 2025@00:15:39 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