OCXOCMPF ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Parse a Rule Relation Expression continued...) ;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
;
SYNTXER(EXP,PTR,FLD1,FLD2) ;
N OCXWTXT,OCXDASH
S OCXDASH="",$P(OCXDASH,"_",250)="_"
S OCXWTXT(1)=" "_EXP
S OCXWTXT(2)="_"_$E(OCXDASH,1,$L($P(EXP," ",1,PTR-1)))_"/"
S OCXWTXT(3)=" "
I 'FLD1,FLD2 S OCXWTXT(4)=" Syntax Error: A Boolean expression cannot start with a '"_$$TKTXT(FLD2)_"'."
I 'FLD1,'FLD2 S OCXWTXT(4)=" Unknown Symbol: '"_$P(EXP," ",PTR)_"'."
I FLD1,FLD2 S OCXWTXT(4)=" Syntax Error: A '"_$$TKTXT(FLD2)_"' cannot follow a '"_$$TKTXT(FLD1)_"'."
I '$D(OCXWTXT(4)) S OCXWTXT(4)="Unknown error with: '"_$P(EXP," ",PTR)_"'."
D WARN^OCXOCMPV(.OCXWTXT,2,OCXD0,$P($T(+1)," ",1)) Q
Q
;
OPCODE(TXT) ;
;
N OPNUM,SUB,OPFUNC,OPCNT,OCXX,OCXPFN
S OPNUM=0 F S OPNUM=$O(^OCXS(863.9,"B",TXT,OPNUM)) Q:'OPNUM Q:($P($G(^OCXS(863.9,OPNUM,0)),U,2)=OCXBOOL)
I 'OPNUM F S OPNUM=$O(^OCXS(863.9,"SYN",TXT,OPNUM)) Q:'OPNUM Q:($P($G(^OCXS(863.9,OPNUM,0)),U,2)=OCXBOOL)
Q:'OPNUM ""
S OPFUNC=$$GETPARM(39,OPNUM,"OCXO GENERATE CODE FUNCTION")
I OPFUNC S OCXPFN=+OPFUNC
E S OCXPFN=0 F S OCXPFN=$O(^OCXS(863.7,"B",$E(OPFUNC,1,30),OCXPFN)) Q:'OCXPFN Q:($P($G(^OCXS(863.7,+OCXPFN,0)),U,1)=OPFUNC)
S OCXX=0 F OPCNT=0:1 S OCXX=$O(^OCXS(863.7,+OCXPFN,"PAR",OCXX)) Q:'OCXX
;
Q:(OPCNT=1) 0
;
Q OPCNT_U_OPFUNC
;
GETPARM(FILE,INST,PARM) ;
Q:'$L(FILE) "" Q:'$L(INST) "" Q:'$L(PARM) ""
N OCXP,OCXP1,OCXI,OCXGL
S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860
Q:'$D(@OCXGL@(+FILE,0)) ""
I (PARM=+PARM),$D(^OCXS(863.8,PARM,0)) S OCXP=PARM
E S OCXP=$O(^OCXS(863.8,"B",PARM,0))
Q:'OCXP ""
I (INST=+INST),$D(@OCXGL@(FILE,INST,0)) S OCXI=INST
E S OCXI=$O(@OCXGL@(FILE,"B",INST,0))
Q:'OCXI ""
S OCXP1=$O(@OCXGL@(FILE,OCXI,"PAR","B",OCXP,0)) S:'OCXP1 OCXP1=$O(@OCXGL@(FILE,OCXI,"PAR","B",PARM,0))
Q:'OCXP1 ""
Q $G(@OCXGL@(FILE,OCXI,"PAR",OCXP1,"VAL"))
;
PARCNT(EXP) ;
N CNT,PTR
;
S CNT=$L(EXP,"(")-$L(EXP,")") I CNT D Q ""
.N MSG
.S MSG(1)=" "_EXP,MSG(2)=" "
.S MSG(3)=" "_$S((CNT<0):(-CNT),1:CNT)_" Unmatched "_$S((CNT>0):"LEFT '('",1:"RIGHT ')'")_" parenthesis in expression"
.S MSG(4)=" PARCNT^OCXOCMPF "
.D WARN^OCXOCMPV(.MSG,2,OCXD0,$P($T(+1)," ",1)) Q
;
F Q:'(EXP["(") S EXP=$P(EXP,"(",1)_" @ "_$P(EXP,"(",2,999)
S EXP=$TR(EXP,"@","(")
F Q:'(EXP[")") S EXP=$P(EXP,")",1)_" @ "_$P(EXP,")",2,999)
S EXP=$TR(EXP,"@",")")
;
F Q:'(EXP[" ") S EXP=$P(EXP," ",1)_" "_$P(EXP," ",2,999)
;
F PTR=1:1:$L(EXP) Q:'($E(EXP,PTR)=" ")
S EXP=$E(EXP,PTR,$L(EXP))
;
F PTR=$L(EXP):-1:1 Q:'($E(EXP,PTR)=" ")
S EXP=$E(EXP,1,PTR)
;
Q EXP
;
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")
;
EXPAND(OPFUNC,OCXP) ;
;
N OCXCOD1,OCXCODE,OCXD1
S OCXCODE="",OCXP=$G(^OCXS(863.7,+OPFUNC,"EX")),OCXCOD1="S OCXCODE=$$"_OCXP
S OCXD1=0 F S OCXD1=$O(^OCXS(863.7,+OPFUNC,"PAR",OCXD1)) Q:'OCXD1 D
.N OCXPOS,OCXVNAM
.S OCXPOS=+$G(^OCXS(863.7,+OPFUNC,"PAR",OCXD1,"IN")) Q:'OCXPOS Q:$D(OCXP(OCXPOS))
.S OCXVNAM=+$G(^OCXS(863.7,+OPFUNC,"PAR",OCXD1,0)) Q:'OCXVNAM
.S OCXVNAM=$P($G(^OCXS(863.8,+OCXVNAM,0)),U,2) Q:'$L(OCXVNAM)
.S OCXP(+OCXPOS)=OCXVNAM
I $O(OCXP(0)) D
.S OCXCOD1=OCXCOD1_"(",OCXD1=0 F S OCXD1=$O(OCXP(OCXD1)) Q:'OCXD1 D
..I ($E(OCXP(OCXP(OCXD1)),1)="""") S OCXCOD1=OCXCOD1_""""""_OCXP(OCXP(OCXD1))_""""""
..E S OCXCOD1=OCXCOD1_""""_OCXP(OCXP(OCXD1))_""""
..I $O(OCXP(OCXD1)) S OCXCOD1=OCXCOD1_","
..E S OCXCOD1=OCXCOD1_")"
.X OCXCOD1
;
Q OCXCODE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPF 3807 printed Apr 09, 2024@21:27:11 Page 2
OCXOCMPF ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Parse a Rule Relation Expression continued...) ;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 ;
SYNTXER(EXP,PTR,FLD1,FLD2) ;
+1 NEW OCXWTXT,OCXDASH
+2 SET OCXDASH=""
SET $PIECE(OCXDASH,"_",250)="_"
+3 SET OCXWTXT(1)=" "_EXP
+4 SET OCXWTXT(2)="_"_$EXTRACT(OCXDASH,1,$LENGTH($PIECE(EXP," ",1,PTR-1)))_"/"
+5 SET OCXWTXT(3)=" "
+6 IF 'FLD1
IF FLD2
SET OCXWTXT(4)=" Syntax Error: A Boolean expression cannot start with a '"_$$TKTXT(FLD2)_"'."
+7 IF 'FLD1
IF 'FLD2
SET OCXWTXT(4)=" Unknown Symbol: '"_$PIECE(EXP," ",PTR)_"'."
+8 IF FLD1
IF FLD2
SET OCXWTXT(4)=" Syntax Error: A '"_$$TKTXT(FLD2)_"' cannot follow a '"_$$TKTXT(FLD1)_"'."
+9 IF '$DATA(OCXWTXT(4))
SET OCXWTXT(4)="Unknown error with: '"_$PIECE(EXP," ",PTR)_"'."
+10 DO WARN^OCXOCMPV(.OCXWTXT,2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+11 QUIT
+12 ;
OPCODE(TXT) ;
+1 ;
+2 NEW OPNUM,SUB,OPFUNC,OPCNT,OCXX,OCXPFN
+3 SET OPNUM=0
FOR
SET OPNUM=$ORDER(^OCXS(863.9,"B",TXT,OPNUM))
if 'OPNUM
QUIT
if ($PIECE($GET(^OCXS(863.9,OPNUM,0)),U,2)=OCXBOOL)
QUIT
+4 IF 'OPNUM
FOR
SET OPNUM=$ORDER(^OCXS(863.9,"SYN",TXT,OPNUM))
if 'OPNUM
QUIT
if ($PIECE($GET(^OCXS(863.9,OPNUM,0)),U,2)=OCXBOOL)
QUIT
+5 if 'OPNUM
QUIT ""
+6 SET OPFUNC=$$GETPARM(39,OPNUM,"OCXO GENERATE CODE FUNCTION")
+7 IF OPFUNC
SET OCXPFN=+OPFUNC
+8 IF '$TEST
SET OCXPFN=0
FOR
SET OCXPFN=$ORDER(^OCXS(863.7,"B",$EXTRACT(OPFUNC,1,30),OCXPFN))
if 'OCXPFN
QUIT
if ($PIECE($GET(^OCXS(863.7,+OCXPFN,0)),U,1)=OPFUNC)
QUIT
+9 SET OCXX=0
FOR OPCNT=0:1
SET OCXX=$ORDER(^OCXS(863.7,+OCXPFN,"PAR",OCXX))
if 'OCXX
QUIT
+10 ;
+11 if (OPCNT=1)
QUIT 0
+12 ;
+13 QUIT OPCNT_U_OPFUNC
+14 ;
GETPARM(FILE,INST,PARM) ;
+1 if '$LENGTH(FILE)
QUIT ""
if '$LENGTH(INST)
QUIT ""
if '$LENGTH(PARM)
QUIT ""
+2 NEW OCXP,OCXP1,OCXI,OCXGL
+3 SET OCXGL="^OCXS"
if (FILE=1)
SET OCXGL="^OCXD"
if (FILE=7)
SET OCXGL="^OCXD"
if (FILE=10)
SET OCXGL="^OCXD"
SET FILE=FILE/10+860
+4 if '$DATA(@OCXGL@(+FILE,0))
QUIT ""
+5 IF (PARM=+PARM)
IF $DATA(^OCXS(863.8,PARM,0))
SET OCXP=PARM
+6 IF '$TEST
SET OCXP=$ORDER(^OCXS(863.8,"B",PARM,0))
+7 if 'OCXP
QUIT ""
+8 IF (INST=+INST)
IF $DATA(@OCXGL@(FILE,INST,0))
SET OCXI=INST
+9 IF '$TEST
SET OCXI=$ORDER(@OCXGL@(FILE,"B",INST,0))
+10 if 'OCXI
QUIT ""
+11 SET OCXP1=$ORDER(@OCXGL@(FILE,OCXI,"PAR","B",OCXP,0))
if 'OCXP1
SET OCXP1=$ORDER(@OCXGL@(FILE,OCXI,"PAR","B",PARM,0))
+12 if 'OCXP1
QUIT ""
+13 QUIT $GET(@OCXGL@(FILE,OCXI,"PAR",OCXP1,"VAL"))
+14 ;
PARCNT(EXP) ;
+1 NEW CNT,PTR
+2 ;
+3 SET CNT=$LENGTH(EXP,"(")-$LENGTH(EXP,")")
IF CNT
Begin DoDot:1
+4 NEW MSG
+5 SET MSG(1)=" "_EXP
SET MSG(2)=" "
+6 SET MSG(3)=" "_$SELECT((CNT<0):(-CNT),1:CNT)_" Unmatched "_$SELECT((CNT>0):"LEFT '('",1:"RIGHT ')'")_" parenthesis in expression"
+7 SET MSG(4)=" PARCNT^OCXOCMPF "
+8 DO WARN^OCXOCMPV(.MSG,2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:1
QUIT ""
+9 ;
+10 FOR
if '(EXP["(")
QUIT
SET EXP=$PIECE(EXP,"(",1)_" @ "_$PIECE(EXP,"(",2,999)
+11 SET EXP=$TRANSLATE(EXP,"@","(")
+12 FOR
if '(EXP[")")
QUIT
SET EXP=$PIECE(EXP,")",1)_" @ "_$PIECE(EXP,")",2,999)
+13 SET EXP=$TRANSLATE(EXP,"@",")")
+14 ;
+15 FOR
if '(EXP[" ")
QUIT
SET EXP=$PIECE(EXP," ",1)_" "_$PIECE(EXP," ",2,999)
+16 ;
+17 FOR PTR=1:1:$LENGTH(EXP)
if '($EXTRACT(EXP,PTR)=" ")
QUIT
+18 SET EXP=$EXTRACT(EXP,PTR,$LENGTH(EXP))
+19 ;
+20 FOR PTR=$LENGTH(EXP):-1:1
if '($EXTRACT(EXP,PTR)=" ")
QUIT
+21 SET EXP=$EXTRACT(EXP,1,PTR)
+22 ;
+23 QUIT EXP
+24 ;
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 ;
EXPAND(OPFUNC,OCXP) ;
+1 ;
+2 NEW OCXCOD1,OCXCODE,OCXD1
+3 SET OCXCODE=""
SET OCXP=$GET(^OCXS(863.7,+OPFUNC,"EX"))
SET OCXCOD1="S OCXCODE=$$"_OCXP
+4 SET OCXD1=0
FOR
SET OCXD1=$ORDER(^OCXS(863.7,+OPFUNC,"PAR",OCXD1))
if 'OCXD1
QUIT
Begin DoDot:1
+5 NEW OCXPOS,OCXVNAM
+6 SET OCXPOS=+$GET(^OCXS(863.7,+OPFUNC,"PAR",OCXD1,"IN"))
if 'OCXPOS
QUIT
if $DATA(OCXP(OCXPOS))
QUIT
+7 SET OCXVNAM=+$GET(^OCXS(863.7,+OPFUNC,"PAR",OCXD1,0))
if 'OCXVNAM
QUIT
+8 SET OCXVNAM=$PIECE($GET(^OCXS(863.8,+OCXVNAM,0)),U,2)
if '$LENGTH(OCXVNAM)
QUIT
+9 SET OCXP(+OCXPOS)=OCXVNAM
End DoDot:1
+10 IF $ORDER(OCXP(0))
Begin DoDot:1
+11 SET OCXCOD1=OCXCOD1_"("
SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXP(OCXD1))
if 'OCXD1
QUIT
Begin DoDot:2
+12 IF ($EXTRACT(OCXP(OCXP(OCXD1)),1)="""")
SET OCXCOD1=OCXCOD1_""""""_OCXP(OCXP(OCXD1))_""""""
+13 IF '$TEST
SET OCXCOD1=OCXCOD1_""""_OCXP(OCXP(OCXD1))_""""
+14 IF $ORDER(OCXP(OCXD1))
SET OCXCOD1=OCXCOD1_","
+15 IF '$TEST
SET OCXCOD1=OCXCOD1_")"
End DoDot:2
+16 XECUTE OCXCOD1
End DoDot:1
+17 ;
+18 QUIT OCXCODE
+19 ;
