- DIM2 ;SFISC/XAK,GFT,TOAD-FileMan: M Syntax Checker, Exprs ; Jan 30, 2023@14:38:33
- ;;22.2;VA FileMan;**24**;Jan 05, 2016;Build 3
- ;;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.
- ;
- ;12277;4186487;4104;
- ;
- 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'?1(1U,1"%").UN G ERR
- ;I %C1]"",%[("."_%C1) G ERR ;DID NOT ALLOW "W A(6)-$$X(.A)"
- 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
- N FROM S FROM=+$E(%,%I,999) I %C?1N D INTLIT Q:%ERR
- I %C="." D %INC
- Q:%C'?1N I +$E(%,%I,999)<FROM S %ERR=1 Q
- 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!(%C="") S %ERR=1 Q
- F D %INC Q:%C="" Q:"ACELNPU"'[%C
- Q
- ALTRN8 I %C'="(" S %ERR=1 Q ;alternate patterns (AE) are within a set of parentheses
- D %INC,PATATOM Q:%ERR
- I %C="," F Q:","'[%C D %INC,PATATOM Q:%ERR ;AE elements that are seperated by comma
- F Q:%C=")" D PATATOM Q:%ERR ;AE elements that are not seperated ;p24
- 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?1(1")",1UN) G ERR ;GFT: unary "'" may precede an operator, can't follow a variable name
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIM2 4661 printed Feb 19, 2025@00:15:40 Page 2
- DIM2 ;SFISC/XAK,GFT,TOAD-FileMan: M Syntax Checker, Exprs ; Jan 30, 2023@14:38:33
- +1 ;;22.2;VA FileMan;**24**;Jan 05, 2016;Build 3
- +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 ;12277;4186487;4104;
- +8 ;
- SUB ; "(": open paren situations (GG^DIM1)
- +1 FOR %J=%I-1:-1
- SET %C1=$EXTRACT(%,%J)
- if %C1'?1(1UN,1"%")
- QUIT
- +2 SET %C1=$EXTRACT(%,%J+1,%I-1)
- +3 IF %C1]""
- IF %C1'?1(1U,1"%").UN
- GOTO ERR
- +4 ;I %C1]"",%[("."_%C1) G ERR ;DID NOT ALLOW "W A(6)-$$X(.A)"
- +5 SET %(%N,0)=$SELECT(%C1]""!($EXTRACT(%,%J)="^"):"V^",$EXTRACT(%,%J)="@":"@^",1:"0^")
- +6 SET %(%N,1)=0
- SET %(%N,2)=0
- SET %(%N,3)=0
- SET %N=%N+1
- GOTO 1
- +7 ;
- UP ; ")": close paren situations (GG^DIM1)
- +1 IF %N=0
- GOTO ERR
- +2 IF "(,"[$EXTRACT(%,%I-1)
- IF $PIECE($GET(%(%N-1,0)),"^")'["P"
- GOTO ERR
- +3 IF $EXTRACT(%,%I+1)]""
- IF "<>_[]:/\?'+-=!&#*),"""'[$EXTRACT(%,%I+1)
- GOTO ERR
- +4 SET %N=%N-1
- SET %(%N,1)=%(%N,1)+1
- SET %F=$PIECE(%(%N,0),"^")
- IF %F
- Begin DoDot:1
- +5 SET %F=$PIECE(%(%N,0),"^",2)
- SET %F1=%(%N,1)
- +6 ; not enough commas for this function
- IF %F1<+%F
- SET %ERR=1
- QUIT
- +7 ; too many commas for this function
- IF %F1>$PIECE(%F,";",2)
- SET %ERR=1
- QUIT
- +8 ; we're in $S and haven't yet hit a :
- IF %(%N,2)
- IF '%(%N,3)
- SET %ERR=1
- End DoDot:1
- if %ERR
- GOTO ERR
- +9 KILL %(%N+1)
- +10 IF '%F
- IF %F'["V"
- IF %F'["@"
- IF %F'["P"
- IF %(%N,1)>1
- GOTO ERR
- +11 GOTO 1
- +12 ;
- AR ; ",": comma situations -- "P" below means "parameters" (GG^DIM1)
- +1 IF %N<1
- GOTO ERR
- +2 IF "(,"[$EXTRACT(%,%I-1)
- IF $PIECE($GET(%(%N-1,0)),"^")'["P"
- GOTO ERR
- +3 IF '%(%N-1,3)
- IF %(%N-1,2)
- GOTO ERR
- +4 IF "@("[$EXTRACT(%,1,2)
- GOTO ERR
- +5 SET %(%N-1,1)=%(%N-1,1)+1
- SET %(%N-1,3)=0
- GOTO 1
- +6 ;
- SEL ; ":": $SELECT delimiter (GG^DIM1)
- +1 SET %(%N-1,3)=%(%N-1,3)+1
- if '%(%N-1,2)!(%(%N-1,3)>1)
- GOTO ERR
- GOTO 1
- +2 ;
- GLO ; "^": global reference (GG^DIM1)
- +1 DO %INC
- if $EXTRACT(%,%I,999)'?1U.UN.P.E&("%("'[%C)
- GOTO ERR
- +2 if "=+-\/<>(,#!&*':@[]_"'[$EXTRACT(%,%I-2)
- GOTO ERR
- +3 SET %I=%I-1
- GOTO 1
- +4 ;
- PAT ; "?": pattern match (GG^DIM1)
- +1 if %I=1
- GOTO ERR
- if $EXTRACT(%,%I+1)="@"
- GOTO 1
- DO %INC
- DO PATTERN
- if %ERR
- GOTO ERR
- SET %I=%I-1
- GOTO 1
- +2 ;
- PATTERN FOR
- DO PATATOM
- if %C'?1N&(%C'=".")!%ERR
- QUIT
- +1 QUIT
- PATATOM DO REPCOUNT
- if %ERR
- QUIT
- +1 IF %C=""""
- DO STRLIT
- if '%ERR
- DO %INC
- QUIT
- +2 IF %C="("
- DO ALTRN8
- QUIT
- +3 DO PATCODE
- +4 QUIT
- REPCOUNT ;
- +1 IF %C'?1N
- IF %C'="."
- SET %ERR=1
- QUIT
- +2 NEW FROM
- SET FROM=+$EXTRACT(%,%I,999)
- IF %C?1N
- DO INTLIT
- if %ERR
- QUIT
- +3 IF %C="."
- DO %INC
- +4 if %C'?1N
- QUIT
- IF +$EXTRACT(%,%I,999)<FROM
- SET %ERR=1
- QUIT
- +5 DO INTLIT
- QUIT
- INTLIT IF %C'?1N
- SET %ERR=1
- QUIT
- +1 FOR
- DO %INC
- if %C'?1N
- QUIT
- +2 QUIT
- STRLIT FOR
- DO %INC
- if %C=""
- QUIT
- IF %C=""""
- if $EXTRACT(%,%I+1)'=""""
- QUIT
- SET %I=%I+1
- +1 IF %C=""
- SET %ERR=1
- +2 QUIT
- PATCODE IF "ACELNPU"'[%C!(%C="")
- SET %ERR=1
- QUIT
- +1 FOR
- DO %INC
- if %C=""
- QUIT
- if "ACELNPU"'[%C
- QUIT
- +2 QUIT
- ALTRN8 ;alternate patterns (AE) are within a set of parentheses
- IF %C'="("
- SET %ERR=1
- QUIT
- +1 DO %INC
- DO PATATOM
- if %ERR
- QUIT
- +2 ;AE elements that are seperated by comma
- IF %C=","
- FOR
- if ","'[%C
- QUIT
- DO %INC
- DO PATATOM
- if %ERR
- QUIT
- +3 ;AE elements that are not seperated ;p24
- FOR
- if %C=")"
- QUIT
- DO PATATOM
- if %ERR
- QUIT
- +4 IF %C'=")"
- SET %ERR=1
- QUIT
- +5 DO %INC
- +6 QUIT
- +7 ;
- BINOP ; binary operator (GG^DIM1)
- +1 SET %Z1=""")%'"
- SET %Z2="""($+-^%@'."
- GOTO OPCHK
- +2 ;
- MTHOP ; math or relational operator (GG^DIM1)
- +1 SET %Z1=""")%"
- SET %Z2="""($+-^%@'."
- GOTO OPCHK
- +2 ;
- UNOP ; unary operator (GG^DIM1)
- +1 SET %Z1=""":<>+-'\/()%@#&!*=_][,"
- +2 SET %Z2="""($+-=&!^%.@'"
- IF %C="'"
- SET %Z2=%Z2_"<>?[]"
- +3 GOTO OPCHK
- +4 ;
- IND ; "@": indirection (GG^DIM1)
- +1 IF $EXTRACT(%COM)="F"
- GOTO ERR
- +2 SET %Z1="^?@(%+-=\/#*!&'_<>[]:,."
- SET %Z2="""(+^-'$@%"
- GOTO OPCHK
- +3 ;
- OPCHK ; ensure that the characters before and after the operator are OK
- +1 SET %L1=$EXTRACT(%,%I-1)
- SET %L2=$EXTRACT(%,%I+1)
- IF %L1="'"
- IF "[]&!<>="[%C
- SET %L1=$EXTRACT(%,%I-2)
- +2 ; binary: require before
- IF %L1=""
- IF "+-'@"'[%C
- GOTO ERR
- +3 ; all: screen before
- IF %L1'?1UN
- IF %Z1'[%L1
- GOTO ERR
- +4 FOR %F="*","]"
- IF %C=%F
- IF %L2=%F
- SET %I=%I+1
- SET %L2=$EXTRACT(%,%I+1)
- QUIT
- +5 ; all: require after
- IF %L2=""
- GOTO ERR
- +6 ; all: screen after
- IF %L2'?1UN
- IF %Z2'[%L2
- GOTO ERR
- +7 ;GFT: unary "'" may precede an operator, can't follow a variable name
- IF %C="'"
- IF "!&[]?=<>"'[%L2
- IF %L1?1(1")",1UN)
- GOTO ERR
- +8 GOTO 1
- +9 ;
- 1 ; common exit point for all of ^DIM2
- +1 GOTO GG^DIM1
- +2 ;
- DATA ; glvn arguments of $D,$G,$NA,$O, & $Q functions (FUNC^DIM1)
- +1 DO %INC
- if %C=""
- GOTO ERR
- if %C=")"
- GOTO ERR
- if "^@"[%C
- GOTO DATA
- DO VAR
- +2 if "@(,)"'[%C!%ERR
- GOTO ERR
- GOTO GG1^DIM1
- +3 ;
- VAR ; variables encountered while parsing exprs (DATA, GG^DIM1)
- +1 NEW %START
- SET %START=%I-1
- IF $EXTRACT(%,%START)="^"
- SET %START=%START-1
- +2 IF %C="%"
- DO %INC
- +3 NEW OUT
- SET OUT=0
- FOR %J=%I:1
- SET %C=$EXTRACT(%,%J)
- Begin DoDot:1
- +4 IF ",<>?/\[]+-=_()*&#!':"[%C
- SET OUT=1
- QUIT
- +5 IF %C="@"
- IF $EXTRACT(%,%J+1)="("
- IF $EXTRACT(%,%START)="@"
- SET OUT=1
- QUIT
- +6 IF %C'?1UN
- SET %ERR=1
- +7 IF %C="^"
- IF $DATA(%(%N-1,"F"))
- IF %(%N-1,"F")["TEXT"
- SET %ERR=0
- SET OUT=1
- End DoDot:1
- if OUT
- QUIT
- +8 if %ERR
- QUIT
- +9 IF %C="@"
- SET %I=%J
- QUIT
- +10 SET %F=$EXTRACT(%,%I,%J-1)
- +11 IF %F="^"
- IF $EXTRACT(%,%J)'="("
- SET %ERR=1
- +12 IF %F]""
- IF %F'?1U.UN
- IF $EXTRACT(%,%I-1,%J-1)'?1"%".UN
- SET %ERR=1
- +13 SET %I=%J
- QUIT
- +14 ;
- %INC SET %I=%I+1
- SET %C=$EXTRACT(%,%I)
- +1 QUIT
- +2 ;
- ERR SET %ERR=1
- SET %N=0
- FINISH if %N'=0
- GOTO ERR
- KILL %C,%,%F,%F1,%I,%J,%L1,%L2,%N,%T,%Z1,%Z2,%FN,%FZ
- Q QUIT
