source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPC.m@ 1141

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

initial load of WorldVistAEHR

File size: 3.3 KB
RevLine 
[613]1OCXOCMPC ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Optimize a Boolean Expression) ;10/29/98 12:37
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
4 ;
5 Q
6 ;
7OPTMIZ(OCXD0,OCXEXP) ;
8 ;
9 Q 0
10 N OCXRES,OCXSTAK,OCXPTR,OCXFLST,OCXTKN,OCXERR,OCXTEXP,OCXDASH,OCXBOOL,OCXPTKN,OCXX
11 ;
12 S OCXEXP=$$PARCNT(OCXEXP) Q:'$L(OCXEXP) OCXWARN Q:OCXWARN OCXWARN
13 ;
14 S OCXEXP=$TR(OCXEXP,"~","")
15 ;
16 S OCXEXP=$$STRIP(OCXEXP)
17 ;
18 I 0 W ! S OCXOP="" F OCXPTR=1:1:$L(OCXEXP," ") D
19 .F Q:'(+$$TOP) Q:'($$TOP=$$TOP(2)) S OCXX=$$POP,OCXX=$$POP D DISP
20 .;
21 .I (+$P(OCXEXP," ",OCXPTR)) D PUSH(+$P(OCXEXP," ",OCXPTR)) D DISP Q
22 .;
23 .I ($P(OCXEXP," ",OCXPTR)="(") D PUSH("(") S OCXOP="" D DISP Q
24 .;
25 .I ($P(OCXEXP," ",OCXPTR)=")") D S OCXOP="" D DISP Q
26 ..N SUB,POP S SUB="" F S POP=$$POP Q:'$L(POP) Q:(POP="(") S:$L(SUB) SUB=" "_SUB S SUB=POP_SUB
27 ..D PUSH($$TOKEN(SUB))
28 .;
29 .I '$L(OCXOP) S OCXOP=$P(OCXEXP," ",OCXPTR) D PUSH(OCXOP) D DISP Q
30 .;
31 .I '(OCXOP=$P(OCXEXP," ",OCXPTR)) D D DISP Q
32 ..N SUB,POP S SUB="" F S POP=$$POP Q:'$L(POP) Q:(POP="(") S:$L(SUB) SUB=" "_SUB S SUB=POP_SUB
33 ..D PUSH("(")
34 ..D PUSH($$TOKEN(SUB))
35 ..S OCXOP=$P(OCXEXP," ",OCXPTR)
36 ..D PUSH(OCXOP)
37 .;
38 .D PUSH($P(OCXEXP," ",OCXPTR)) D DISP Q
39 ;
40 S OCXEXP=$$EXPAND(OCXEXP)
41 ;
42 Q 0_U_$TR(OCXEXP," ","")
43 ;
44DISP ;
45 Q:$G(OCXAUTO)
46 W !,$P(OCXEXP," ",1,OCXPTR),!
47 Q
48TOKEN(VAL) ;
49 ;
50 Q:($L(VAL," ")=1) VAL
51 N ORD,OPER,PTR
52 S OPER=$P(VAL," ",2)
53 F PTR=1:2:$L(VAL," ") S ORD($P(VAL," ",PTR))=""
54 S VAL="",PTR=0 F S PTR=$O(ORD(PTR)) Q:'PTR S:$L(VAL) VAL=VAL_" "_OPER_" " S VAL=VAL_PTR
55 ;
56 S PTR=+$G(^TMP("OCXCMP",$J,"B TOKEN","B",VAL)) Q:PTR PTR
57 ;
58 F PTR=$O(^OCXS(860.3,999999),-1)+1:1 Q:'$D(^TMP("OCXCMP",$J,"B TOKEN",+PTR))
59 S ^TMP("OCXCMP",$J,"B TOKEN",+PTR)=VAL
60 S ^TMP("OCXCMP",$J,"B TOKEN","B",VAL)=+PTR
61 Q +PTR
62 ;
63PUSH(V) S OCXSTAK($O(OCXSTAK(99999),-1)+1)=V Q
64 ;
65POP() N L,V S L=$O(OCXSTAK(99999),-1) Q:'L "" S V=OCXSTAK(L) K OCXSTAK(L) Q V
66 ;
67TOP(C) ;
68 Q:'$D(OCXSTAK) "" Q:'$D(C) OCXSTAK($O(OCXSTAK(999999),-1))
69 N L,X S L=$O(OCXSTAK(99999),-1) Q:'L "" F X=1:1:C S L=$O(OCXSTAK(L),-1) Q:'L
70 Q:'L "" Q OCXSTAK(L)
71 K C
72 ;
73STRIP(EXP) ;
74 ;
75 N QUIT,PTR
76 F S QUIT=1 D Q:QUIT
77 .F PTR=1:1:($L(EXP," ")-2) I ($P(EXP," ",PTR)="("),(+$P(EXP," ",PTR+1)),($P(EXP," ",PTR+2)=")") S QUIT=0 D Q
78 ..I (PTR>1) S EXP=$P(EXP," ",1,PTR-1)_" "_(+$P(EXP," ",PTR+1))_" "_$P(EXP," ",PTR+3,99999) Q
79 ..S EXP=(+$P(EXP," ",PTR+1))_" "_$P(EXP," ",PTR+3,99999)
80 Q EXP
81 ;
82PARCNT(EXP) ;
83 N CNT,PTR,TEMP
84 S CNT=0,TEMP="" F PTR=1:1:$L(EXP) D
85 .N CHAR S CHAR=$E(EXP,PTR)
86 .I (CHAR="(") S CNT=CNT+1,TEMP=TEMP_" ( "
87 .E I (CHAR=")") S CNT=CNT-1,TEMP=TEMP_" ) "
88 .E I '(CHAR=" "),'(CHAR="~"),(CHAR?1P) S TEMP=TEMP_" "_CHAR_" "
89 .E S TEMP=TEMP_CHAR
90 I CNT D Q ""
91 .N MSG
92 .S MSG(1)=" "_EXP,MSG(2)=" "
93 .I (CNT>0) S MSG(3)=" "_(CNT)_" Unmatched LEFT '(' parenthesis in expression"
94 .I (CNT<0) S MSG(3)=" "_(CNT*(-1))_" Unmatched RIGHT ')' parenthesis in expression"
95 .D WARN^OCXOCMPV(.MSG,2,OCXD0,$P($T(+1)," ",1)) Q
96 ;
97 F Q:'(TEMP[" ") S TEMP=$P(TEMP," ",1)_" "_$P(TEMP," ",2,999)
98 F Q:'($E(TEMP,1)=" ") S TEMP=$E(TEMP,2,$L(TEMP))
99 Q TEMP
100 ;
101EXPAND(EXP) ;
102 ;
103 N QUIT,PTR
104 F PTR=1:1:$L(EXP," ") S:+$P(EXP," ",PTR) $P(EXP," ",PTR)="~"_$P(EXP," ",PTR)_"~"
105 F Q:'(EXP["~") S EXP=$P(EXP,"~",1)_$G(^TMP("OCXCMP",$J,"B TOKEN",+$P(EXP,"~",2)))_$P(EXP,"~",3,999)
106 Q EXP
107 ;
Note: See TracBrowser for help on using the repository browser.