OCXOCMPB ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Parse a Rule Relation Expression) ;10/29/98 12:37
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
Q
;
PARSE(OCXD0,OCXD1,OCXEXP,OCXCD) ;
;
Q:$G(OCXWARN) 1
N OCXRES,OCXSTAK,OCXPTR,OCXTKN,OCXERR,OCXTEXP,OCXDASH
N OCXBOOL,OCXPTKN,OCXX,OCXD2,OCXD3,OCXTPTR2
K ^TMP("OCXCMP",$J,"CODE")
M ^TMP("OCXCMP",$J,"CODE")=OCXCD
;
S:($P(OCXEXP," ",1)="IF") OCXEXP=$P(OCXEXP," ",2,999)
S OCXEXP=$$PARCNT^OCXOCMPF(OCXEXP) Q:'$L(OCXEXP) OCXWARN Q:OCXWARN OCXWARN
;
F OCXTPTR=1:1:($L(OCXEXP," ")+1) S OCXTXT=$P(OCXEXP," ",OCXTPTR) I $L(OCXTXT) D Q:OCXWARN
.N OCXSTOP
.;
.; TOKENIZE TERM
.;
.S OCXPTKN=+$$TOP
.S OCXTKN=$S($L($G(^TMP("OCXCMP",$J,"CODE","B",OCXTXT))):1,(OCXTXT="AND"):3,(OCXTXT="OR"):4,(OCXTXT="("):5,(OCXTXT=")"):6,1:0)
.I 'OCXTKN F OCXTPTR2=OCXTPTR:1:($L(OCXEXP," ")+1) I $L($G(^TMP("OCXCMP",$J,"CODE","B",$P(OCXEXP," ",OCXTPTR,OCXTPTR2)))) S OCXTKN=1,OCXTXT=$P(OCXEXP," ",OCXTPTR,OCXTPTR2),OCXTPTR=OCXTPTR2 Q
.I (OCXTKN=1) S:(OCXPTKN=3) OCXTKN=2 S:(OCXPTKN=4) OCXTKN=2 S OCXTXT=$G(^TMP("OCXCMP",$J,"CODE","B",OCXTXT))
.I +OCXTXT,+$G(OCXCD(+OCXTXT)) S ^TMP("OCXCMP",$J,"RULE",OCXD0,OCXD1,+OCXCD(+OCXTXT))=+OCXTXT
.;
.; CHECK FOR SYNTAX ERROR
.;
.I 'OCXTKN D SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXTXT,OCXTKN) S OCXWARN=1 Q
.I ("50"[+OCXPTKN),'("15"[(+OCXTKN)) D SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXPTKN,OCXTKN) S OCXWARN=1 Q
.I ("126"[+OCXPTKN),'("346"[(+OCXTKN)) D SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXPTKN,OCXTKN) S OCXWARN=1 Q
.I ("34"[+OCXPTKN),'("25"[(+OCXTKN)) D SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXPTKN,OCXTKN) S OCXWARN=1 Q
.;
.Q:OCXWARN
.;
.; PUT TERM ON THE STACK
.;
.I (OCXTKN<3) D
..N OCXTMP M OCXTMP=^TMP("OCXCMP",$J,"CODE",+OCXTXT) D PUSH(OCXTKN_U_OCXTXT,.OCXTMP)
.I (OCXTKN>2) D PUSH(OCXTKN_U_OCXTXT)
.;
.; PROCESS THE STACK
.;
.F D Q:OCXSTOP
..N OCXTOP S OCXSTOP=1,OCXTOP=+$$TOP
..;
..I (OCXTOP=1),(+$$TOP(1)=3) S OCXTOP=2
..I (OCXTOP=1),(+$$TOP(1)=4) S OCXTOP=2
..;
..I (OCXTOP=2) D S OCXSTOP=0 Q ; SECOND DATA FIELD
...N FLD1,OPER,FLD2,FLD3,NXTFLD
...D POP(.FLD2),POP(.OPER),POP(.FLD1)
...S NXTFLD=$O(^TMP("OCXCMP",$J,"CODE","B"),-1)+1,^TMP("OCXCMP",$J,"CODE",NXTFLD)="",FLD3="1^"_NXTFLD
...;
...I (+OPER=3) D ; AND OPERATOR
....N SUB1,SUB2,DOTS
....S SUB1=0 F S SUB1=$O(FLD1("CODE",SUB1)) Q:'SUB1 D
.....N VAL1,VAL2
.....S (VAL1,VAL2)=FLD1("CODE",SUB1) S:(VAL1[" @@@@") VAL2=$P(VAL1," @@@@",1)_" "_$P(VAL1," @@@@",2)
.....S FLD3("CODE",$O(FLD3("CODE","B"),-1)+1)=VAL2
.....Q:'(VAL1["@@@@")
.....F DOTS=1:1:$L(VAL1) Q:'($E(VAL1,DOTS)=".")
.....S SUB2=0 F S SUB2=$O(FLD2("CODE",SUB2)) Q:'SUB2 D
......S FLD3("CODE",$O(FLD3("CODE","B"),-1)+1)=$E("..................",1,DOTS)_FLD2("CODE",SUB2)
...;
...I (+OPER=4) D ; OR OPERATOR
....N SUB
....S SUB=0 F S SUB=$O(FLD1("CODE",SUB)) Q:'SUB S FLD3("CODE",$O(FLD3("CODE","B"),-1)+1)=FLD1("CODE",SUB)
....S SUB=0 F S SUB=$O(FLD2("CODE",SUB)) Q:'SUB S FLD3("CODE",$O(FLD3("CODE","B"),-1)+1)=FLD2("CODE",SUB)
...;
...S FLD3("LABEL")="("_FLD1("LABEL")_" "_$S((+OPER=3):"AND",1:"OR")_" "_FLD2("LABEL")_")"
...M ^TMP("OCXCMP",$J,"CODE",NXTFLD)=FLD3
...D PUSH(FLD3,.FLD3)
..;
..I (+$$TOP(0)=6),(+$$TOP(1)=1),(+$$TOP(2)=5) S OCXSTOP=0 D ; RIGHT PARENTHESIS
...N FLD,TEMP D POP(.TEMP),POP(.FLD),POP(TEMP),PUSH(FLD,.FLD)
;
K OCXTKN D POP(.OCXTKN)
M ^TMP("OCXCMP",$J,"RULE",OCXD0,OCXD1)=OCXTKN
I $D(OCXSTAK) D WARN^OCXOCMPV(" ERROR: Incomplete expression..",2,OCXD0,$P($T(+1)," ",1)) Q OCXWARN
K ^TMP("OCXCMP",$J,"CODE")
Q OCXWARN
;
PUSH(V,C) ;
N T
S T=$O(OCXSTAK(99999),-1)+1
S OCXSTAK(T)=V
I $D(C) M OCXSTAK(T,"CODE")=C("CODE"),OCXSTAK(T,"LABEL")=C("LABEL")
Q
;
POP(V) ;
N L K V S V="",L=$O(OCXSTAK(99999),-1) Q:'L M V=OCXSTAK(L) K OCXSTAK(L) Q
;
TOP(C) ;
Q:'$D(OCXSTAK) "" Q:'$D(C) OCXSTAK($O(OCXSTAK(999999),-1))
N L,X S L=$O(OCXSTAK(99999),-1) Q:'L "" F X=1:1:C S L=$O(OCXSTAK(L),-1) Q:'L
Q:'L "" Q OCXSTAK(L)
K C
;
TKTXT(T) Q $S(T=1:"Data Field 1",T=2:"Data Field 2",T=3:"AND Operator",T=4:"OR Operator",T=5:"Left Parenthesis",T=6:"Right Parenthesis",1:"Token not found")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPB 4257 printed Apr 09, 2024@21:32:44 Page 2
OCXOCMPB ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Parse a Rule Relation Expression) ;10/29/98 12:37
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
+4 QUIT
+5 ;
PARSE(OCXD0,OCXD1,OCXEXP,OCXCD) ;
+1 ;
+2 if $GET(OCXWARN)
QUIT 1
+3 NEW OCXRES,OCXSTAK,OCXPTR,OCXTKN,OCXERR,OCXTEXP,OCXDASH
+4 NEW OCXBOOL,OCXPTKN,OCXX,OCXD2,OCXD3,OCXTPTR2
+5 KILL ^TMP("OCXCMP",$JOB,"CODE")
+6 MERGE ^TMP("OCXCMP",$JOB,"CODE")=OCXCD
+7 ;
+8 if ($PIECE(OCXEXP," ",1)="IF")
SET OCXEXP=$PIECE(OCXEXP," ",2,999)
+9 SET OCXEXP=$$PARCNT^OCXOCMPF(OCXEXP)
if '$LENGTH(OCXEXP)
QUIT OCXWARN
if OCXWARN
QUIT OCXWARN
+10 ;
+11 FOR OCXTPTR=1:1:($LENGTH(OCXEXP," ")+1)
SET OCXTXT=$PIECE(OCXEXP," ",OCXTPTR)
IF $LENGTH(OCXTXT)
Begin DoDot:1
+12 NEW OCXSTOP
+13 ;
+14 ; TOKENIZE TERM
+15 ;
+16 SET OCXPTKN=+$$TOP
+17 SET OCXTKN=$SELECT($LENGTH($GET(^TMP("OCXCMP",$JOB,"CODE","B",OCXTXT))):1,(OCXTXT="AND"):3,(OCXTXT="OR"):4,(OCXTXT="("):5,(OCXTXT=")"):6,1:0)
+18 IF 'OCXTKN
FOR OCXTPTR2=OCXTPTR:1:($LENGTH(OCXEXP," ")+1)
IF $LENGTH($GET(^TMP("OCXCMP",$JOB,"CODE","B",$PIECE(OCXEXP," ",OCXTPTR,OCXTPTR2))))
SET OCXTKN=1
SET OCXTXT=$PIECE(OCXEXP," ",OCXTPTR,OCXTPTR2)
SET OCXTPTR=OCXTPTR2
QUIT
+19 IF (OCXTKN=1)
if (OCXPTKN=3)
SET OCXTKN=2
if (OCXPTKN=4)
SET OCXTKN=2
SET OCXTXT=$GET(^TMP("OCXCMP",$JOB,"CODE","B",OCXTXT))
+20 IF +OCXTXT
IF +$GET(OCXCD(+OCXTXT))
SET ^TMP("OCXCMP",$JOB,"RULE",OCXD0,OCXD1,+OCXCD(+OCXTXT))=+OCXTXT
+21 ;
+22 ; CHECK FOR SYNTAX ERROR
+23 ;
+24 IF 'OCXTKN
DO SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXTXT,OCXTKN)
SET OCXWARN=1
QUIT
+25 IF ("50"[+OCXPTKN)
IF '("15"[(+OCXTKN))
DO SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXPTKN,OCXTKN)
SET OCXWARN=1
QUIT
+26 IF ("126"[+OCXPTKN)
IF '("346"[(+OCXTKN))
DO SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXPTKN,OCXTKN)
SET OCXWARN=1
QUIT
+27 IF ("34"[+OCXPTKN)
IF '("25"[(+OCXTKN))
DO SYNTXER^OCXOCMPF(OCXEXP,OCXTPTR,OCXPTKN,OCXTKN)
SET OCXWARN=1
QUIT
+28 ;
+29 if OCXWARN
QUIT
+30 ;
+31 ; PUT TERM ON THE STACK
+32 ;
+33 IF (OCXTKN<3)
Begin DoDot:2
+34 NEW OCXTMP
MERGE OCXTMP=^TMP("OCXCMP",$JOB,"CODE",+OCXTXT)
DO PUSH(OCXTKN_U_OCXTXT,.OCXTMP)
End DoDot:2
+35 IF (OCXTKN>2)
DO PUSH(OCXTKN_U_OCXTXT)
+36 ;
+37 ; PROCESS THE STACK
+38 ;
+39 FOR
Begin DoDot:2
+40 NEW OCXTOP
SET OCXSTOP=1
SET OCXTOP=+$$TOP
+41 ;
+42 IF (OCXTOP=1)
IF (+$$TOP(1)=3)
SET OCXTOP=2
+43 IF (OCXTOP=1)
IF (+$$TOP(1)=4)
SET OCXTOP=2
+44 ;
+45 ; SECOND DATA FIELD
IF (OCXTOP=2)
Begin DoDot:3
+46 NEW FLD1,OPER,FLD2,FLD3,NXTFLD
+47 DO POP(.FLD2)
DO POP(.OPER)
DO POP(.FLD1)
+48 SET NXTFLD=$ORDER(^TMP("OCXCMP",$JOB,"CODE","B"),-1)+1
SET ^TMP("OCXCMP",$JOB,"CODE",NXTFLD)=""
SET FLD3="1^"_NXTFLD
+49 ;
+50 ; AND OPERATOR
IF (+OPER=3)
Begin DoDot:4
+51 NEW SUB1,SUB2,DOTS
+52 SET SUB1=0
FOR
SET SUB1=$ORDER(FLD1("CODE",SUB1))
if 'SUB1
QUIT
Begin DoDot:5
+53 NEW VAL1,VAL2
+54 SET (VAL1,VAL2)=FLD1("CODE",SUB1)
if (VAL1[" @@@@")
SET VAL2=$PIECE(VAL1," @@@@",1)_" "_$PIECE(VAL1," @@@@",2)
+55 SET FLD3("CODE",$ORDER(FLD3("CODE","B"),-1)+1)=VAL2
+56 if '(VAL1["@@@@")
QUIT
+57 FOR DOTS=1:1:$LENGTH(VAL1)
if '($EXTRACT(VAL1,DOTS)=".")
QUIT
+58 SET SUB2=0
FOR
SET SUB2=$ORDER(FLD2("CODE",SUB2))
if 'SUB2
QUIT
Begin DoDot:6
+59 SET FLD3("CODE",$ORDER(FLD3("CODE","B"),-1)+1)=$EXTRACT("..................",1,DOTS)_FLD2("CODE",SUB2)
End DoDot:6
End DoDot:5
End DoDot:4
+60 ;
+61 ; OR OPERATOR
IF (+OPER=4)
Begin DoDot:4
+62 NEW SUB
+63 SET SUB=0
FOR
SET SUB=$ORDER(FLD1("CODE",SUB))
if 'SUB
QUIT
SET FLD3("CODE",$ORDER(FLD3("CODE","B"),-1)+1)=FLD1("CODE",SUB)
+64 SET SUB=0
FOR
SET SUB=$ORDER(FLD2("CODE",SUB))
if 'SUB
QUIT
SET FLD3("CODE",$ORDER(FLD3("CODE","B"),-1)+1)=FLD2("CODE",SUB)
End DoDot:4
+65 ;
+66 SET FLD3("LABEL")="("_FLD1("LABEL")_" "_$SELECT((+OPER=3):"AND",1:"OR")_" "_FLD2("LABEL")_")"
+67 MERGE ^TMP("OCXCMP",$JOB,"CODE",NXTFLD)=FLD3
+68 DO PUSH(FLD3,.FLD3)
End DoDot:3
SET OCXSTOP=0
QUIT
+69 ;
+70 ; RIGHT PARENTHESIS
IF (+$$TOP(0)=6)
IF (+$$TOP(1)=1)
IF (+$$TOP(2)=5)
SET OCXSTOP=0
Begin DoDot:3
+71 NEW FLD,TEMP
DO POP(.TEMP)
DO POP(.FLD)
DO POP(TEMP)
DO PUSH(FLD,.FLD)
End DoDot:3
End DoDot:2
if OCXSTOP
QUIT
End DoDot:1
if OCXWARN
QUIT
+72 ;
+73 KILL OCXTKN
DO POP(.OCXTKN)
+74 MERGE ^TMP("OCXCMP",$JOB,"RULE",OCXD0,OCXD1)=OCXTKN
+75 IF $DATA(OCXSTAK)
DO WARN^OCXOCMPV(" ERROR: Incomplete expression..",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT OCXWARN
+76 KILL ^TMP("OCXCMP",$JOB,"CODE")
+77 QUIT OCXWARN
+78 ;
PUSH(V,C) ;
+1 NEW T
+2 SET T=$ORDER(OCXSTAK(99999),-1)+1
+3 SET OCXSTAK(T)=V
+4 IF $DATA(C)
MERGE OCXSTAK(T,"CODE")=C("CODE"),OCXSTAK(T,"LABEL")=C("LABEL")
+5 QUIT
+6 ;
POP(V) ;
+1 NEW L
KILL V
SET V=""
SET L=$ORDER(OCXSTAK(99999),-1)
if 'L
QUIT
MERGE V=OCXSTAK(L)
KILL OCXSTAK(L)
QUIT
+2 ;
TOP(C) ;
+1 if '$DATA(OCXSTAK)
QUIT ""
if '$DATA(C)
QUIT OCXSTAK($ORDER(OCXSTAK(999999),-1))
+2 NEW L,X
SET L=$ORDER(OCXSTAK(99999),-1)
if 'L
QUIT ""
FOR X=1:1:C
SET L=$ORDER(OCXSTAK(L),-1)
if 'L
QUIT
+3 if 'L
QUIT ""
QUIT OCXSTAK(L)
+4 KILL C
+5 ;
TKTXT(T) QUIT $SELECT(T=1:"Data Field 1",T=2:"Data Field 2",T=3:"AND Operator",T=4:"OR Operator",T=5:"Left Parenthesis",T=6:"Right Parenthesis",1:"Token not found")
+1 ;
