OCXOCMP ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules) ;3/21/01 08:50
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,243**;Dec 17,1997;Build 242
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN ;
;
N OCXQ
;
S OCXQ=$$READ("Y","Do you want to queue the compiler to run ","NO") Q:(OCXQ[U) I OCXQ D Q
.D QUE^OCXOCMPV(10)
.W !!,"Expert system compiler queued to run in 10 seconds."
.W !,"You will be sent a Mailman bulletin when it has finished.",!!
.H 2
;
MAN K ZTSK D MAN^OCXOCMPV Q ; Run the compiler (interactive/manual mode)
; ; Ask for option settings.
;
AUTO D AUTO^OCXOCMPV Q ; Run the compiler (Automatic mode)
; ; Program Execution Trace Mode OFF
; ; Elapsed time logging OFF
; ; Raw Data Logging OFF
;
QUE D QUE^OCXOCMPV(10) Q ; Queue the compiler to run in the background
; ; Uses option setting from last compile.
; ; If no last compile then all options are
; ; turned OFF as in Automatic mode.
RUN ;
;
N OCX1,OCX2,OCX3,OCX4
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(1,20)
;
D MESG("Build list of Active Rules, Elements and Datafields...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP9 D ERMESG("Compiler Aborted while building list of Rules, Elements and Datafields...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(2,20)
;
S OCX1="" F S OCX1=$O(^TMP("OCXCMP",$J,OCX1)) Q:'$L(OCX1) D
.S OCX2=0 F OCX3=0:1 S OCX2=$O(^TMP("OCXCMP",$J,OCX1,OCX2)) Q:'OCX2
.D MESG(" "_$J(OCX3,5)_" "_OCX1_$S(OCX3=1:"",1:"S"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(3,20)
;
D MESG("Compile DataField Navigation code...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP1 D ERMESG("Compiler Aborted due to Datafield syntax errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(4,20)
;
S (OCX3,OCX1)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1)) Q:'OCX1 D
.S OCX2=0 F S OCX2=$O(^TMP("OCXCMP",$J,"DATA FIELD",OCX1,OCX2)) Q:'OCX2 S OCX3=OCX3+1
D MESG(" "_$J(OCX3,5)_" DataField Navigation Code Array"_$S(OCX3=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(5,20)
;
D MESG("Compile Element Evaluation code...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP2 D ERMESG("Compiler Aborted due to Rule Element syntax errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(6,20)
;
S (OCX1,OCX2)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"A CODE",OCX1)) Q:'OCX1 S OCX2=OCX2+1
D MESG(" "_$J(OCX2,5)_" Event Evaluation Code Array"_$S(OCX2=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(7,20)
;
D MESG("Compile Element MetaCode...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMPM D ERMESG("Compiler Aborted due to Element metacode errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(8,20)
;
S OCX1="",OCX2=0 F S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1) S:($E(OCX1,1,3)="MCE") OCX2=OCX2+1
D MESG(" "_$J(OCX2,5)_" Element Metacode Array"_$S(OCX2=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(9,20)
;
D MESG("Get Compiler Function Code...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMPO D ERMESG("Compiler Aborted due to Compiler Function code errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(10,20)
;
S OCX1="",OCX2=0 F S OCX1=$O(^TMP("OCXCMP",$J,"INCLUDE",OCX1)) Q:'$L(OCX1) S:'($E(OCX1,1,3)="MCE") OCX2=OCX2+1
D MESG(" "_$J(OCX2,5)_" Compiler Include Function"_$S(OCX2=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(12,20)
;
D MESG("Compile Rule Element Relation code...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP3 D ERMESG("Compiler Aborted due to Rule syntax errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(13,20)
;
S (OCX1,OCX2)=0 F S OCX1=$O(^TMP("OCXCMP",$J,"RULE",OCX1)) Q:'OCX1 D
.S OCX3=0 F S OCX3=$O(^TMP("OCXCMP",$J,"RULE",OCX1,OCX3)) Q:'OCX3 S:$O(^(OCX3,"CODE",0)) OCX2=OCX2+1
D MESG(" "_$J(OCX2,5)_" Rule Element Relation Code Array"_$S(OCX2=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(14,20)
;
D MESG("Construct Decision Tree...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP4 D ERMESG("Compiler Aborted due to Compiler errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(15,20)
;
S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1
D MESG(" "_$J(OCX2,5)_" Sub-Routine"_$S(OCX2=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(16,20)
;
D MESG("Optimize Sub-Routines...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP5 D ERMESG("Compiler Aborted due to Compiler errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(17,20)
;
S OCX1=0 F OCX3=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"C CODE",OCX1)) Q:'OCX1
D MESG(" "_$J(OCX3,5)_" Sub-Routine"_$S(OCX3=1:"",1:"s"))
D MESG(" "_(100-(((OCX3/OCX2)*1000)\1/10))_"% Optimization")
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(18,20)
;
D MESG("Assemble Routines...")
D SETFLAG^OCXOCMPV ; H 1
I $$EN^OCXOCMP6 D ERMESG("Compiler Aborted due to Compiler errors...") Q
Q:$G(OCXWARN)
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(19,20)
;
S OCX1=0 F OCX2=0:1 S OCX1=$O(^TMP("OCXCMP",$J,"D CODE",OCX1)) Q:'OCX1
D MESG(" "_$J(OCX2,5)_" OCXOZ* Routine"_$S(OCX2=1:"",1:"s"))
;
D:($G(OCXAUTO)<2) STATUS^OCXOPOST(20,20)
;
L -^OCXD(861,1)
;
Q
;
MESG(OCXX) ;
I '$G(OCXAUTO) W !!,OCXX
I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
Q
;
ERMESG(OCXX) ;
N OCXY S OCXY=OCXX
I '$G(OCXAUTO) W !!,OCXX
I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
S OCXERRM=OCXY
Q
;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
Q:'$L($G(OCXZ0)) U
S DIR(0)=OCXZ0
S:$L($G(OCXZA)) DIR("A")=OCXZA
S:$L($G(OCXZB)) DIR("B")=OCXZB
F OCXLINE=1:1:($G(OCXZL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
Q
;
DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y
Q
;
CNT(X) ;
;
N CNT,D0
S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0
W !!,?10,X," ",CNT
Q CNT
;
DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y
;
CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99)
;
;
VERSION() Q $P($T(+3),";;",3)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMP 6226 printed Dec 13, 2024@02:24:37 Page 2
OCXOCMP ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules) ;3/21/01 08:50
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,243**;Dec 17,1997;Build 242
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN ;
+1 ;
+2 NEW OCXQ
+3 ;
+4 SET OCXQ=$$READ("Y","Do you want to queue the compiler to run ","NO")
if (OCXQ[U)
QUIT
IF OCXQ
Begin DoDot:1
+5 DO QUE^OCXOCMPV(10)
+6 WRITE !!,"Expert system compiler queued to run in 10 seconds."
+7 WRITE !,"You will be sent a Mailman bulletin when it has finished.",!!
+8 HANG 2
End DoDot:1
QUIT
+9 ;
MAN ; Run the compiler (interactive/manual mode)
KILL ZTSK
DO MAN^OCXOCMPV
QUIT
+1 ; ; Ask for option settings.
+2 ;
AUTO ; Run the compiler (Automatic mode)
DO AUTO^OCXOCMPV
QUIT
+1 ; ; Program Execution Trace Mode OFF
+2 ; ; Elapsed time logging OFF
+3 ; ; Raw Data Logging OFF
+4 ;
QUE ; Queue the compiler to run in the background
DO QUE^OCXOCMPV(10)
QUIT
+1 ; ; Uses option setting from last compile.
+2 ; ; If no last compile then all options are
+3 ; ; turned OFF as in Automatic mode.
RUN ;
+1 ;
+2 NEW OCX1,OCX2,OCX3,OCX4
+3 ;
+4 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(1,20)
+5 ;
+6 DO MESG("Build list of Active Rules, Elements and Datafields...")
+7 ; H 1
DO SETFLAG^OCXOCMPV
+8 IF $$EN^OCXOCMP9
DO ERMESG("Compiler Aborted while building list of Rules, Elements and Datafields...")
QUIT
+9 if $GET(OCXWARN)
QUIT
+10 ;
+11 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(2,20)
+12 ;
+13 SET OCX1=""
FOR
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,OCX1))
if '$LENGTH(OCX1)
QUIT
Begin DoDot:1
+14 SET OCX2=0
FOR OCX3=0:1
SET OCX2=$ORDER(^TMP("OCXCMP",$JOB,OCX1,OCX2))
if 'OCX2
QUIT
+15 DO MESG(" "_$JUSTIFY(OCX3,5)_" "_OCX1_$SELECT(OCX3=1:"",1:"S"))
End DoDot:1
+16 ;
+17 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(3,20)
+18 ;
+19 DO MESG("Compile DataField Navigation code...")
+20 ; H 1
DO SETFLAG^OCXOCMPV
+21 IF $$EN^OCXOCMP1
DO ERMESG("Compiler Aborted due to Datafield syntax errors...")
QUIT
+22 if $GET(OCXWARN)
QUIT
+23 ;
+24 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(4,20)
+25 ;
+26 SET (OCX3,OCX1)=0
FOR
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"DATA FIELD",OCX1))
if 'OCX1
QUIT
Begin DoDot:1
+27 SET OCX2=0
FOR
SET OCX2=$ORDER(^TMP("OCXCMP",$JOB,"DATA FIELD",OCX1,OCX2))
if 'OCX2
QUIT
SET OCX3=OCX3+1
End DoDot:1
+28 DO MESG(" "_$JUSTIFY(OCX3,5)_" DataField Navigation Code Array"_$SELECT(OCX3=1:"",1:"s"))
+29 ;
+30 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(5,20)
+31 ;
+32 DO MESG("Compile Element Evaluation code...")
+33 ; H 1
DO SETFLAG^OCXOCMPV
+34 IF $$EN^OCXOCMP2
DO ERMESG("Compiler Aborted due to Rule Element syntax errors...")
QUIT
+35 if $GET(OCXWARN)
QUIT
+36 ;
+37 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(6,20)
+38 ;
+39 SET (OCX1,OCX2)=0
FOR
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"A CODE",OCX1))
if 'OCX1
QUIT
SET OCX2=OCX2+1
+40 DO MESG(" "_$JUSTIFY(OCX2,5)_" Event Evaluation Code Array"_$SELECT(OCX2=1:"",1:"s"))
+41 ;
+42 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(7,20)
+43 ;
+44 DO MESG("Compile Element MetaCode...")
+45 ; H 1
DO SETFLAG^OCXOCMPV
+46 IF $$EN^OCXOCMPM
DO ERMESG("Compiler Aborted due to Element metacode errors...")
QUIT
+47 if $GET(OCXWARN)
QUIT
+48 ;
+49 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(8,20)
+50 ;
+51 SET OCX1=""
SET OCX2=0
FOR
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"INCLUDE",OCX1))
if '$LENGTH(OCX1)
QUIT
if ($EXTRACT(OCX1,1,3)="MCE")
SET OCX2=OCX2+1
+52 DO MESG(" "_$JUSTIFY(OCX2,5)_" Element Metacode Array"_$SELECT(OCX2=1:"",1:"s"))
+53 ;
+54 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(9,20)
+55 ;
+56 DO MESG("Get Compiler Function Code...")
+57 ; H 1
DO SETFLAG^OCXOCMPV
+58 IF $$EN^OCXOCMPO
DO ERMESG("Compiler Aborted due to Compiler Function code errors...")
QUIT
+59 if $GET(OCXWARN)
QUIT
+60 ;
+61 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(10,20)
+62 ;
+63 SET OCX1=""
SET OCX2=0
FOR
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"INCLUDE",OCX1))
if '$LENGTH(OCX1)
QUIT
if '($EXTRACT(OCX1,1,3)="MCE")
SET OCX2=OCX2+1
+64 DO MESG(" "_$JUSTIFY(OCX2,5)_" Compiler Include Function"_$SELECT(OCX2=1:"",1:"s"))
+65 ;
+66 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(12,20)
+67 ;
+68 DO MESG("Compile Rule Element Relation code...")
+69 ; H 1
DO SETFLAG^OCXOCMPV
+70 IF $$EN^OCXOCMP3
DO ERMESG("Compiler Aborted due to Rule syntax errors...")
QUIT
+71 if $GET(OCXWARN)
QUIT
+72 ;
+73 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(13,20)
+74 ;
+75 SET (OCX1,OCX2)=0
FOR
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"RULE",OCX1))
if 'OCX1
QUIT
Begin DoDot:1
+76 SET OCX3=0
FOR
SET OCX3=$ORDER(^TMP("OCXCMP",$JOB,"RULE",OCX1,OCX3))
if 'OCX3
QUIT
if $ORDER(^(OCX3,"CODE",0))
SET OCX2=OCX2+1
End DoDot:1
+77 DO MESG(" "_$JUSTIFY(OCX2,5)_" Rule Element Relation Code Array"_$SELECT(OCX2=1:"",1:"s"))
+78 ;
+79 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(14,20)
+80 ;
+81 DO MESG("Construct Decision Tree...")
+82 ; H 1
DO SETFLAG^OCXOCMPV
+83 IF $$EN^OCXOCMP4
DO ERMESG("Compiler Aborted due to Compiler errors...")
QUIT
+84 if $GET(OCXWARN)
QUIT
+85 ;
+86 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(15,20)
+87 ;
+88 SET OCX1=0
FOR OCX2=0:1
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"C CODE",OCX1))
if 'OCX1
QUIT
+89 DO MESG(" "_$JUSTIFY(OCX2,5)_" Sub-Routine"_$SELECT(OCX2=1:"",1:"s"))
+90 ;
+91 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(16,20)
+92 ;
+93 DO MESG("Optimize Sub-Routines...")
+94 ; H 1
DO SETFLAG^OCXOCMPV
+95 IF $$EN^OCXOCMP5
DO ERMESG("Compiler Aborted due to Compiler errors...")
QUIT
+96 if $GET(OCXWARN)
QUIT
+97 ;
+98 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(17,20)
+99 ;
+100 SET OCX1=0
FOR OCX3=0:1
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"C CODE",OCX1))
if 'OCX1
QUIT
+101 DO MESG(" "_$JUSTIFY(OCX3,5)_" Sub-Routine"_$SELECT(OCX3=1:"",1:"s"))
+102 DO MESG(" "_(100-(((OCX3/OCX2)*1000)\1/10))_"% Optimization")
+103 ;
+104 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(18,20)
+105 ;
+106 DO MESG("Assemble Routines...")
+107 ; H 1
DO SETFLAG^OCXOCMPV
+108 IF $$EN^OCXOCMP6
DO ERMESG("Compiler Aborted due to Compiler errors...")
QUIT
+109 if $GET(OCXWARN)
QUIT
+110 ;
+111 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(19,20)
+112 ;
+113 SET OCX1=0
FOR OCX2=0:1
SET OCX1=$ORDER(^TMP("OCXCMP",$JOB,"D CODE",OCX1))
if 'OCX1
QUIT
+114 DO MESG(" "_$JUSTIFY(OCX2,5)_" OCXOZ* Routine"_$SELECT(OCX2=1:"",1:"s"))
+115 ;
+116 if ($GET(OCXAUTO)<2)
DO STATUS^OCXOPOST(20,20)
+117 ;
+118 LOCK -^OCXD(861,1)
+119 ;
+120 QUIT
+121 ;
MESG(OCXX) ;
+1 IF '$GET(OCXAUTO)
WRITE !!,OCXX
+2 IF ($GET(OCXAUTO)=1)
DO BMES^XPDUTL(.OCXX)
+3 QUIT
+4 ;
ERMESG(OCXX) ;
+1 NEW OCXY
SET OCXY=OCXX
+2 IF '$GET(OCXAUTO)
WRITE !!,OCXX
+3 IF ($GET(OCXAUTO)=1)
DO BMES^XPDUTL(.OCXX)
+4 SET OCXERRM=OCXY
+5 QUIT
+6 ;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
+1 NEW OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 if '$LENGTH($GET(OCXZ0))
QUIT U
+3 SET DIR(0)=OCXZ0
+4 if $LENGTH($GET(OCXZA))
SET DIR("A")=OCXZA
+5 if $LENGTH($GET(OCXZB))
SET DIR("B")=OCXZB
+6 FOR OCXLINE=1:1:($GET(OCXZL)-1)
WRITE !
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+9 QUIT Y
+10 ;
+11 QUIT
+12 ;
DT(X,D) NEW Y,%DT
SET %DT=D
DO ^%DT
QUIT Y
+1 QUIT
+2 ;
CNT(X) ;
+1 ;
+2 NEW CNT,D0
+3 SET D0=0
FOR CNT=1:1
SET D0=$ORDER(@X@(D0))
if 'D0
QUIT
+4 WRITE !!,?10,X," ",CNT
+5 QUIT CNT
+6 ;
DATE() NEW X,Y,%DT
SET X="N"
SET %DT="T"
DO ^%DT
XECUTE ^DD("DD")
QUIT Y
+1 ;
CONV(Y) if '(Y["@")
QUIT Y
QUIT $PIECE(Y,"@",1)_" at "_$PIECE(Y,"@",2,99)
+1 ;
+2 ;
VERSION() QUIT $PIECE($TEXT(+3),";;",3)
+1 ;
