source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIM1.m@ 757

Last change on this file since 757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1DIM1 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;1:55 PM 19 Jul 1999
2 ;;22.0;VA FileMan;**6**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;12276;6135531;3766;
5 ;
6 Q:%ERR N %A,%A1 S (%I,%N,%ERR,%(-1,2),%(-1,3))=0
7 ;
8GG ; expr, expratom, expritem, subscript, parameter (called everywhere)
9 D %INC G:%C="" FINISH^DIM2
10 G E:%C=";"!($A(%C)>95)!($A(%C)<33)
11 G QUOTE:%C="""",FUNC:%C="$",SUB^DIM2:%C="(",UP^DIM2:%C=")"
12 G AR^DIM2:%C=",",SEL^DIM2:%C=":",GLO^DIM2:%C="^"
13EXP I %C="E",$E(%,%I-1)?1N D G E:%ERR S %I=%I-1 G GG
14 . S %L1=$E(%,%I+1)
15 . I %L1'?1(1N,1"+",1"-") S %ERR=1 Q
16 . N %OUT S %OUT=0 F %I=%I+2:1 D Q:%ERR!%OUT
17 . . S %C=$E(%,%I)
18 . . I "<>=!&'[]+-*/\#_?,:)"[%C S %OUT=1 Q
19 . . I %C'?1N S %ERR=1 Q
20 I %C?1(1U,1"%") D VAR^DIM2
21 G E:%ERR,GG:%C=""
22 G PAT^DIM2:%C="?",BINOP^DIM2:"=[]<>&!"[%C,MTHOP^DIM2:"/\*#_"[%C
23 G UNOP^DIM2:"'+-"[%C,IND^DIM2:%C="@"
24PERIOD I %C="." D G E:%ERR
25 . I $P($G(%(%N-1,0)),"^")="P" D Q
26 . . N %C S %C=$E(%,%I+1) I %C?1N Q ; decimal pass by value
27 . . I %C'="@",%C'?1U,%C'="%" S %ERR=1 ; bad pass by reference
28 . D %INC N %L1,%P S %L1=$E(%,%I-2),%P="':=+-\/<>[](,*&!_#"
29 . I %L1?1N,%C?1N Q ; 4.2
30 . I %P[%L1,%C?1N Q ; +.2
31 . S %ERR=1 ; illegal period
32 I %C?1N,$E(%,%I+1)]"" G E:$E(%,%I+1)'?1(1NP,1"E")
33GG1 ;
34 I %C]"","$(),:"""[%C S %I=%I-1
35 G GG
36 ;
37QUOTE ; strlit (GG)
38 F %J=0:0 D %INC Q:%C=""!(%C="""")
39 G E:%C=""!("[]()><\/+-=&!_#*,;:'"""'[$E(%,%I+1)) D:$D(%(%N-1,"F")) FN:%(%N-1,"F")["FN" G E:%ERR,GG
40 ;
41FUNC ; intrinsics & extrinsics, mainly intrinsic functions (GG)
42 D %INC G EXT:%C="$",E:%C'?1U,SPV:$E(%,%I,999)'?.U1"(".E,FUNC1:%C="Z"!($E(%,%I+1)="(")
43 S %T=$E(%,%I,$F(%,"(",%I)-2)
44 I %T="ST"!(%T="STACK") G E ; SAC
45 F %F1="FNUMBER^2;3","TRANSLATE^2;3","NAME^1;2","QLENGTH^1;1","QSUBSCRIPT^2;2","REVERSE^1;1" G FUNC2:$E(%F1,1,2)=%T,FUNC2:$P(%F1,"^")=%T
46FNC ;;,ASCII^1;2,CHAR^1;999,DATA^1;1,EXTRACT^1;3,FIND^2;3,GET^1;2,JUSTIFY^2;3,LENGTH^1;2,ORDER^1;2,PIECE^2;4,QUERY^1;1,RANDOM^1;1,SELECT^1;999,TEXT^1;1,VIEW^1;999,ZFUNC^1;999
47 G E:$T(FNC)'[(","_%T_"^")
48FUNC1 S %F1=$P($T(FNC),",",$F("ACDEFGJLOPQRSTVZ",%C)) G E:%F1=""
49FUNC2 S %I=$F(%,"(",%I)-1,%(%N,0)="1^"_$P(%F1,"^",2),%(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%(%N,"F")=%F1,%N=%N+1 S:$E(%F1)="S" %(%N-1,2)=1
50 I ",DATA,NAME,ORDER,QUERY,GET,"[(","_$P(%F1,"^")_",") G DATA^DIM2
51 I $E(%F1)="T",$E(%F1,2)'="R" D I %ERR G ERR^DIM2
52 . S %A=%I,%I=$F(%,")",%A)-1,%N=%N-1,%A=$P($E(%,%A,%I-1),"(",2,99)
53 . I %A?1"+"1N.E S %A=$E(%A,2,999)
54 . N %,%I,%N S %=%A D LABEL^DIM3(1)
55 G GG
56 ;
57SPV ; intrinsic special variables (FUNC)
58 I $E(%,%I+1)?1U S %I=%I+1,%C=%C_$E(%,%I) G SPV
59 I ",D,EC,ES,ET,K,P,Q,ST,SY,TL,TR,"[(","_%C_",") G E ; SAC
60 I "HIJSTXYZ"[%C&(%C?1U)!(%C?1"Z".U) G GG
61 I "[],)><=_&#!'+-*\/?"'[$E(%,%I+1) G E
62 I ",DEVICE,ECODE,ESTACK,ETRAP,KEY,PRINCIPAL,QUIT,STACK,SYSTEM,TLEVEL,TRESTART,"[(","_%C_",") G E ; SAC
63 I ",HOROLOG,IO,JOB,STORAGE,TEST,"[(","_%C_",") G GG
64E G ERR^DIM2
65 ;
66%INC S %I=%I+1,%C=$E(%,%I) Q
67 ;
68FN ; literal string argument 2 of $FNUMBER (QUOTE)
69 Q:%(%N-1,1)'=1 F %FZ=%I-1:-1 S %FN=$E(%,%FZ) Q:%FN=""""
70 S %FN=$TR($E(%,%FZ+1,%I-1),"pt","PT")
71 F %FZ=1:1 Q:$E(%FN,%FZ)="" I "+-,TP"'[$E(%FN,%FZ) S %ERR=1 Q
72 Q:%ERR I %FN["P" F %FZ=1:1 Q:$E(%FN,%FZ)="" I "+-T"[$E(%FN,%FZ) S %ERR=1 Q
73 Q
74 ;
75EXT ; extrinsic functions and variables (FUNC)
76 D %INC
77 F %I=%I+1:1 S %C1=$E(%,%I) Q:%C1?1PC&("^%"'[%C1)!(%C1="") S %C=%C_%C1
78 G:%C="" E G:%C?.E1"^" E G:%C["^^" E
79 S %C1=$P(%C,"^",2) I %C1]"",%C1'?1U.7AN,%C1'?1"%".7AN G E
80 S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N G E
81 I $E(%,%I)="(",$E(%,%I+1)'=")" S %(%N,0)="P^",(%(%N,1),%(%N,2),%(%N,3))=0,%N=%N+1 G GG
82 S %I=%I+$S($E(%,%I,%I+1)="()":1,1:-1)
83 G GG:"[],)><=_&#!'+-*/\?:"[$E(%,%I+1),E
Note: See TracBrowser for help on using the repository browser.