source: WorldVistAEHR/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUPEX.m@ 1693

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1RORUPEX ;HCIOFO/SG - SELECTION RULE EXPRESSION PARSER ; 7/21/03 9:47am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 Q
5 ;
6 ;***** GETS THE NEXT CHARACTER FROM THE EXPRESSION
7GETCHAR ;
8 S LOOK=$E(EXPR,EPTR),EPTR=EPTR+1
9 Q
10 ;
11 ;***** TRANSLATES FIELD OR RULE MACRO TO MUMPS CODE
12 ;
13 ; The function returns a string containing MUMPS expression
14 ; that implements the selection rule macro.
15 ;
16GETMACRO() ;
17 ;;AVG,CNT,E,GDF,GDL,I,LS,MAX,MIN,SDF,SDL,SUM
18 ;
19 Q:'$$MATCH("{") ""
20 N BI,BUF,DATELMT,NAME,PFX,PFXLST,RC,RORMSG,SFX,TMP,XCODE
21 S PFXLST=","_$P($T(GETMACRO+1),";;",2)_","
22 S BI=1,RC=0
23 F D Q:RC
24 . I LOOK="}" D GETCHAR S RC=1 Q
25 . I LOOK=":" D GETCHAR S BI=BI+1 Q
26 . I LOOK="{" D Q
27 . . I BI<3 D SNTXERR("GETMACRO^RORUPEX") S RC=1 Q
28 . . S BUF(BI)=$G(BUF(BI))_$$GETMACRO()
29 . S BUF(BI)=$G(BUF(BI))_LOOK
30 . D GETCHAR
31 Q:ERRCODE<0 ""
32 ;--- Get the parts of the macro
33 S BI=1,(NAME,PFX,SFX)=""
34 S TMP=$$UP^XLFSTR($$TRIM^XLFSTR($G(BUF(BI))))
35 S:PFXLST[(","_TMP_",") PFX=TMP,BI=BI+1
36 S NAME=$$TRIM^XLFSTR($G(BUF(BI))),BI=BI+1
37 S SFX=$$TRIM^XLFSTR($G(BUF(BI))),BI=BI+1
38 ;--- Data element value
39 I (PFX="E")!(PFX="I") S XCODE="" D Q XCODE
40 . S DATELMT=$S(+NAME=NAME:+NAME,1:$$DATACODE^RORUPDUT(FILE,NAME))
41 . I DATELMT<0 S ERRCODE=DATELMT Q
42 . S XCODE="$G(RORVALS(""DV"","_FILE_","_DATELMT_","""_PFX_"""))"
43 . S RESULT("F",DATELMT,PFX)=""
44 ;--- Lab Search (replace a name of the Lab Search with the IEN)
45 I PFX="LS" D Q "$$RULE^RORUPD04("_TMP_")"
46 . I FILE'=63 D SNTXERR("GETMACRO^RORUPEX") S TMP="" Q
47 . S TMP="I '$P(^(0),U,2)" ; Only Active
48 . S TMP=+$$FIND1^DIC(798.9,"","X",NAME,"B",TMP,"RORMSG")
49 . S RC=$$DBS^RORERR("RORMSG",-9,,,798.9)
50 . S:RC<0 ERRCODE=RC,TMP=0
51 . S:TMP RESULT("L",TMP)=""
52 ;--- Trigger date macros (set)
53 I PFX="SDF" Q "$$SDF^RORUPDUT("""_NAME_""","_SFX_")"
54 I PFX="SDL" Q "$$SDL^RORUPDUT("""_NAME_""","_SFX_")"
55 ;--- Macros processed after this point cannot reference
56 ; the rule that they are part of the expression of
57 S RESULT("R",NAME)=""
58 ;--- Trigger date macros (get)
59 I (PFX="GDF")!(PFX="GDL") D Q XCODE
60 . S XCODE="$$SRDT^RORUPDUT("""_NAME_""","""_PFX_""","_SFX_")"
61 ;--- Value of the selection rule
62 Q:PFX="" "$G(RORVALS(""SV"","""_NAME_"""))"
63 Q "$G(RORVALS(""SV"","""_NAME_""","""_PFX_"""))"
64 ;
65 ;***** GETS A STRING CONSTANT FROM THE EXPRESSION
66 ;
67 ; The function returns a string argument from the expression.
68 ;
69GETSTR() ;
70 Q:'$$MATCH("""") ""
71 N RC,STR
72 S STR="",RC=0
73 F D Q:RC
74 . I LOOK="""" D Q:RC
75 . . D GETCHAR
76 . . I LOOK'="""" S RC=1 Q
77 . . S STR=STR_""""
78 . S STR=STR_LOOK
79 . D GETCHAR
80 Q STR
81 ;
82 ;***** INITIALIZES PARSING PROCESS
83INIT ;
84 S EPTR=1,ERRCODE=0,RESULT=""
85 D GETCHAR,SKIPWHT
86 Q
87 ;
88 ;***** COMPARES LOOK-AHEAD CHARACTER TO THE ARGUMENT
89MATCH(CH) ;
90 I LOOK=CH D GETCHAR Q 1
91 D SNTXERR("MATCH^RORUPEX")
92 Q 0
93 ;
94 ;***** PARSES THE EXPRESSION
95 ;
96 ; FILE File number
97 ; EXPR Source expression
98 ; .RESULT( Resulting MUMPS code
99 ; "F", List of data elements to load
100 ; DataCode)
101 ; "L",LS#) List of Lab Search IENs
102 ; "R",Rule#) List of rules that this expression depend on
103 ;
104 ; Return values:
105 ; <0 Error code
106 ; 0 Ok
107 ;
108PARSER(FILE,EXPR,RESULT) ;
109 N EPTR ; Current position in the expression
110 N ERRCODE ; Error code
111 N LOOK ; Look-ahead character
112 ;
113 ;--- Check if the file exists and supported
114 Q:'$$VFILE^DILFD(FILE) $$ERROR^RORERR(-58,"PARSER^RORUPEX",,,FILE)
115 Q:'$D(^ROR(799.2,FILE)) $$ERROR^RORERR(-63,"PARSER^RORUPEX",,,FILE)
116 ;--- Parse the expression
117 D INIT
118 F Q:LOOK="" D Q:ERRCODE<0
119 . I LOOK="""" D Q
120 . . S RESULT=RESULT_""""_$$GETSTR()_""""
121 . I LOOK="{" D Q
122 . . S RESULT=RESULT_$$GETMACRO()
123 . S RESULT=RESULT_LOOK
124 . D GETCHAR
125 ;
126 Q $S(ERRCODE<0:ERRCODE,1:0)
127 ;
128 ;***** PROCESSES A SYNTAX ERROR
129SNTXERR(PLACE,MSG) ;
130 N I,INFO S I=0
131 S:$G(MSG)'="" I=I+1,INFO(I)=MSG
132 S I=I+1,INFO(I)="Position: "_EPTR
133 S:LOOK'="" INFO(I)=INFO(I)_", Character: '"_LOOK_"'"
134 S ERRCODE=$$ERROR^RORERR(-21,$G(PLACE),.INFO)
135 Q
136 ;
137 ;***** SKIPS WHITE SPACES IN THE EXPRESSION
138SKIPWHT ;
139 F Q:(" "'[LOOK)!(LOOK="") D GETCHAR
140 Q
Note: See TracBrowser for help on using the repository browser.