- 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 Mar 13, 2025@21:29:48 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 ;
