DIM4 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/6/97 09:10
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
;12279;3292224;3060;
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIM4 3261 printed Dec 13, 2024@02:49:27 Page 2
DIM4 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/6/97 09:10
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;12279;3292224;3060;
+8 ;
BK ; BREAK and QUIT (B^DIM and Q^DIM)
+1 IF %ARG]""
SET %=%ARG
DO ^DIM1
if %ERR
GOTO ER
+2 GOTO GC^DIM
+3 ;
CL ; CLOSE (C^DIM)
+1 if %ERR
GOTO ER
IF %ARG]""
FOR %Z=0:0
DO S
SET %=%A
DO ^DIM1
if %ARG=""!%ERR
GOTO GC^DIM
+2 GOTO GC^DIM
+3 ;
IX ; IF and XECUTE (I^DIM and X^DIM)
+1 if %ARG=""!%ERR
GOTO GC^DIM
DO S
SET %L=":"
DO S1
IF %C=%L
SET %=%A1
DO ^DIM1
if %A1=""!%ERR
GOTO ER
+2 SET %=%A
DO ^DIM1
GOTO IX
+3 ;
ST ; SET and MERGE (S^DIM and M^DIM)
+1 if %ARG=""!%ERR
GOTO GC^DIM
DO S
if %ERR!(%A=""&(%C=","))
GOTO ER
+2 IF %A?1"@".E
SET %=%A
DO ^DIM1
GOTO ST
+3 SET %L="="
DO S1
if (%A="")!(%A1="")
GOTO ER
SET %=%A1
if %COM="M"&'$$GLVN(%)
GOTO ER
DO ^DIM1
if %ERR
GOTO ER
+4 IF %A?1"(".E1")"
SET %A=$EXTRACT(%A,2,$LENGTH(%A)-1)
if %COM="M"
GOTO ER
GOTO STM
+5 DO VV
GOTO ST
+6 ;
STM ; SET (x,y)=... (ST)
+1 if %ERR!(%A="")
GOTO ST
if %A?1",".E
GOTO ER
SET %L=","
DO S1
if %ERR!(%C=%L&(%A1=""))
GOTO ER
+2 DO VV
SET %A=%A1
GOTO STM
+3 ;
RD ; READ (R^DIM)
+1 if %ARG=""!%ERR
GOTO GC^DIM
DO S
if %ERR!(%C=","&(%A=""))
GOTO ER
+2 IF "!#?"[$EXTRACT(%A,1)
SET %I=0
DO FRM
GOTO RD
+3 IF %A?1"""".E
if $PIECE(%A,"""",3)'=""
GOTO ER
SET %=%A
DO ^DIM1
GOTO RD
+4 IF %A?1"*".E
SET %A=$EXTRACT(%A,2,999)
+5 IF $EXTRACT(%A)="^"
IF "^TMP^XTMP^"'[$PIECE(%A,"(")
GOTO ER
+6 FOR %L=":","#"
Begin DoDot:1
+7 DO S1
if %ERR
QUIT
+8 IF %A=""
SET %ERR=1
QUIT
+9 IF %A1=""
IF %C=%L
SET %ERR=1
QUIT
+10 SET %=%A1
DO ^DIM1
End DoDot:1
if %ERR
GOTO ER
+11 DO VV
if %ERR
GOTO ER
GOTO RD
+12 ;
WR ; WRITE (W^DIM)
+1 if %ARG=""!%ERR
GOTO GC^DIM
DO S
if %ERR!(%A=""&(%C=","))
GOTO ER
+2 IF "!#?/"[$EXTRACT(%A)
SET %I=0
DO FRM
GOTO WR
+3 if %A?1"*".E
SET %A=$EXTRACT(%A,2,999)
SET %=%A
DO ^DIM1
GOTO WR
+4 ;
FRM ; format (RD and WR)
+1 SET %I=%I+1
SET %C=$EXTRACT(%A,%I)
if %C=""
QUIT
if "!#"[%C
GOTO FRM
+2 SET %=$EXTRACT(%A,%I+1,999)
IF %]""
IF %C="?"
DO ^DIM1
QUIT
+3 IF %C="/"
IF %COM="W"
if %?1"?".E
SET %="A"_$EXTRACT(%,2,999)
IF %?1AN.E
DO ^DIM1
QUIT
+4 SET %ERR=1
QUIT
+5 ;
S ; split at first comma: end of first argument (*)
+1 SET (%A,%C)=""
if %ERR
QUIT
SET (%ERR,%I)=0
INC DO %INC
if %C=""""
DO QT
if %C="("
DO P
if %ERR
QUIT
if ","[%C
GOTO OUT
GOTO INC
QT DO %INC
if %C=""""
QUIT
if %C]""
GOTO QT
SET %ERR=1
QUIT
P SET %P=1
FOR %J=0:0
DO %INC
if %C=""""
DO QT
SET %P=%P+$SELECT(%C="(":1,%C=")":-1,1:0)
if '%P
QUIT
IF %C=""
SET %ERR=1
QUIT
+1 QUIT
OUT SET %A=$EXTRACT(%ARG,1,%I-1)
SET %ARG=$EXTRACT(%ARG,%I+1,999)
QUIT
%INC SET %I=%I+1
SET %C=$EXTRACT(%ARG,%I)
QUIT
+1 ;
S1 ; split at first instance of %L (*)
+1 SET (%A1,%C)=""
if %ERR
QUIT
SET (%ERR,%I)=0
INCR DO %INC1
if %C=""""
DO QT1
if %C="("
DO P1
if %ERR
QUIT
if %L[%C
GOTO OUT1
GOTO INCR
OUT1 SET %A1=$EXTRACT(%A,%I+1,999)
SET %A=$EXTRACT(%A,1,%I-1)
QUIT
QT1 DO %INC1
if %C=""""
QUIT
if %C]""
GOTO QT1
SET %ERR=1
QUIT
P1 SET %P=1
FOR %J=0:0
DO %INC1
if %C=""""
DO QT1
SET %P=%P+$SELECT(%C="(":1,%C=")":-1,1:0)
if '%P
QUIT
IF %C=""
SET %ERR=1
QUIT
+1 QUIT
%INC1 SET %I=%I+1
SET %C=$EXTRACT(%A,%I)
QUIT
+1 ;
VV ; glvn or setleft (ST, STM, and RD)
+1 SET %=%A
if %ERR
QUIT
+2 IF %]""
IF $$GLVN(%)=0
Begin DoDot:1
+3 IF %COM'="S"
SET %ERR=1
QUIT
+4 IF %["("
IF (%?1"$P".E)!(%?1"$E".E)
QUIT
+5 IF %="$X"!(%="$Y")
QUIT
+6 ; SAC
IF %="$D"!(%="$DEVICE")!(%="$K")!(%="$KEY")!(%="$EC")!(%="$ECODE")!(%="$ET")!(%="$ETRAP")
SET %ERR=1
QUIT
+7 SET %ERR=1
End DoDot:1
+8 if '%ERR
DO ^DIM1
QUIT
+9 ;
GLVN(%) ; glvn (not counting subscript syntax)
+1 IF %?.1"^"1U.UN
QUIT 1
+2 IF %?.1"^"1U.UN1"("1.E1")"
QUIT 1
+3 IF %?.1"^"1"%".UN
QUIT 1
+4 IF %?.1"^"1"%".UN1"("1.E1")"
QUIT 1
+5 IF %?1"^("1.E1")"
QUIT 1
+6 IF %?1"^$"1.U1"("1.E1")"
QUIT 1
+7 IF %?1"@"1.E
QUIT 1
+8 QUIT 0
+9 ;
ER GOTO ER^DIM
