OCXOCMPL ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Complex Rule Element Expressions) ;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
;
EN ;
;
Q
;
GETC(OCXD0,OCXEXP,OCXDTYP,OCXCD) ;
;
N OCXCHR,OCXCOD1,OCXCODE,OCXD2,OCXNULL,OCXOPC,OCXOPER,OCXOPN,OCXP,OCXPOS,OCXPTR1,OCXPTR2,OCXVNAM,OCXITEM
;
F OCXPTR1=1:1:$L(OCXEXP) S OCXCHR=$E(OCXEXP,OCXPTR1) D
.;
.I (OCXCHR="|") D Q
..F OCXPTR2=(OCXPTR1+1):1:$L(OCXEXP) Q:($E(OCXEXP,OCXPTR2)="|")
..S OCXITEM($O(OCXITEM(""),-1)+1)=$$STSPAC($E(OCXEXP,OCXPTR1+1,OCXPTR2-1)),OCXPTR1=OCXPTR2
.;
.I (OCXCHR="""") D Q
..F OCXPTR2=(OCXPTR1+1):1:$L(OCXEXP) Q:($E(OCXEXP,OCXPTR2)="""")
..S OCXITEM($O(OCXITEM(""),-1)+1)=$$STSPAC($E(OCXEXP,OCXPTR1+1,OCXPTR2-1)),OCXPTR1=OCXPTR2
.;
.I (OCXCHR?1A) D Q
..F OCXPTR2=(OCXPTR1+1):1:$L(OCXEXP) Q:($E(OCXEXP,OCXPTR2)="""") Q:($E(OCXEXP,OCXPTR2)="|")
..S OCXITEM($O(OCXITEM(""),-1)+1)=$$STSPAC($E(OCXEXP,OCXPTR1,OCXPTR2-1)),OCXPTR1=OCXPTR2-1
;
S OCXOPER=$$OPER(OCXITEM(2),OCXDTYP)
I '(OCXOPER) D WARN^OCXOCMPV("Operator/Function ("_OCXDTYP_") '"_OCXITEM(2)_"' not defined...",3,OCXEL,$P($T(+1)," ",1)) Q ""
S OCXOPN=$P($G(^OCXS(863.9,OCXOPER,0)),U,1)
S OCXOPC=$$GETPARM^OCXOCMPE(39,OCXOPER,"OCXO GENERATE CODE FUNCTION")
I '$L(OCXOPC) D WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' parameter not defined",3,OCXEL,$P($T(+1)," ",1)) Q ""
S:'(OCXOPC=+OCXOPC) OCXOPC=$$GETIEN("^OCXS(863.7)",OCXOPC)
I '$D(^OCXS(863.7,+OCXOPC,0)) D WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' Public Function not defined",3,OCXEL,$P($T(+1)," ",1)) Q ""
S OCXP=$G(^OCXS(863.7,+OCXOPC,"EX")) I '$L(OCXP) D WARN^OCXOCMPV("Operator ("_(+OCXOPC)_") '"_$P($G(^OCXS(863.9,+OCXOPC,0)),U,1)_"' executable not defined",3,OCXEL,$P($T(+1)," ",1)) Q ""
S OCXD2=0 F S OCXD2=$O(^OCXS(863.7,+OCXOPC,"PAR",OCXD2)) Q:'OCXD2 D
.N OCXPOS,OCXVNAM
.S OCXPOS=+$G(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,"IN")) Q:'OCXPOS Q:$D(OCXP(OCXPOS))
.S OCXVNAM=+$G(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,0)) Q:'OCXVNAM
.S OCXVNAM=$P($G(^OCXS(863.8,+OCXVNAM,0)),U,2) Q:'$L(OCXVNAM)
.S OCXP(+OCXPOS)=OCXVNAM,OCXP(OCXVNAM)=""
;
S OCXNULL=$$GETPARM(39,OCXOPER,"OCXO NULL VALUE ALLOWED")
I '$D(OCXP("PDFLD")) D WARN^OCXOCMPV("CMPE1 Primary Data field not defined",3,OCXD0,$P($T(+1)," ",1)) Q ""
I $D(OCXP("PDFLD")) S OCXP("PDFLD")=OCXITEM(1)
I '$L(OCXP("PDFLD")) D WARN^OCXOCMPV("CMPE2 Primary Data field not defined",3,OCXD0,$P($T(+1)," ",1)) Q ""
;
I $D(OCXP("CVAL")) D I '$L(OCXP("CVAL")) D WARN^OCXOCMPV("Comparison Value/Field not defined",3,OCXD0,$P($T(+1)," ",1)) Q ""
.S OCXP("CVAL")=OCXITEM(3)
.I '$L(OCXP("CVAL")) S OCXP("CVAL")=$$GV^OCXOCMPE(OCXD0,OCXD1,"DFLD2",OCXOPDT,OCXNULL)
;
I $D(OCXP("CLVAL")) D I '$L(OCXP("CLVAL")) D WARN^OCXOCMPV("Comparison Value/Field minimum value not defined",3,OCXD0,$P($T(+1)," ",1)) Q ""
.S OCXP("CLVAL")=OCXITEM(3)
.I '$L(OCXP("CLVAL")) S OCXP("CLVAL")=$$GV^OCXOCMPE(OCXD0,OCXD1,"DFLD2",OCXOPDT,OCXNULL)
;
I $D(OCXP("CHVAL")) D I '$L(OCXP("CHVAL")) D WARN^OCXOCMPV("Comparison Value/Field maximum value not defined",3,OCXD0,$P($T(+1)," ",1)) Q ""
.S OCXP("CHVAL")=OCXITEM(5)
.I '$L(OCXP("CHVAL")) S OCXP("CHVAL")=$$GV^OCXOCMPE(OCXD0,OCXD1,"DFLD3",OCXOPDT,OCXNULL)
;
S OCXCOD1="S OCXCODE=$$"_OCXP
I $O(OCXP(0)) S OCXCOD1=OCXCOD1_"(",OCXD2=0 F S OCXD2=$O(OCXP(OCXD2)) Q:'OCXD2 D
.I ($E(OCXP(OCXP(OCXD2)),1)="""") S OCXCOD1=OCXCOD1_""""""_OCXP(OCXP(OCXD2))_""""""
.E S OCXCOD1=OCXCOD1_""""_OCXP(OCXP(OCXD2))_""""
.I $O(OCXP(OCXD2)) S OCXCOD1=OCXCOD1_","
.E S OCXCOD1=OCXCOD1_")"
X OCXCOD1
I '$L(OCXCODE) D WARN^OCXOCMPV("Execute code missing for '"_OCXCOD1_"'",2,OCXD0,$P($T(+1)," ",1)) Q ""
S OCXCD="I "_OCXCODE_" D @@@@" Q OCXWARN
;
GETIEN(FILE,KEY) ;
;
N IEN1,IEN2,LEN,SHORT
F LEN=$L(KEY):-1:0 I LEN Q:$D(@FILE@("B",$E(KEY,1,LEN)))
Q:'LEN 0 S SHORT=$E(KEY,1,LEN)
S IEN1=0 F S IEN1=$O(@FILE@("B",SHORT,IEN1)) Q:'IEN1 Q:($P($G(@FILE@(IEN1,0)),U,1)=KEY)
S IEN2=IEN1 F S IEN2=$O(@FILE@("B",SHORT,IEN2)) Q:'IEN2 Q:($P($G(@FILE@(IEN2,0)),U,1)=KEY)
I IEN1,IEN2 Q -1
Q IEN1
;
OPER(OPER,DTYP) ;
;
N DTYPN,OPERN
S DTYPN=$O(^OCXS(864.1,"B",DTYP,0)) Q:'DTYPN 0
S OPERN=0 F S OPERN=$O(^OCXS(863.9,"B",OPER,OPERN)) Q:'OPERN Q:($P($G(^OCXS(863.9,+OPERN,0)),U,2)=DTYPN)
Q:OPERN OPERN
S OPERN=0 F S OPERN=$O(^OCXS(863.9,"SYN",OPER,OPERN)) Q:'OPERN Q:($P($G(^OCXS(863.9,+OPERN,0)),U,2)=DTYPN)
Q OPERN
;
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:'$L(OCXP1) ""
Q $G(@OCXGL@(FILE,OCXI,"PAR",OCXP1,"VAL"))
STSPAC(S) ;
;
N X
;
F X=1:1:$L(S) Q:'($E(S,X)=" ")
S S=$E(S,X,$L(S))
;
F X=$L(S):-1:1 Q:'($E(S,X)=" ")
S S=$E(S,1,X)
;
Q S
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPL 5320 printed Apr 09, 2024@21:33:39 Page 2
OCXOCMPL ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Complex Rule Element Expressions) ;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 ;
EN ;
+1 ;
+2 QUIT
+3 ;
GETC(OCXD0,OCXEXP,OCXDTYP,OCXCD) ;
+1 ;
+2 NEW OCXCHR,OCXCOD1,OCXCODE,OCXD2,OCXNULL,OCXOPC,OCXOPER,OCXOPN,OCXP,OCXPOS,OCXPTR1,OCXPTR2,OCXVNAM,OCXITEM
+3 ;
+4 FOR OCXPTR1=1:1:$LENGTH(OCXEXP)
SET OCXCHR=$EXTRACT(OCXEXP,OCXPTR1)
Begin DoDot:1
+5 ;
+6 IF (OCXCHR="|")
Begin DoDot:2
+7 FOR OCXPTR2=(OCXPTR1+1):1:$LENGTH(OCXEXP)
if ($EXTRACT(OCXEXP,OCXPTR2)="|")
QUIT
+8 SET OCXITEM($ORDER(OCXITEM(""),-1)+1)=$$STSPAC($EXTRACT(OCXEXP,OCXPTR1+1,OCXPTR2-1))
SET OCXPTR1=OCXPTR2
End DoDot:2
QUIT
+9 ;
+10 IF (OCXCHR="""")
Begin DoDot:2
+11 FOR OCXPTR2=(OCXPTR1+1):1:$LENGTH(OCXEXP)
if ($EXTRACT(OCXEXP,OCXPTR2)="""")
QUIT
+12 SET OCXITEM($ORDER(OCXITEM(""),-1)+1)=$$STSPAC($EXTRACT(OCXEXP,OCXPTR1+1,OCXPTR2-1))
SET OCXPTR1=OCXPTR2
End DoDot:2
QUIT
+13 ;
+14 IF (OCXCHR?1A)
Begin DoDot:2
+15 FOR OCXPTR2=(OCXPTR1+1):1:$LENGTH(OCXEXP)
if ($EXTRACT(OCXEXP,OCXPTR2)="""")
QUIT
if ($EXTRACT(OCXEXP,OCXPTR2)="|")
QUIT
+16 SET OCXITEM($ORDER(OCXITEM(""),-1)+1)=$$STSPAC($EXTRACT(OCXEXP,OCXPTR1,OCXPTR2-1))
SET OCXPTR1=OCXPTR2-1
End DoDot:2
QUIT
End DoDot:1
+17 ;
+18 SET OCXOPER=$$OPER(OCXITEM(2),OCXDTYP)
+19 IF '(OCXOPER)
DO WARN^OCXOCMPV("Operator/Function ("_OCXDTYP_") '"_OCXITEM(2)_"' not defined...",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT ""
+20 SET OCXOPN=$PIECE($GET(^OCXS(863.9,OCXOPER,0)),U,1)
+21 SET OCXOPC=$$GETPARM^OCXOCMPE(39,OCXOPER,"OCXO GENERATE CODE FUNCTION")
+22 IF '$LENGTH(OCXOPC)
DO WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' parameter not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT ""
+23 if '(OCXOPC=+OCXOPC)
SET OCXOPC=$$GETIEN("^OCXS(863.7)",OCXOPC)
+24 IF '$DATA(^OCXS(863.7,+OCXOPC,0))
DO WARN^OCXOCMPV("'"_OCXOPN_"' Operator 'OCXO GENERATE CODE FUNCTION' Public Function not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT ""
+25 SET OCXP=$GET(^OCXS(863.7,+OCXOPC,"EX"))
IF '$LENGTH(OCXP)
DO WARN^OCXOCMPV("Operator ("_(+OCXOPC)_") '"_$PIECE($GET(^OCXS(863.9,+OCXOPC,0)),U,1)_"' executable not defined",3,OCXEL,$PIECE($TEXT(+1)," ",1))
QUIT ""
+26 SET OCXD2=0
FOR
SET OCXD2=$ORDER(^OCXS(863.7,+OCXOPC,"PAR",OCXD2))
if 'OCXD2
QUIT
Begin DoDot:1
+27 NEW OCXPOS,OCXVNAM
+28 SET OCXPOS=+$GET(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,"IN"))
if 'OCXPOS
QUIT
if $DATA(OCXP(OCXPOS))
QUIT
+29 SET OCXVNAM=+$GET(^OCXS(863.7,+OCXOPC,"PAR",OCXD2,0))
if 'OCXVNAM
QUIT
+30 SET OCXVNAM=$PIECE($GET(^OCXS(863.8,+OCXVNAM,0)),U,2)
if '$LENGTH(OCXVNAM)
QUIT
+31 SET OCXP(+OCXPOS)=OCXVNAM
SET OCXP(OCXVNAM)=""
End DoDot:1
+32 ;
+33 SET OCXNULL=$$GETPARM(39,OCXOPER,"OCXO NULL VALUE ALLOWED")
+34 IF '$DATA(OCXP("PDFLD"))
DO WARN^OCXOCMPV("CMPE1 Primary Data field not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT ""
+35 IF $DATA(OCXP("PDFLD"))
SET OCXP("PDFLD")=OCXITEM(1)
+36 IF '$LENGTH(OCXP("PDFLD"))
DO WARN^OCXOCMPV("CMPE2 Primary Data field not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT ""
+37 ;
+38 IF $DATA(OCXP("CVAL"))
Begin DoDot:1
+39 SET OCXP("CVAL")=OCXITEM(3)
+40 IF '$LENGTH(OCXP("CVAL"))
SET OCXP("CVAL")=$$GV^OCXOCMPE(OCXD0,OCXD1,"DFLD2",OCXOPDT,OCXNULL)
End DoDot:1
IF '$LENGTH(OCXP("CVAL"))
DO WARN^OCXOCMPV("Comparison Value/Field not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT ""
+41 ;
+42 IF $DATA(OCXP("CLVAL"))
Begin DoDot:1
+43 SET OCXP("CLVAL")=OCXITEM(3)
+44 IF '$LENGTH(OCXP("CLVAL"))
SET OCXP("CLVAL")=$$GV^OCXOCMPE(OCXD0,OCXD1,"DFLD2",OCXOPDT,OCXNULL)
End DoDot:1
IF '$LENGTH(OCXP("CLVAL"))
DO WARN^OCXOCMPV("Comparison Value/Field minimum value not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT ""
+45 ;
+46 IF $DATA(OCXP("CHVAL"))
Begin DoDot:1
+47 SET OCXP("CHVAL")=OCXITEM(5)
+48 IF '$LENGTH(OCXP("CHVAL"))
SET OCXP("CHVAL")=$$GV^OCXOCMPE(OCXD0,OCXD1,"DFLD3",OCXOPDT,OCXNULL)
End DoDot:1
IF '$LENGTH(OCXP("CHVAL"))
DO WARN^OCXOCMPV("Comparison Value/Field maximum value not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT ""
+49 ;
+50 SET OCXCOD1="S OCXCODE=$$"_OCXP
+51 IF $ORDER(OCXP(0))
SET OCXCOD1=OCXCOD1_"("
SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXP(OCXD2))
if 'OCXD2
QUIT
Begin DoDot:1
+52 IF ($EXTRACT(OCXP(OCXP(OCXD2)),1)="""")
SET OCXCOD1=OCXCOD1_""""""_OCXP(OCXP(OCXD2))_""""""
+53 IF '$TEST
SET OCXCOD1=OCXCOD1_""""_OCXP(OCXP(OCXD2))_""""
+54 IF $ORDER(OCXP(OCXD2))
SET OCXCOD1=OCXCOD1_","
+55 IF '$TEST
SET OCXCOD1=OCXCOD1_")"
End DoDot:1
+56 XECUTE OCXCOD1
+57 IF '$LENGTH(OCXCODE)
DO WARN^OCXOCMPV("Execute code missing for '"_OCXCOD1_"'",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT ""
+58 SET OCXCD="I "_OCXCODE_" D @@@@"
QUIT OCXWARN
+59 ;
GETIEN(FILE,KEY) ;
+1 ;
+2 NEW IEN1,IEN2,LEN,SHORT
+3 FOR LEN=$LENGTH(KEY):-1:0
IF LEN
if $DATA(@FILE@("B",$EXTRACT(KEY,1,LEN)))
QUIT
+4 if 'LEN
QUIT 0
SET SHORT=$EXTRACT(KEY,1,LEN)
+5 SET IEN1=0
FOR
SET IEN1=$ORDER(@FILE@("B",SHORT,IEN1))
if 'IEN1
QUIT
if ($PIECE($GET(@FILE@(IEN1,0)),U,1)=KEY)
QUIT
+6 SET IEN2=IEN1
FOR
SET IEN2=$ORDER(@FILE@("B",SHORT,IEN2))
if 'IEN2
QUIT
if ($PIECE($GET(@FILE@(IEN2,0)),U,1)=KEY)
QUIT
+7 IF IEN1
IF IEN2
QUIT -1
+8 QUIT IEN1
+9 ;
OPER(OPER,DTYP) ;
+1 ;
+2 NEW DTYPN,OPERN
+3 SET DTYPN=$ORDER(^OCXS(864.1,"B",DTYP,0))
if 'DTYPN
QUIT 0
+4 SET OPERN=0
FOR
SET OPERN=$ORDER(^OCXS(863.9,"B",OPER,OPERN))
if 'OPERN
QUIT
if ($PIECE($GET(^OCXS(863.9,+OPERN,0)),U,2)=DTYPN)
QUIT
+5 if OPERN
QUIT OPERN
+6 SET OPERN=0
FOR
SET OPERN=$ORDER(^OCXS(863.9,"SYN",OPER,OPERN))
if 'OPERN
QUIT
if ($PIECE($GET(^OCXS(863.9,+OPERN,0)),U,2)=DTYPN)
QUIT
+7 QUIT OPERN
+8 ;
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 '$LENGTH(OCXP1)
QUIT ""
+13 QUIT $GET(@OCXGL@(FILE,OCXI,"PAR",OCXP1,"VAL"))
STSPAC(S) ;
+1 ;
+2 NEW X
+3 ;
+4 FOR X=1:1:$LENGTH(S)
if '($EXTRACT(S,X)=" ")
QUIT
+5 SET S=$EXTRACT(S,X,$LENGTH(S))
+6 ;
+7 FOR X=$LENGTH(S):-1:1
if '($EXTRACT(S,X)=" ")
QUIT
+8 SET S=$EXTRACT(S,1,X)
+9 ;
+10 QUIT S
+11 ;
