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 Apr 09, 2024@21:56:11 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
