- 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 Jan 18, 2025@03:26:01 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