- DIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;25MAR2010
- ;;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.
- ;
- ;
- DG ; DO and GET (D^DIM and G^DIM)
- G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR
- S %L=":" D PARS1 G ER:%ERR I %C=%L G ER:%A1="" S %=%A1 D ^DIM1
- I %A["@^" S %=%A D ^DIM1 G DG
- I %A["(",$E(%A)'="@",$E($P(%A,"^",2))'="@" D G ER:%ERR
- . I %COM'="D" S %ERR=1 Q
- . S %=%A
- . I %'?.E1"(".E1")" S %ERR=1 Q
- . S %C=$P(%,"("),%C1=$P(%C,"^",2,999),%I=$F(%,"(")-1
- . I %C=""!(%C?.E1"^") S %ERR=1 Q
- . I %C1]"",%C1'?1U.15AN,%C1'?1"%".15AN S %ERR=1 Q
- . S %C=$P(%C,"^") I %C]"",%C'?1U.15AN,%C'?1"%".15AN,%C'?1.15N S %ERR=1 Q
- . Q:$E(%,%I,%I+1)="()"
- . S (%(-1,2),%(-1,3))=0,%N=1,%(0,0)="P^",(%(0,1),%(0,2),%(0,3))=0
- . D GG^DIM1
- E D LABEL(0)
- G DG
- ;
- LABEL(OFFSET) ; labelref, entryref, and $TEXT argument (DG and TEXT^DIM1)
- S %L="^" D PARS1 Q:%ERR
- I %C=%L S:%A1=""!($E(%A1)="^") %ERR=1 S %=%A1 D VV,^DIM1 Q:%ERR
- S %=%A D VV:%'=+%&'OFFSET,^DIM1 Q
- ;
- KL ; KILL, LOCK, and NEW (K^DIM and LK)
- D PARS G ER:%ERR
- I %A="",%C="," G ER
- I %A?1"^"1UP.UN,%COM'="L" G ER
- I %A?1"(".E1")" D G KL
- . S %ARG("E")=$L(%ARG)
- . S %A=$E(%A,2,$L(%A)-1) S %ARG=%A_$S(%ARG]"":","_%ARG,1:"")
- S %=%A I %COM="L","+-"[$E(%A) S $E(%A)=""
- I %COM="N",'$$LNAME(%) G ER
- I %COM="K",$D(%ARG("E")),'$$LNAME(%) G ER
- I $D(%ARG("E")),$L(%ARG)'>%ARG("E") K %ARG("E")
- D VV,^DIM1 G GC^DIM:%ARG=""!%ERR
- G KL
- ;
- LK ; LOCK (L^DIM)
- S %A=%ARG,%L=":" S:"+-"[$E(%A) %A=$E(%A,2,999) D PARS1
- I %C=%L G ER:%A1="" S %=%A1 D ^DIM1
- S %ARG=%A G GC^DIM:%A="",KL
- ;
- HN ; HANG (H^DIM)
- S %=%ARG D ^DIM1 G GC^DIM
- ;
- OP ; OPEN and USE (O^DIM and U^DIM)
- G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR!(%C=","&(%A=""))
- G US:%COM="U" S %L=":" D PARS1 S %A2=%A,%A=%A1 S:%C=%L&(%A="") %ERR=1 D PARS1 G ER:%ERR!(%C=%L&(%A1=""))
- F %L="%A1","%A2" S %=@%L D ^DIM1 G OP:%ERR
- G OP
- US S %L=":" D PARS1 G ER:%C=%L&(%A1="") S %=%A D ^DIM1
- S %A=%A1 D PARS1 G ER:%C]"",OP
- ;
- FR ; FOR (F^DIM)
- S %L="=",%A=%ARG D PARS1 G ER:%ERR!(%A1="")!(%A="") S %ARG=%A1
- S %=%A G ER:%A?1"^".E D VV,^DIM1 G ER:%ERR
- FR1 G GC^DIM:%ARG=""!%ERR D PARS
- S %L=":" F %A=%A,%A1 D PARS1 G ER:%ERR!(%A=""&(%C=%L)) S %=%A D ^DIM1
- I %A1]"" S %=%A1 D ^DIM1
- G FR1
- ;
- PARS S (%A,%C)="" Q:%ERR S (%ERR,%I)=0
- INC D %INC D QT:%C="""",PARAN:%C="(" Q:%ERR G OUT:","[%C,INC
- QT D %INC Q:%C="""" G QT:%C]"" S %ERR=1 Q
- PARAN 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
- ;
- PARS1 S (%A1,%C)="" Q:%ERR S (%ERR,%I)=0
- INCR D %INC1 D QT1:%C="""",PARAN1:%C="(" Q:%ERR=1 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
- PARAN1 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 ; variable, label, or routine name (LABEL, KL, and FR)
- I '%ERR,%]"",%'["@",%'?1U.15UN,%'?1U.15UN1"(".E1")",%'?1"%".15UN1"(".E1")",%'?1"%".15UN,%'?1"^"1U.15UN1"(".E1")",%'?1"^%".15UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.15UN S %ERR=1
- S:%["?@" %ERR=1 Q
- ;
- LNAME(%) ; lname (KL)
- I %?1(1A,1"%").7UN Q 1
- I %?1"@".E Q 1
- Q 0
- ;
- ER G ER^DIM
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIM3 3556 printed Feb 19, 2025@00:15:41 Page 2
- DIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;25MAR2010
- +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 ;
- DG ; DO and GET (D^DIM and G^DIM)
- +1 if %ARG=""!%ERR
- GOTO GC^DIM
- DO PARS
- if %ERR
- GOTO ER
- +2 SET %L=":"
- DO PARS1
- if %ERR
- GOTO ER
- IF %C=%L
- if %A1=""
- GOTO ER
- SET %=%A1
- DO ^DIM1
- +3 IF %A["@^"
- SET %=%A
- DO ^DIM1
- GOTO DG
- +4 IF %A["("
- IF $EXTRACT(%A)'="@"
- IF $EXTRACT($PIECE(%A,"^",2))'="@"
- Begin DoDot:1
- +5 IF %COM'="D"
- SET %ERR=1
- QUIT
- +6 SET %=%A
- +7 IF %'?.E1"(".E1")"
- SET %ERR=1
- QUIT
- +8 SET %C=$PIECE(%,"(")
- SET %C1=$PIECE(%C,"^",2,999)
- SET %I=$FIND(%,"(")-1
- +9 IF %C=""!(%C?.E1"^")
- SET %ERR=1
- QUIT
- +10 IF %C1]""
- IF %C1'?1U.15AN
- IF %C1'?1"%".15AN
- SET %ERR=1
- QUIT
- +11 SET %C=$PIECE(%C,"^")
- IF %C]""
- IF %C'?1U.15AN
- IF %C'?1"%".15AN
- IF %C'?1.15N
- SET %ERR=1
- QUIT
- +12 if $EXTRACT(%,%I,%I+1)="()"
- QUIT
- +13 SET (%(-1,2),%(-1,3))=0
- SET %N=1
- SET %(0,0)="P^"
- SET (%(0,1),%(0,2),%(0,3))=0
- +14 DO GG^DIM1
- End DoDot:1
- if %ERR
- GOTO ER
- +15 IF '$TEST
- DO LABEL(0)
- +16 GOTO DG
- +17 ;
- LABEL(OFFSET) ; labelref, entryref, and $TEXT argument (DG and TEXT^DIM1)
- +1 SET %L="^"
- DO PARS1
- if %ERR
- QUIT
- +2 IF %C=%L
- if %A1=""!($EXTRACT(%A1)="^")
- SET %ERR=1
- SET %=%A1
- DO VV
- DO ^DIM1
- if %ERR
- QUIT
- +3 SET %=%A
- if %'=+%&'OFFSET
- DO VV
- DO ^DIM1
- QUIT
- +4 ;
- KL ; KILL, LOCK, and NEW (K^DIM and LK)
- +1 DO PARS
- if %ERR
- GOTO ER
- +2 IF %A=""
- IF %C=","
- GOTO ER
- +3 IF %A?1"^"1UP.UN
- IF %COM'="L"
- GOTO ER
- +4 IF %A?1"(".E1")"
- Begin DoDot:1
- +5 SET %ARG("E")=$LENGTH(%ARG)
- +6 SET %A=$EXTRACT(%A,2,$LENGTH(%A)-1)
- SET %ARG=%A_$SELECT(%ARG]"":","_%ARG,1:"")
- End DoDot:1
- GOTO KL
- +7 SET %=%A
- IF %COM="L"
- IF "+-"[$EXTRACT(%A)
- SET $EXTRACT(%A)=""
- +8 IF %COM="N"
- IF '$$LNAME(%)
- GOTO ER
- +9 IF %COM="K"
- IF $DATA(%ARG("E"))
- IF '$$LNAME(%)
- GOTO ER
- +10 IF $DATA(%ARG("E"))
- IF $LENGTH(%ARG)'>%ARG("E")
- KILL %ARG("E")
- +11 DO VV
- DO ^DIM1
- if %ARG=""!%ERR
- GOTO GC^DIM
- +12 GOTO KL
- +13 ;
- LK ; LOCK (L^DIM)
- +1 SET %A=%ARG
- SET %L=":"
- if "+-"[$EXTRACT(%A)
- SET %A=$EXTRACT(%A,2,999)
- DO PARS1
- +2 IF %C=%L
- if %A1=""
- GOTO ER
- SET %=%A1
- DO ^DIM1
- +3 SET %ARG=%A
- if %A=""
- GOTO GC^DIM
- GOTO KL
- +4 ;
- HN ; HANG (H^DIM)
- +1 SET %=%ARG
- DO ^DIM1
- GOTO GC^DIM
- +2 ;
- OP ; OPEN and USE (O^DIM and U^DIM)
- +1 if %ARG=""!%ERR
- GOTO GC^DIM
- DO PARS
- if %ERR!(%C=","&(%A=""))
- GOTO ER
- +2 if %COM="U"
- GOTO US
- SET %L=":"
- DO PARS1
- SET %A2=%A
- SET %A=%A1
- if %C=%L&(%A="")
- SET %ERR=1
- DO PARS1
- if %ERR!(%C=%L&(%A1=""))
- GOTO ER
- +3 FOR %L="%A1","%A2"
- SET %=@%L
- DO ^DIM1
- if %ERR
- GOTO OP
- +4 GOTO OP
- US SET %L=":"
- DO PARS1
- if %C=%L&(%A1="")
- GOTO ER
- SET %=%A
- DO ^DIM1
- +1 SET %A=%A1
- DO PARS1
- if %C]""
- GOTO ER
- GOTO OP
- +2 ;
- FR ; FOR (F^DIM)
- +1 SET %L="="
- SET %A=%ARG
- DO PARS1
- if %ERR!(%A1="")!(%A="")
- GOTO ER
- SET %ARG=%A1
- +2 SET %=%A
- if %A?1"^".E
- GOTO ER
- DO VV
- DO ^DIM1
- if %ERR
- GOTO ER
- FR1 if %ARG=""!%ERR
- GOTO GC^DIM
- DO PARS
- +1 SET %L=":"
- FOR %A=%A,%A1
- DO PARS1
- if %ERR!(%A=""&(%C=%L))
- GOTO ER
- SET %=%A
- DO ^DIM1
- +2 IF %A1]""
- SET %=%A1
- DO ^DIM1
- +3 GOTO FR1
- +4 ;
- PARS SET (%A,%C)=""
- if %ERR
- QUIT
- SET (%ERR,%I)=0
- INC DO %INC
- if %C=""""
- DO QT
- if %C="("
- DO PARAN
- if %ERR
- QUIT
- if ","[%C
- GOTO OUT
- GOTO INC
- QT DO %INC
- if %C=""""
- QUIT
- if %C]""
- GOTO QT
- SET %ERR=1
- QUIT
- PARAN 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 ;
- PARS1 SET (%A1,%C)=""
- if %ERR
- QUIT
- SET (%ERR,%I)=0
- INCR DO %INC1
- if %C=""""
- DO QT1
- if %C="("
- DO PARAN1
- if %ERR=1
- 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
- PARAN1 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 ; variable, label, or routine name (LABEL, KL, and FR)
- +1 IF '%ERR
- IF %]""
- IF %'["@"
- IF %'?1U.15UN
- IF %'?1U.15UN1"(".E1")"
- IF %'?1"%".15UN1"(".E1")"
- IF %'?1"%".15UN
- IF %'?1"^"1U.15UN1"(".E1")"
- IF %'?1"^%".15UN1"(".E1")"
- IF %'?1"^(".E1")"
- IF %'?1"^"1U.15UN
- SET %ERR=1
- +2 if %["?@"
- SET %ERR=1
- QUIT
- +3 ;
- LNAME(%) ; lname (KL)
- +1 IF %?1(1A,1"%").7UN
- QUIT 1
- +2 IF %?1"@".E
- QUIT 1
- +3 QUIT 0
- +4 ;
- ER GOTO ER^DIM