DIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/6/97 09:10
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;12278;4265731;3363;
;
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.7AN,%C1'?1"%".7AN S %ERR=1 Q
. S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N 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.UN,%'?1U.UN1"(".E1")",%'?1"%".UN1"(".E1")",%'?1"%".UN,%'?1"^"1U.UN1"(".E1")",%'?1"^%".UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.UN 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
DIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/6/97 09:10
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;12278;4265731;3363;
+4 ;
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.7AN
IF %C1'?1"%".7AN
SET %ERR=1
QUIT
+11 SET %C=$PIECE(%C,"^")
IF %C]""
IF %C'?1U.7AN
IF %C'?1"%".7AN
IF %C'?1.8N
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.UN
IF %'?1U.UN1"(".E1")"
IF %'?1"%".UN1"(".E1")"
IF %'?1"%".UN
IF %'?1"^"1U.UN1"(".E1")"
IF %'?1"^%".UN1"(".E1")"
IF %'?1"^(".E1")"
IF %'?1"^"1U.UN
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
