OCXOCMPC ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Optimize a Boolean 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
;
OPTMIZ(OCXD0,OCXEXP) ;
;
Q 0
N OCXRES,OCXSTAK,OCXPTR,OCXFLST,OCXTKN,OCXERR,OCXTEXP,OCXDASH,OCXBOOL,OCXPTKN,OCXX
;
S OCXEXP=$$PARCNT(OCXEXP) Q:'$L(OCXEXP) OCXWARN Q:OCXWARN OCXWARN
;
S OCXEXP=$TR(OCXEXP,"~","")
;
S OCXEXP=$$STRIP(OCXEXP)
;
I 0 W ! S OCXOP="" F OCXPTR=1:1:$L(OCXEXP," ") D
.F Q:'(+$$TOP) Q:'($$TOP=$$TOP(2)) S OCXX=$$POP,OCXX=$$POP D DISP
.;
.I (+$P(OCXEXP," ",OCXPTR)) D PUSH(+$P(OCXEXP," ",OCXPTR)) D DISP Q
.;
.I ($P(OCXEXP," ",OCXPTR)="(") D PUSH("(") S OCXOP="" D DISP Q
.;
.I ($P(OCXEXP," ",OCXPTR)=")") D S OCXOP="" D DISP Q
..N SUB,POP S SUB="" F S POP=$$POP Q:'$L(POP) Q:(POP="(") S:$L(SUB) SUB=" "_SUB S SUB=POP_SUB
..D PUSH($$TOKEN(SUB))
.;
.I '$L(OCXOP) S OCXOP=$P(OCXEXP," ",OCXPTR) D PUSH(OCXOP) D DISP Q
.;
.I '(OCXOP=$P(OCXEXP," ",OCXPTR)) D D DISP Q
..N SUB,POP S SUB="" F S POP=$$POP Q:'$L(POP) Q:(POP="(") S:$L(SUB) SUB=" "_SUB S SUB=POP_SUB
..D PUSH("(")
..D PUSH($$TOKEN(SUB))
..S OCXOP=$P(OCXEXP," ",OCXPTR)
..D PUSH(OCXOP)
.;
.D PUSH($P(OCXEXP," ",OCXPTR)) D DISP Q
;
S OCXEXP=$$EXPAND(OCXEXP)
;
Q 0_U_$TR(OCXEXP," ","")
;
DISP ;
Q:$G(OCXAUTO)
W !,$P(OCXEXP," ",1,OCXPTR),!
Q
TOKEN(VAL) ;
;
Q:($L(VAL," ")=1) VAL
N ORD,OPER,PTR
S OPER=$P(VAL," ",2)
F PTR=1:2:$L(VAL," ") S ORD($P(VAL," ",PTR))=""
S VAL="",PTR=0 F S PTR=$O(ORD(PTR)) Q:'PTR S:$L(VAL) VAL=VAL_" "_OPER_" " S VAL=VAL_PTR
;
S PTR=+$G(^TMP("OCXCMP",$J,"B TOKEN","B",VAL)) Q:PTR PTR
;
F PTR=$O(^OCXS(860.3,999999),-1)+1:1 Q:'$D(^TMP("OCXCMP",$J,"B TOKEN",+PTR))
S ^TMP("OCXCMP",$J,"B TOKEN",+PTR)=VAL
S ^TMP("OCXCMP",$J,"B TOKEN","B",VAL)=+PTR
Q +PTR
;
PUSH(V) S OCXSTAK($O(OCXSTAK(99999),-1)+1)=V Q
;
POP() N L,V S L=$O(OCXSTAK(99999),-1) Q:'L "" S V=OCXSTAK(L) K OCXSTAK(L) Q V
;
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
;
STRIP(EXP) ;
;
N QUIT,PTR
F S QUIT=1 D Q:QUIT
.F PTR=1:1:($L(EXP," ")-2) I ($P(EXP," ",PTR)="("),(+$P(EXP," ",PTR+1)),($P(EXP," ",PTR+2)=")") S QUIT=0 D Q
..I (PTR>1) S EXP=$P(EXP," ",1,PTR-1)_" "_(+$P(EXP," ",PTR+1))_" "_$P(EXP," ",PTR+3,99999) Q
..S EXP=(+$P(EXP," ",PTR+1))_" "_$P(EXP," ",PTR+3,99999)
Q EXP
;
PARCNT(EXP) ;
N CNT,PTR,TEMP
S CNT=0,TEMP="" F PTR=1:1:$L(EXP) D
.N CHAR S CHAR=$E(EXP,PTR)
.I (CHAR="(") S CNT=CNT+1,TEMP=TEMP_" ( "
.E I (CHAR=")") S CNT=CNT-1,TEMP=TEMP_" ) "
.E I '(CHAR=" "),'(CHAR="~"),(CHAR?1P) S TEMP=TEMP_" "_CHAR_" "
.E S TEMP=TEMP_CHAR
I CNT D Q ""
.N MSG
.S MSG(1)=" "_EXP,MSG(2)=" "
.I (CNT>0) S MSG(3)=" "_(CNT)_" Unmatched LEFT '(' parenthesis in expression"
.I (CNT<0) S MSG(3)=" "_(CNT*(-1))_" Unmatched RIGHT ')' parenthesis in expression"
.D WARN^OCXOCMPV(.MSG,2,OCXD0,$P($T(+1)," ",1)) Q
;
F Q:'(TEMP[" ") S TEMP=$P(TEMP," ",1)_" "_$P(TEMP," ",2,999)
F Q:'($E(TEMP,1)=" ") S TEMP=$E(TEMP,2,$L(TEMP))
Q TEMP
;
EXPAND(EXP) ;
;
N QUIT,PTR
F PTR=1:1:$L(EXP," ") S:+$P(EXP," ",PTR) $P(EXP," ",PTR)="~"_$P(EXP," ",PTR)_"~"
F Q:'(EXP["~") S EXP=$P(EXP,"~",1)_$G(^TMP("OCXCMP",$J,"B TOKEN",+$P(EXP,"~",2)))_$P(EXP,"~",3,999)
Q EXP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPC 3478 printed Nov 22, 2024@17:34:48 Page 2
OCXOCMPC ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Optimize a Boolean 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 ;
OPTMIZ(OCXD0,OCXEXP) ;
+1 ;
+2 QUIT 0
+3 NEW OCXRES,OCXSTAK,OCXPTR,OCXFLST,OCXTKN,OCXERR,OCXTEXP,OCXDASH,OCXBOOL,OCXPTKN,OCXX
+4 ;
+5 SET OCXEXP=$$PARCNT(OCXEXP)
if '$LENGTH(OCXEXP)
QUIT OCXWARN
if OCXWARN
QUIT OCXWARN
+6 ;
+7 SET OCXEXP=$TRANSLATE(OCXEXP,"~","")
+8 ;
+9 SET OCXEXP=$$STRIP(OCXEXP)
+10 ;
+11 IF 0
WRITE !
SET OCXOP=""
FOR OCXPTR=1:1:$LENGTH(OCXEXP," ")
Begin DoDot:1
+12 FOR
if '(+$$TOP)
QUIT
if '($$TOP=$$TOP(2))
QUIT
SET OCXX=$$POP
SET OCXX=$$POP
DO DISP
+13 ;
+14 IF (+$PIECE(OCXEXP," ",OCXPTR))
DO PUSH(+$PIECE(OCXEXP," ",OCXPTR))
DO DISP
QUIT
+15 ;
+16 IF ($PIECE(OCXEXP," ",OCXPTR)="(")
DO PUSH("(")
SET OCXOP=""
DO DISP
QUIT
+17 ;
+18 IF ($PIECE(OCXEXP," ",OCXPTR)=")")
Begin DoDot:2
+19 NEW SUB,POP
SET SUB=""
FOR
SET POP=$$POP
if '$LENGTH(POP)
QUIT
if (POP="(")
QUIT
if $LENGTH(SUB)
SET SUB=" "_SUB
SET SUB=POP_SUB
+20 DO PUSH($$TOKEN(SUB))
End DoDot:2
SET OCXOP=""
DO DISP
QUIT
+21 ;
+22 IF '$LENGTH(OCXOP)
SET OCXOP=$PIECE(OCXEXP," ",OCXPTR)
DO PUSH(OCXOP)
DO DISP
QUIT
+23 ;
+24 IF '(OCXOP=$PIECE(OCXEXP," ",OCXPTR))
Begin DoDot:2
+25 NEW SUB,POP
SET SUB=""
FOR
SET POP=$$POP
if '$LENGTH(POP)
QUIT
if (POP="(")
QUIT
if $LENGTH(SUB)
SET SUB=" "_SUB
SET SUB=POP_SUB
+26 DO PUSH("(")
+27 DO PUSH($$TOKEN(SUB))
+28 SET OCXOP=$PIECE(OCXEXP," ",OCXPTR)
+29 DO PUSH(OCXOP)
End DoDot:2
DO DISP
QUIT
+30 ;
+31 DO PUSH($PIECE(OCXEXP," ",OCXPTR))
DO DISP
QUIT
End DoDot:1
+32 ;
+33 SET OCXEXP=$$EXPAND(OCXEXP)
+34 ;
+35 QUIT 0_U_$TRANSLATE(OCXEXP," ","")
+36 ;
DISP ;
+1 if $GET(OCXAUTO)
QUIT
+2 WRITE !,$PIECE(OCXEXP," ",1,OCXPTR),!
+3 QUIT
TOKEN(VAL) ;
+1 ;
+2 if ($LENGTH(VAL," ")=1)
QUIT VAL
+3 NEW ORD,OPER,PTR
+4 SET OPER=$PIECE(VAL," ",2)
+5 FOR PTR=1:2:$LENGTH(VAL," ")
SET ORD($PIECE(VAL," ",PTR))=""
+6 SET VAL=""
SET PTR=0
FOR
SET PTR=$ORDER(ORD(PTR))
if 'PTR
QUIT
if $LENGTH(VAL)
SET VAL=VAL_" "_OPER_" "
SET VAL=VAL_PTR
+7 ;
+8 SET PTR=+$GET(^TMP("OCXCMP",$JOB,"B TOKEN","B",VAL))
if PTR
QUIT PTR
+9 ;
+10 FOR PTR=$ORDER(^OCXS(860.3,999999),-1)+1:1
if '$DATA(^TMP("OCXCMP",$JOB,"B TOKEN",+PTR))
QUIT
+11 SET ^TMP("OCXCMP",$JOB,"B TOKEN",+PTR)=VAL
+12 SET ^TMP("OCXCMP",$JOB,"B TOKEN","B",VAL)=+PTR
+13 QUIT +PTR
+14 ;
PUSH(V) SET OCXSTAK($ORDER(OCXSTAK(99999),-1)+1)=V
QUIT
+1 ;
POP() NEW L,V
SET L=$ORDER(OCXSTAK(99999),-1)
if 'L
QUIT ""
SET V=OCXSTAK(L)
KILL OCXSTAK(L)
QUIT V
+1 ;
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 ;
STRIP(EXP) ;
+1 ;
+2 NEW QUIT,PTR
+3 FOR
SET QUIT=1
Begin DoDot:1
+4 FOR PTR=1:1:($LENGTH(EXP," ")-2)
IF ($PIECE(EXP," ",PTR)="(")
IF (+$PIECE(EXP," ",PTR+1))
IF ($PIECE(EXP," ",PTR+2)=")")
SET QUIT=0
Begin DoDot:2
+5 IF (PTR>1)
SET EXP=$PIECE(EXP," ",1,PTR-1)_" "_(+$PIECE(EXP," ",PTR+1))_" "_$PIECE(EXP," ",PTR+3,99999)
QUIT
+6 SET EXP=(+$PIECE(EXP," ",PTR+1))_" "_$PIECE(EXP," ",PTR+3,99999)
End DoDot:2
QUIT
End DoDot:1
if QUIT
QUIT
+7 QUIT EXP
+8 ;
PARCNT(EXP) ;
+1 NEW CNT,PTR,TEMP
+2 SET CNT=0
SET TEMP=""
FOR PTR=1:1:$LENGTH(EXP)
Begin DoDot:1
+3 NEW CHAR
SET CHAR=$EXTRACT(EXP,PTR)
+4 IF (CHAR="(")
SET CNT=CNT+1
SET TEMP=TEMP_" ( "
+5 IF '$TEST
IF (CHAR=")")
SET CNT=CNT-1
SET TEMP=TEMP_" ) "
+6 IF '$TEST
IF '(CHAR=" ")
IF '(CHAR="~")
IF (CHAR?1P)
SET TEMP=TEMP_" "_CHAR_" "
+7 IF '$TEST
SET TEMP=TEMP_CHAR
End DoDot:1
+8 IF CNT
Begin DoDot:1
+9 NEW MSG
+10 SET MSG(1)=" "_EXP
SET MSG(2)=" "
+11 IF (CNT>0)
SET MSG(3)=" "_(CNT)_" Unmatched LEFT '(' parenthesis in expression"
+12 IF (CNT<0)
SET MSG(3)=" "_(CNT*(-1))_" Unmatched RIGHT ')' parenthesis in expression"
+13 DO WARN^OCXOCMPV(.MSG,2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:1
QUIT ""
+14 ;
+15 FOR
if '(TEMP[" ")
QUIT
SET TEMP=$PIECE(TEMP," ",1)_" "_$PIECE(TEMP," ",2,999)
+16 FOR
if '($EXTRACT(TEMP,1)=" ")
QUIT
SET TEMP=$EXTRACT(TEMP,2,$LENGTH(TEMP))
+17 QUIT TEMP
+18 ;
EXPAND(EXP) ;
+1 ;
+2 NEW QUIT,PTR
+3 FOR PTR=1:1:$LENGTH(EXP," ")
if +$PIECE(EXP," ",PTR)
SET $PIECE(EXP," ",PTR)="~"_$PIECE(EXP," ",PTR)_"~"
+4 FOR
if '(EXP["~")
QUIT
SET EXP=$PIECE(EXP,"~",1)_$GET(^TMP("OCXCMP",$JOB,"B TOKEN",+$PIECE(EXP,"~",2)))_$PIECE(EXP,"~",3,999)
+5 QUIT EXP
+6 ;
