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