OCXOCMPE ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Rule Elements cont...) ;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,OCXD1,OCXP) ;
;
N OCXNULL
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")=$$GV(OCXD0,OCXD1,"DFLD1",OCXOPDT,OCXNULL)
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")=$$GV(OCXD0,OCXD1,"VAL1",OCXOPDT,OCXNULL)
.I '$L(OCXP("CVAL")) S OCXP("CVAL")=$$GV(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")=$$GV(OCXD0,OCXD1,"VAL1",OCXOPDT,OCXNULL)
.I '$L(OCXP("CLVAL")) S OCXP("CLVAL")=$$GV(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")=$$GV(OCXD0,OCXD1,"VAL2",OCXOPDT,OCXNULL)
.I '$L(OCXP("CHVAL")) S OCXP("CHVAL")=$$GV(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
I OCXTLOG,(OCXCODE["$$") D FILECODE("S OCXBOOLV="_OCXCODE,"S"),FILECODE("I OCXBOOLV","I") I 1
E D FILECODE("I "_OCXCODE,"I")
Q
;
;
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"))
;
GV(D0,D1,SUB,DTYP,NULL) ;
;
N OCXVAL,OCXFLDN,OCXFLDG,OCXD2,OCXCON,OCXCONN,OCXFREC
;
S OCXVAL=$G(^OCXS(860.3,D0,"COND",D1,SUB)) Q:'$L(OCXVAL) ""
Q:(SUB["VAL") $$EXT2INT^OCXOCMPA($P($G(^OCXS(864.1,+DTYP,0)),U,1),OCXVAL)
;
S OCXVAL=+OCXVAL,OCXFLDN=$P($G(^OCXS(860.4,OCXVAL,0)),U,1),OCXCON=$P($G(^OCXS(860.3,+D0,0)),U,2)
I 'OCXCON D WARN^OCXOCMPV("Element context missing for '"_$P($G(^OCXS(860.3,D0,0)),U,1)_"'",3,D0,$P($T(+1)," ",1)) Q
I '$L(OCXFLDN) D WARN^OCXOCMPV("Data Field Name missing for '"_OCXDFLD_"'",3,D0,$P($T(+1)," ",1)) Q
S OCXFREC="" I $D(^TMP("OCXCMP",$J,"DATA FIELD",OCXVAL)) M OCXFREC=^TMP("OCXCMP",$J,"DATA FIELD",OCXVAL)
I '$O(OCXFREC(0)) D Q ""
.D WARN^OCXOCMPV("CMPE Get data code not defined for '"_OCXFLDN_"' ("_(+OCXVAL)_")",3,D0,$P($T(+1)," ",1)) Q
;
I '$D(OCXFREC(OCXCON)) D
.S OCXCONN=0 F S OCXCONN=$O(OCXFREC(OCXCONN)) Q:'OCXCONN Q:$G(OCXFREC(OCXCONN,"DA MODE"))
.I 'OCXCONN D WARN^OCXOCMPV("CMPE Get data code mising for '"_$P($G(^OCXS(860.6,+OCXCON,0)),U,1)_"' ("_(+OCXCON)_") context of field '"_OCXFLDN_"' ("_(+OCXVAL)_")",3,D0,$P($T(+1)," ",1))
.S OCXCON=+OCXCONN
Q:'OCXCON ""
;
I '$L($G(OCXFREC(OCXCON,"DTYP","DATA TYPE INDEX")))!'$L($G(OCXFREC(OCXCON,"DTYP","DATA TYPE NAME"))) D Q ""
.D WARN^OCXOCMPV("Data Type not defined for '"_OCXFLDN_"' Field",3,D0,$P($T(+1)," ",1)) Q
I '(+DTYP=$G(OCXFREC(OCXCON,"DTYP","DATA TYPE INDEX"))) D Q ""
.N OCXX S OCXX="'"_OCXVAL_"-"_OCXFLDN_"' field's Data Type '"_OCXFREC(OCXCON,"DTYP","DATA TYPE NAME")
.S OCXX=OCXX_"' is not valid for '"_OCXOPN_"' Operator ("_(+DTYP)_"-"_$P($G(^OCXS(864.1,+DTYP,0)),U,1)_")"
.D WARN^OCXOCMPV(OCXX,3,D0,$P($T(+1)," ",1)) Q
;
S OCXFLDG="OCXDF("_(+OCXVAL)_")"
;
I 'NULL D FILECODE("I $L("_OCXFLDG_")","I")
;
Q OCXFLDG
K D0,D1
;
FILECODE(CODE,OPLIST) ;
;
N OCXNDX S OCXNDX=$O(OCXFCODE(9999),-1)+1,OCXFCODE(OCXNDX)=CODE
S:$L($G(OPLIST)) OCXFCODE(OCXNDX,"OPLIST")=OPLIST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPE 4645 printed Apr 09, 2024@21:41:49 Page 2
OCXOCMPE ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Compile Rule Elements cont...) ;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,OCXD1,OCXP) ;
+1 ;
+2 NEW OCXNULL
+3 SET OCXNULL=$$GETPARM(39,OCXOPER,"OCXO NULL VALUE ALLOWED")
+4 IF '$DATA(OCXP("PDFLD"))
DO WARN^OCXOCMPV("CMPE1 Primary Data field not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+5 IF $DATA(OCXP("PDFLD"))
SET OCXP("PDFLD")=$$GV(OCXD0,OCXD1,"DFLD1",OCXOPDT,OCXNULL)
+6 IF '$LENGTH(OCXP("PDFLD"))
DO WARN^OCXOCMPV("CMPE2 Primary Data field not defined",3,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+7 ;
+8 IF $DATA(OCXP("CVAL"))
Begin DoDot:1
+9 SET OCXP("CVAL")=$$GV(OCXD0,OCXD1,"VAL1",OCXOPDT,OCXNULL)
+10 IF '$LENGTH(OCXP("CVAL"))
SET OCXP("CVAL")=$$GV(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
+11 ;
+12 IF $DATA(OCXP("CLVAL"))
Begin DoDot:1
+13 SET OCXP("CLVAL")=$$GV(OCXD0,OCXD1,"VAL1",OCXOPDT,OCXNULL)
+14 IF '$LENGTH(OCXP("CLVAL"))
SET OCXP("CLVAL")=$$GV(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
+15 ;
+16 IF $DATA(OCXP("CHVAL"))
Begin DoDot:1
+17 SET OCXP("CHVAL")=$$GV(OCXD0,OCXD1,"VAL2",OCXOPDT,OCXNULL)
+18 IF '$LENGTH(OCXP("CHVAL"))
SET OCXP("CHVAL")=$$GV(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
+19 ;
+20 SET OCXCOD1="S OCXCODE=$$"_OCXP
+21 IF $ORDER(OCXP(0))
SET OCXCOD1=OCXCOD1_"("
SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXP(OCXD2))
if 'OCXD2
QUIT
Begin DoDot:1
+22 IF ($EXTRACT(OCXP(OCXP(OCXD2)),1)="""")
SET OCXCOD1=OCXCOD1_""""""_OCXP(OCXP(OCXD2))_""""""
+23 IF '$TEST
SET OCXCOD1=OCXCOD1_""""_OCXP(OCXP(OCXD2))_""""
+24 IF $ORDER(OCXP(OCXD2))
SET OCXCOD1=OCXCOD1_","
+25 IF '$TEST
SET OCXCOD1=OCXCOD1_")"
End DoDot:1
+26 XECUTE OCXCOD1
+27 IF '$LENGTH(OCXCODE)
DO WARN^OCXOCMPV("Execute code missing for '"_OCXCOD1_"'",2,OCXD0,$PIECE($TEXT(+1)," ",1))
QUIT
+28 IF OCXTLOG
IF (OCXCODE["$$")
DO FILECODE("S OCXBOOLV="_OCXCODE,"S")
DO FILECODE("I OCXBOOLV","I")
IF 1
+29 IF '$TEST
DO FILECODE("I "_OCXCODE,"I")
+30 QUIT
+31 ;
+32 ;
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"))
+14 ;
GV(D0,D1,SUB,DTYP,NULL) ;
+1 ;
+2 NEW OCXVAL,OCXFLDN,OCXFLDG,OCXD2,OCXCON,OCXCONN,OCXFREC
+3 ;
+4 SET OCXVAL=$GET(^OCXS(860.3,D0,"COND",D1,SUB))
if '$LENGTH(OCXVAL)
QUIT ""
+5 if (SUB["VAL")
QUIT $$EXT2INT^OCXOCMPA($PIECE($GET(^OCXS(864.1,+DTYP,0)),U,1),OCXVAL)
+6 ;
+7 SET OCXVAL=+OCXVAL
SET OCXFLDN=$PIECE($GET(^OCXS(860.4,OCXVAL,0)),U,1)
SET OCXCON=$PIECE($GET(^OCXS(860.3,+D0,0)),U,2)
+8 IF 'OCXCON
DO WARN^OCXOCMPV("Element context missing for '"_$PIECE($GET(^OCXS(860.3,D0,0)),U,1)_"'",3,D0,$PIECE($TEXT(+1)," ",1))
QUIT
+9 IF '$LENGTH(OCXFLDN)
DO WARN^OCXOCMPV("Data Field Name missing for '"_OCXDFLD_"'",3,D0,$PIECE($TEXT(+1)," ",1))
QUIT
+10 SET OCXFREC=""
IF $DATA(^TMP("OCXCMP",$JOB,"DATA FIELD",OCXVAL))
MERGE OCXFREC=^TMP("OCXCMP",$JOB,"DATA FIELD",OCXVAL)
+11 IF '$ORDER(OCXFREC(0))
Begin DoDot:1
+12 DO WARN^OCXOCMPV("CMPE Get data code not defined for '"_OCXFLDN_"' ("_(+OCXVAL)_")",3,D0,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:1
QUIT ""
+13 ;
+14 IF '$DATA(OCXFREC(OCXCON))
Begin DoDot:1
+15 SET OCXCONN=0
FOR
SET OCXCONN=$ORDER(OCXFREC(OCXCONN))
if 'OCXCONN
QUIT
if $GET(OCXFREC(OCXCONN,"DA MODE"))
QUIT
+16 IF 'OCXCONN
DO WARN^OCXOCMPV("CMPE Get data code mising for '"_$PIECE($GET(^OCXS(860.6,+OCXCON,0)),U,1)_"' ("_(+OCXCON)_") context of field '"_OCXFLDN_"' ("_(+OCXVAL)_")",3,D0,$PIECE($TEXT(+1)," ",1))
+17 SET OCXCON=+OCXCONN
End DoDot:1
+18 if 'OCXCON
QUIT ""
+19 ;
+20 IF '$LENGTH($GET(OCXFREC(OCXCON,"DTYP","DATA TYPE INDEX")))!'$LENGTH($GET(OCXFREC(OCXCON,"DTYP","DATA TYPE NAME")))
Begin DoDot:1
+21 DO WARN^OCXOCMPV("Data Type not defined for '"_OCXFLDN_"' Field",3,D0,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:1
QUIT ""
+22 IF '(+DTYP=$GET(OCXFREC(OCXCON,"DTYP","DATA TYPE INDEX")))
Begin DoDot:1
+23 NEW OCXX
SET OCXX="'"_OCXVAL_"-"_OCXFLDN_"' field's Data Type '"_OCXFREC(OCXCON,"DTYP","DATA TYPE NAME")
+24 SET OCXX=OCXX_"' is not valid for '"_OCXOPN_"' Operator ("_(+DTYP)_"-"_$PIECE($GET(^OCXS(864.1,+DTYP,0)),U,1)_")"
+25 DO WARN^OCXOCMPV(OCXX,3,D0,$PIECE($TEXT(+1)," ",1))
QUIT
End DoDot:1
QUIT ""
+26 ;
+27 SET OCXFLDG="OCXDF("_(+OCXVAL)_")"
+28 ;
+29 IF 'NULL
DO FILECODE("I $L("_OCXFLDG_")","I")
+30 ;
+31 QUIT OCXFLDG
+32 KILL D0,D1
+33 ;
FILECODE(CODE,OPLIST) ;
+1 ;
+2 NEW OCXNDX
SET OCXNDX=$ORDER(OCXFCODE(9999),-1)+1
SET OCXFCODE(OCXNDX)=CODE
+3 if $LENGTH($GET(OPLIST))
SET OCXFCODE(OCXNDX,"OPLIST")=OPLIST
+4 QUIT
