jsoltys/CGW
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
CGW/CGWRULE.PRG
T
Jason Soltys 7905c43278 first commit
2026-07-14 00:41:31 -05:00

1137 lines
29 KiB
Plaintext
Raw Permalink Blame History

** CGWRULE - ADD/CHG/DEL ATTRIBUTE RULES
** DON LOWENSTEIN 10-25-93
* * * * * * * * * * * * * * *
#INCLUDE 'INKEY.CH'
***************************************************************
FUNCTION REP_RECNO()
REPLACE LINE_NUM WITH RECNO()
RETURN .T.
***************************************************************
FUNCTION RULE_DISPLINE
LOCAL RETVAL, CURREC
CURREC := STR(RECNO(),4 )
RETVAL := SUBS( 'L' + ALLTRIM(CURREC) + SPACE(10) , 1, 6)
RETURN RETVAL
*********************************************************
FUNCTION CK_OPERRULE
LOCAL GOODOPER := .F.
DO CASE
CASE OPERATOR = '=='
RETURN .T.
CASE OPERATOR = 'LT'
RETURN .T.
CASE OPERATOR = 'GT'
RETURN .T.
CASE OPERATOR = 'EQ'
RETURN .T.
CASE OPERATOR = 'LE'
RETURN .T.
CASE OPERATOR = 'GE'
RETURN .T.
CASE OPERATOR = 'NE'
RETURN .T.
CASE ALLTRIM(OPERATOR) == '<'
REPLACE OPERATOR WITH '< '
RETURN .T.
CASE ALLTRIM(OPERATOR) == '>'
REPLACE OPERATOR WITH '> '
RETURN .T.
CASE ALLTRIM(OPERATOR) == '='
REPLACE OPERATOR WITH '= '
RETURN .T.
CASE OPERATOR == '<='
RETURN .T.
CASE OPERATOR == '>='
RETURN .T.
CASE OPERATOR == '<>'
RETURN .T.
OTHERWISE
ERR_BOX( ' *** INVALID FIELD OPERATOR ***' ,;
' "LT" or "<" is LESS THAN ³ "GT" or ">" is MORE THAN ',;
' "LE" or "<=" is LESS THAN or = ³ "GE" or ">=" is GR. or = ',;
' "EQ" or "=" is EQUAL ³ "NE" or "<>" is NOT EQUAL')
RETURN .F.
ENDCASE
******************************************************************
FUNCTION CK_COMMRULE()
IF !LCOMMAND$'ID '
ERR_BOX( 'VALID COMMANDS ARE: I = Insert',;
' D = Delete')
RETURN .F.
ENDIF
IF LCOMMAND=' '
RETURN .T.
ENDIF
IF LCOMMAND = 'D'
IF RECNO() = 1
GOTOREC := RECNO() - 1
ELSE
GOTOREC := 1
ENDIF
DELETE
PACK
GOTO GOTOREC
RETURN .T.
ENDIF
IF LCOMMAND = 'I'
GOTOREC := RECNO()
APPEND BLANK
GOTO BOTTOM
DO WHILE RECNO() <> GOTOREC
SKIP -1
PLINE_NUM := LINE_NUM
PLOGIC_GR := LOGIC_GR
P_FIELD1 := FIELD1
P_FIELD1TYPE := FIELD1TYPE
P_FIELD2TYPE := FIELD2TYPE
P_ALIAS1 := ALIAS1
P_OPERATOR := OPERATOR
P_FIELD2 := FIELD2
P_ALIAS2 := ALIAS2
PCONT_COND := CONT_COND
SKIP 1
REPLACE RULE_CODE WITH RULES->RULE_CODE
REPLACE LOGIC_GR WITH PLOGIC_GR
REPLACE FIELD1 WITH P_FIELD1
REPLACE FIELD1TYPE WITH P_FIELD1TYPE
REPLACE ALIAS1 WITH P_ALIAS1
REPLACE FIELD2 WITH P_FIELD2
REPLACE FIELD2TYPE WITH P_FIELD2TYPE
REPLACE ALIAS2 WITH P_ALIAS2
REPLACE OPERATOR WITH P_OPERATOR
REPLACE CONT_COND WITH PCONT_COND
REPLACE LINE_NUM WITH RECNO()
SKIP -1
ENDDO
REPLACE RULE_CODE WITH RULES->RULE_CODE
REPLACE LOGIC_GR WITH ' '
REPLACE FIELD1 WITH SPACE(10)
REPLACE FIELD1TYPE WITH SPACE(1)
REPLACE FIELD2 WITH SPACE(10)
REPLACE FIELD2TYPE WITH SPACE(1)
REPLACE ALIAS1 WITH ' '
REPLACE ALIAS2 WITH ' '
REPLACE OPERATOR WITH ' '
REPLACE CONT_COND WITH ' '
REPLACE LINE_NUM WITH RECNO()
REPLACE LCOMMAND WITH ' '
RETURN .T.
ENDIF
***********************************************************
FUNCTION CK_CONTCOND
LOCAL CC1
CC1 := SUBSTR(CONT_COND,1,1)
IF CC1 = ' '
REPLACE CONT_COND WITH ' '
RETURN .T.
ENDIF
IF !CC1$'OA'
ERRLINE := 'Line ' + STR(RECNO(),3) + ' '
ERR_BOX( 'VALID CONTINUE CONDITIONS ARE: "A" = "AND" ',;
' (Blank is Also "AND") ',;
' "O" = "OR" ',;
' (See ' + ERRLINE + ') ')
RETURN .F.
ENDIF
CURREC := RECNO()
SKIP 1
ERRFLAG := .F.
** LOOK AT THE NEXT RECORD
IF EOF()
ELSE
IF !EMPTY(LOGIC_GR)
ERRFLAG := .T.
ENDIF
ENDIF
GOTO CURREC
IF ERRFLAG
ERRLINE := 'Line ' + STR(RECNO(),3) + ' '
ERR_BOX( ' You May NOT Place a CONTINUATION (And/Or) ',;
' Immediately Preceding a NEW LOGIC GROUP ',;
' or OR" on the LAST LINE. ',;
' (See ' + ERRLINE + ') ')
RETURN .F.
ENDIF
IF CC1 = 'O'
REPLACE CONT_COND WITH 'OR '
ELSE
IF CC1 = 'A'
REPLACE CONT_COND WITH 'AND'
ELSE
REPLACE CONT_COND WITH ' '
ENDIF
ENDIF
KEYBOARD CHR(13)
RETURN .T.
***********************************************************
FUNCTION CK_LOGICGR
IF RECNO() = 1
REPLACE LOGIC_GR WITH ' 1'
ENDIF
IF EMPTY(LOGIC_GR)
RETURN .T.
ELSE
IF LOGIC_GR == 'OR'
RETURN .T.
ELSE
IF VAL(LOGIC_GR) > 0
REPLACE LOGIC_GR WITH STR(VAL(LOGIC_GR),2)
RETURN .T.
ELSE
ERRLINE := 'Line ' + STR(RECNO(),3) + ' '
ERR_BOX( 'VALID LOGIC GROUPS ARE: ',;
' - Numeric Sequence Numbers ',;
' - "OR" (Which Will Combine Logic Groups) ',;
' (See ' + ERRLINE + ') ')
RETURN .F.
ENDIF
ENDIF
ENDIF
RETURN .T.
***********************************************************
PROCEDURE LOGICERR
ERRLINE := 'Line ' + STR(RECNO(),3) + ' '
ERR_BOX( 'LOGIC GROUPS (' + ERRLINE + ') ARE OUT OF SEQUENCE ',;
' Please Re-enter with Consecutive ',;
' LOGIC GROUPS or NO LOGIC GROUPS AT ALL! ')
RETURN
*********************************************************
FUNCTION OPT_VAL_LOOK() // CALLED FROM THE ALIAS2 FIELD
LOCAL NCHOICE := 0
LOCAL HEADER := 'Select File'
LOCAL CHOICE_ARR := {}, SAVESEL := SELECT()
LOCAL SAVESCR := SAVESCREEN(), SAVEORD
LOCAL SAVECURSOR := SETCURSOR(), SAVEFILT
LOCAL STRT_ROW := 10
LOCAL RETVAL := 10
PRIVATE DISPVAL, FILTERVAL
IF FIELD2 == '"SYSTEM "'
NCHOICE = 1
ELSE
IF FIELD2 == '"CATEGORY"'
NCHOICE = 2
ELSE
IF FIELD2 == '"MODEL "'
NCHOICE = 3
ELSE
AADD(CHOICE_ARR, 'SYSTEM ATTRIBUTE Options')
AADD(CHOICE_ARR, 'CATEGORY ATTRIBUTE Options')
AADD(CHOICE_ARR, 'MODEL ATTRIBUTE Options')
NCHOICE = LISTBOX(CHOICE_ARR,1,HEADER, STRT_ROW)
IF LASTKEY() = 27
RESTSCREEN(,,,,SAVESCR)
SETCURSOR(SAVECURSOR)
RETURN .F.
ENDIF
ENDIF
ENDIF
ENDIF
IF NCHOICE = 1
SELFILE = 'ATT_OPTS'
DISPVAL := '"-" + ATT_CODE + " " + OPT_VALUE '
ELSE
IF NCHOICE = 2
SELFILE = 'CAT_OPTS'
DISPVAL := '"-" + CAT_CODE + " " + OPT_VALUE '
ELSE
IF NCHOICE = 3
SELFILE = 'PROD_OPTS'
DISPVAL := '"-" + PROD_CODE + " " + OPT_VALUE '
ENDIF
ENDIF
ENDIF
SELECT (SELFILE)
SAVEORD := INDEXORD()
SAVEFILT := DBFILTER()
IF NCHOICE <> 1
DONSETORD(2)
ENDIF
**SET FILTER TO ATT_CODE == (SAVESEL)->FIELD1
FILTERVAL := 'ATT_CODE == ' + STR(SAVESEL,2) + '->FIELD1'
SET FILTER TO &FILTERVAL
***********************GBROWSE( SELFILE )
RETVAL := VAL_LOOKUP((SAVESEL)->FIELD1 + (SAVESEL)->ALIAS2, ;
SELFILE, 5, {'ATT_CODE', DISPVAL} , 'Y' ,.F., ;
STR(SAVESEL,2) + '->ALIAS2')
******************* SELFILE, 5, {'ATT_CODE', DISPVAL} , 'Y' ,.F., '(SAVESEL)->ALIAS2')
SELECT (SELFILE)
SET FILTER TO &SAVEFILT
DONSETORD(SAVEORD)
SELECT (SAVESEL)
//** CHECK FOR ENTER OR F10
IF (LASTKEY() = 13 .OR. LASTKEY() = -9 ) .AND. RETVAL
IF NCHOICE = 1
REPLACE (SAVESEL)->FIELD2 WITH '"SYSTEM "'
ELSEIF NCHOICE = 2
REPLACE (SAVESEL)->FIELD2 WITH '"CATEGORY"'
ELSE
REPLACE (SAVESEL)->FIELD2 WITH '"MODEL "'
ENDIF
IF SELECT('TFILE') > 0
REPLACE (SAVESEL)->ALIAS2 WITH TFILE->OPT_VALUE
SELECT TFILE
USE
SELECT (SAVESEL)
ELSE
REPLACE (SAVESEL)->ALIAS2 WITH (SELFILE)->OPT_VALUE
ENDIF
REPLACE (SAVESEL)->FIELD2TYPE WITH 'C'
ENDIF
RETURN RETVAL
****************************************************
FUNCTION CK_CAT_MOD()
IF FIELD2 = '"CATEGORY"' .OR. FIELD2 = '"MODEL "' ;
.OR. FIELD2 = '"SYSTEM "'
RETURN .T.
ELSE
RETURN .F.
ENDIF
****************************************************
FUNCTION RULE_LINE1()
RETURN ' Att Code '
****************************************************
FUNCTION RULE_LINE2()
RETURN ' Logic Att. /Option Attribute Cont Line'
***********************************************************
***FUNCTION GETRULES(MRULE_CODE ) // GET ALL RULES THAT APPLY TO THIS ITEM
FUNCTION GETRULES(MRULE_CODE, SELFILE, GET_ARR, GET_ELM)
** RETURNS AN ARRAY WITH FIVE ELEMENTS, ONE ELEMENT FOR EACH SET
** OF RULES OF THAT TYPE
LOCAL RULEARR, SAVESCR, I, II, CUSTRULES := {}, LOANRULES := {}
LOCAL FSRULES := {}, TRRULES := {}, RETVAL, SAVESEL
LOCAL LVRULES := {}
SAVE SCREEN TO SAVESCR
SAVESEL := SELECT()
RULEARR := {}
SELECT RULES
SEEKKEY := MRULE_CODE
SEEK SEEKKEY
IF !FOUND()
ERR_BOX('PRODUCT ' + ALLTRIM((SELFILE)->PROD_CODE) + ' contains the ' + ;
'RULE CODE ' + MRULE_CODE + '! ', ;
'The RULE was NOT FOUND IN the RULES File!', ;
'Define the RULE "' + ALLTRIM(MRULE_CODE) + '" and try again!')
ENDIF
DO WHILE RULE_CODE == MRULE_CODE .AND. !EOF()
RETVAL := FILLRULE()
IF !EMPTY(RETVAL)
AADD(CUSTRULES, RETVAL) // RETARR ELE 1
ENDIF
SELECT RULES
SKIP 1
ENDDO
SELECT RULES
SELECT &SAVESEL
RULEARR := CUSTRULES
RESTORE SCREEN FROM SAVESCR
RETURN RULEARR
******************************************************************
STATIC FUNCTION FILLRULE()
LOCAL SEEKKEY, CURRULEPACK := {}, RULEPARMS := {}, LOGICARR := {}
LOCAL SUBGRARR := {}, SAVESEL
LOCAL TEMPADD := {}
SAVESEL := SELECT()
SEEKKEY := RULE_CODE
SELECT RULEPACK
SEEK SEEKKEY
FSTREC := .T.
LASTSUBGR := 1
CURLG := 0
IF FOUND()
** IF THE LOGIC GROUP IS NOT EMPTY, EITHER NEW LOGIC OR SUBLOGIC GR.
** THE RETURNED ARRAY MUST CONTAIN 1 ELEMENT PER LOGIC GROUP
RULEPARMS := {, RULES->RULE_CODE,;
RULES->RULE_LT, RULES->AUTO_GRADE,;
RULES->RULE_DESC, RULES->SETUP_ID}
LASTLG := LOGIC_GR
DO WHILE RULE_CODE == SEEKKEY .AND. !EOF()
IF !EMPTY(LOGIC_GR) .OR. FSTREC
FSTREC := .F.
IF LOGIC_GR = 'OR'
SUBGR ++
ELSE
IF CURLG <> 0
** ADD THE RULE PACK FOR THE CURRENT SUBGROUP BEFORE ADDING LG
AADD(SUBGRARR, {CURRULEPACK, LASTLG})
CURRULEPACK := {}
** LOGICARR CONTAINS 1 ELEMENT FOR EACH ACTUAL LOGIC GROUP
AADD(LOGICARR, SUBGRARR)
SUBGRARR := {}
ENDIF
CURLG := VAL(LOGIC_GR)
SUBGR := 1
LASTSUBGR := 1
LASTLG := LOGIC_GR
ENDIF
ENDIF
IF SUBGR <> LASTSUBGR
** CONTAINS 1 ELEMENT FOR EACH SUB GROUP (1 OR MORE PER LOGIC GR)
** EACH SUBGROUP ELEMENT WILL CONTAIN ALL RULES FOR THAT SUBGR
AADD(SUBGRARR, {CURRULEPACK, LASTLG} )
CURRULEPACK := {}
LASTSUBGR := SUBGR
LASTLG := LOGIC_GR
ENDIF
AADD(CURRULEPACK, {FIELD1, OPERATOR, FIELD2, CONT_COND, FIELD1TYPE, FIELD2TYPE, ALIAS1, ALIAS2})
SKIP 1
ENDDO
AADD(SUBGRARR, {CURRULEPACK, LASTLG} )
AADD(LOGICARR, SUBGRARR)
SELECT &SAVESEL
RETURN {RULEPARMS,LOGICARR}
ELSE
ERR_BOX('RULE CODE ' + SEEKKEY + ' was called for ', ;
'evaluation, but the RULE had NO RULE PACK ', ;
'LINE DEFINITIONS - PRESS ANY KEY TO CONTINUE ')
SELECT &SAVESEL
RETURN NIL
ENDIF
*********************************************************************
** ALL RULES PASSED HERE.
** EVALUATE THE CUST RULES FIRST, THEN THE LOAN RULES
** IF ANY HIT, RETURN .T. TO CALLING PROC (FOR ANCILLARY PROCESS)
** THE NEXT STEP WILL RECEIVE ALL RULES OF A GIVEN TYPE
FUNCTION EVALCLRULES(CLRULEARR, WHENFAIL, G_ARR, SELFILE)
LOCAL I, RESULT := {}, THISRESULT := .F., HITCUST := .F.
PRIVATE CURFILE, FIELDARR
PRIVATE FAILFUNC := WHENFAIL
PRIVATE GET_ARR := G_ARR
PRIVATE RULE_SELFILE := SELFILE
*PRIVATE SEEKVAL := SEEKKEY
CURFILE := 'C'
IF LEN(CLRULEARR[1]) > 0 // PASS WHOLE (L/C) RULE SET TO NEXT
HITCUST := EVALRULESET(CLRULEARR[1])
ENDIF // STEP (ALL CUST RULES OR ALL
IF HITCUST
RETURN .T.
ELSE
RETURN .F.
ENDIF
*********************************************************************
** ALL RULES PASSED HERE. (1ST CUST, THEN LOAN-WILL PROCESS 2 TIMES)
** EVALUATE EACH RULE SEPERATELY AND STORE RESULT IN RESULT ARRAY
** IF THE TOTAL EVALUATION IS TRUE, RETURN .T. TO CALLING FUNCTION
** THE NEXT STEP WILL EVALUATE EACH RULE AND WRITE THE GRADE RECS AS NEEDED
FUNCTION EVALRULESET(THISRULEARR)
LOCAL I, RESULT := {}, THISRESULT
FOR I := 1 TO LEN(THISRULEARR)
THISRESULT := EVAL1RULE(THISRULEARR[I]) // PASS THE WHOLE RULE TO NEXT
AADD(RESULT, THISRESULT) // STEP
IF !THISRESULT
EXIT
ENDIF
NEXT // RESULT ARR 1 ELEMENT FOR EACH
*** STRING RESULTS TOGETHER AND // RULE IN THE SET PASSED
*** EVALUATE AS A HIT OR NOT
** NOW, EVALUATE THE COMBINED RULES TO SEE IF ANY HITS
RETURNVAL := .T.
FOR I := 1 TO LEN(RESULT)
IF !RESULT[I] // THIS IS A MASSIVE "OR" (ANY FALSE => ALL FALSE)
RETURNVAL := .F.
ENDIF
NEXT
RETURN RETURNVAL // RETURNS T/F FOR ALL RULES EVALUATED
// IF ANY ONE WAS TRUE, RETURNS TRUE
*********************************************************************
** EACH RULE PASSED HERE (REGARDLESS OF TYPE)
** EVALUATE THIS ONE RULE SINGLELY AND STORE RESULT IN RESULT ARRAY
** IF THIS RULE IS A HIT, WRITE OUT THE GRADE RECORD
** THE NEXT STEP WILL EVALUATE EACH LOGIC GROUP AS REQUIRED
STATIC FUNCTION EVAL1RULE(WHOLERULE)
LOCAL I, RESULT := {}, THISRESULT, STRVAL := ''
LOCAL BAL, COLL, FACT
PRIVATE MFILE_TYPE
PRIVATE MRULE_LT
PRIVATE MAUTOGRADE
PRIVATE MRULE_DESC
PRIVATE ML2VFACTOR
MRULE_CODE := WHOLERULE[1][2]
MRULE_DESC := WHOLERULE[1][5]
RULE2CK := WHOLERULE[2]
FOR I := 1 TO LEN(RULE2CK) // ONE ELEMENT FOR EACH LOGIC GR.
THISRESULT := EVALLGGRP(RULE2CK[I]) // ONE LOGIC GROUP
AADD(RESULT, THISRESULT)
IF !THISRESULT // IF ANY LOGIC GROUP IN THE RULE IS FALSE,
RETURN .F. // THE WHOLE RULE IS A NON-HIT
ENDIF
NEXT
** NOW, EVALUATE THE COMBINED LOGIC GROUPS IN THE RULE
EVALSTR := ''
STRVAL := ''
FOR I := 1 TO LEN(RESULT)
IF RESULT[I]
STRVAL := '.T.'
ELSE
STRVAL := '.F.'
ENDIF
IF I = LEN(RESULT)
EVALSTR := EVALSTR + STRVAL
ELSE
JOINER := '.AND.'
EVALSTR := EVALSTR + STRVAL + JOINER
ENDIF
NEXT
IF EVALSTR == ''
RETURN .F.
ELSE
IF &EVALSTR .AND. FAILFUNC <> NIL
WRITEFRREC()
ENDIF
RETURN &EVALSTR // RETURNS T/F FOR ALL LOGIC GROUPS IN THE RULE
ENDIF
*********************************************************************
** EACH LOGIC GROUP PASSED HERE.
** EVALUATE LOGIC GROUP SINGLELY AND STORE RESULT IN RESULT ARRAY
** IF COMBINATION OF LOGIC GROUPS HITS, RETURN .T. TO CALLING FUNCTION
** THE NEXT STEP WILL EVALUATE EACH SUB GROUP AS REQUIRED
STATIC FUNCTION EVALLGGRP(LGGROUP)
LOCAL I, RESULT := {}, THISRESULT
LOCAL EVALSTR, JOINER, STRVAL
FOR I := 1 TO LEN(LGGROUP) // ONE ELEMENT FOR EACH LOGIC GROUP
THISRESULT := EVALSUB(LGGROUP[I]) // PASS EACH SUBGROUP
AADD(RESULT, THISRESULT)
NEXT
** NOW, EVALUATE THE COMBINED SUB GROUPS IN THE LOGIC GROUP
EVALSTR := ''
STRVAL := ''
FOR I := 1 TO LEN(RESULT)
IF RESULT[I]
STRVAL := '.T.'
ELSE
STRVAL := '.F.'
ENDIF
IF I = 1
EVALSTR := EVALSTR + STRVAL
ELSE
IF ALLTRIM(LGGROUP[I,2]) = 'OR' // THE LOGIC GROUP VALUE
JOINER := '.OR.'
ELSE
JOINER := '.AND.'
ENDIF
EVALSTR := EVALSTR + JOINER + STRVAL
ENDIF
NEXT
RETURN &EVALSTR // RETURNS T/F FOR ALL SUBGROUPS IN THE LOGIC GR.
*********************************************************************
** EACH SUB-LOGIC-GROUP PASSED HERE.
** EVALUATE SUB-GROUP SINGLELY AND STORE RESULT IN RESULT ARRAY
** IF COMBINATION OF SUB-LOGIC GROUPS HITS, RETURN .T. TO CALLING FUNCTION
** THE NEXT STEP WILL EVALUATE EACH LINE ITEM AS REQUIRED
STATIC FUNCTION EVALSUB(TOTSUBGROUP)
LOCAL I, RESULT := {}, THISRESULT
LOCAL EVALSTR, JOINER, STRVAL := '', CURLGVAL
SUBGROUP := TOTSUBGROUP[1]
CURLGVAL := TOTSUBGROUP[2]
FOR I := 1 TO LEN(SUBGROUP) // ONE ELEMENT FOR EACH LINE ITEM
THISRESULT := EVALLINE(SUBGROUP[I]) // PASS EACH LINE ITEM
AADD(RESULT, {THISRESULT, SUBGROUP[I,4]}) // STORE THE CONT_COND W/LINE LI
NEXT
** NOW, EVALUATE THE SUB LOGIC GROUP
EVALSTR := ''
FOR I := 1 TO LEN(RESULT)
IF RESULT[I,1]
STRVAL := '.T.'
ELSE
STRVAL := '.F.'
ENDIF
IF I = LEN(RESULT)
EVALSTR := EVALSTR + STRVAL
ELSE
IF ALLTRIM(RESULT[I,2]) = 'OR'
JOINER := '.OR.'
ELSE
JOINER := '.AND.'
ENDIF
EVALSTR := EVALSTR + STRVAL + JOINER
ENDIF
NEXT
RETURN &EVALSTR // RETURNS T/F FOR ALL LINES IN SUBGROUP
*********************************************************************
** EACH LINE OF THE FIELD COMPARISON RULE MADE IT TO HERE.
** EVALUATE THE LINE TO THE ACTUAL DATA IN THE PERMCUST/PERMLOAN
** THEN EVALUATE THE RESULT AND RETURN .T. IF THE RULE IS TRUE FOR DATA
** THIS FUNCTION EVALUATES DATA IN THE RECORD AND CALCULATES THE T/F
** VALUE BASED ON THE RULE DEFINITION.
**********************************
STATIC FUNCTION EVALLINE(LINEITEM)
LOCAL I, RESULT := {}, THISRESULT, REPVAR1, REPVAR2, OPER, CC, ELEM
LOCAL MFIELD, SAVESEL := SELECT()
PRIVATE AL1 // ALIAS1 := ALLTRIM(LINEITEM[7]
PRIVATE AL2 // ALIAS2 := ALLTRIM(LINEITEM[8]
PRIVATE LVAR1 := ''
** THIS VERSION KNOWS WHICH DATABASES TO LOOK AT BASED ON THE FILETYPE
** THE SURVEY VERSION WILL HAVE TO SELECT AND SEEK ON THE FLY!
REPVAR1 := ALLTRIM(LINEITEM[1])
REPTYPE1 := ALLTRIM(LINEITEM[5])
IF REPTYPE1 = 'C'
REPVAR1 = ALLTRIM( STRTRAN(REPVAR1, '"', '') )
ENDIF
OPER := LINEITEM[2]
REPVAR2 := ALLTRIM(LINEITEM[3])
REPTYPE2 := ALLTRIM(LINEITEM[6])
REPALIAS1 := ALLTRIM(LINEITEM[7])
REPALIAS2 := ALLTRIM(LINEITEM[8])
LVAR1 = ''
LVAR2 = ''
CC := LINEITEM[4]
IF EMPTY(REPTYPE1) .OR. EMPTY(REPTYPE2)
ERR_BOX('ERROR DURING RULE EVALUATION - EMPTY FIELDTYPE ' , ;
' The line in error reads as follows ', ;
REPVAR1 + ' ' + OPER + ' ' + REPALIAS2 + ' '+ REPVAR2 , ;
' PLEASE CORRECT AND RE-RUN THIS PROCESS')
RETURN .F.
ENDIF
// determine value of 1st field to compare
// IF IT IS A RANCH SLIDER, THEN REVERSE THE HEIGHT AND WIDTH
IF REPVAR1 = 'WIDTH' .OR. REPVAR1 = 'HEIGHT'
ELEM = ASCAN(GET_ARR, {|X| ALLTRIM(X[1]) == 'RANCH SLID' })
IF ELEM > 0 .AND. ALLTRIM(GET_ARR[ELEM,4]) == 'RANCH SLIDER'
IF REPVAR1 = 'WIDTH'
REPVAR1 = 'HEIGHT'
ELSE
REPVAR1 = 'WIDTH'
ENDIF
ENDIF
ENDIF
IF REPTYPE1 = 'S'
LVAR1 = SPECFLD_VALUE( REPVAR1, RULE_SELFILE )
ELSE
IF REPTYPE1 = 'A'
ELEM = ASCAN(GET_ARR, {|X| ALLTRIM(X[1]) == ALLTRIM(REPVAR1) })
IF ELEM > 0
LVAR1 = GET_ARR[ELEM,4] //USER_RESP
IF GET_ARR[ELEM,2]$'T'
REPTYPE1 := 'C'
// STRIP THE "V" OFF THE 1ST BYTE OF THE RESULT
IF SUBS(LVAR1,1,1)$'V' .AND. ISDIGIT(SUBS(LVAR1,2,1))
LVAR1 := SUBS(LVAR1,2)
ENDIF
ELSE
IF GET_ARR[ELEM,2]$'UC'
REPTYPE1 := 'N'
LVAR1 := VAL(LVAR1)
ELSE
REPTYPE1 := 'C'
ENDIF
ENDIF
ELSE
ERR_BOX('ERROR DURING EVALUATION OF RULE - (' + MRULE_CODE + ')',;
' ATT_CODE SPECIFIED - NOT FOUND' , ;
' The ATT CODE WAS "' + REPVAR1 + '"' , ;
' The line in error reads as follows ' , ;
REPVAR1 + ' ' + OPER + ' ' + REPALIAS2 + ' '+ REPVAR2 , ;
' PLEASE CORRECT LINE ITEM - '+STR((CUR_OL)->LINE_NUM)+'/'+(CUR_OL)->PROD_CODE)
ENDIF
ELSE
LVAR1 = ''
ERR_BOX('ERROR DURING RULE EVALUATION - INVALID FIELDTYPE1 ' , ;
' The VALUE TO LOOK FOR was ' + REPVAR1 , ;
' The line in error reads as follows ', ;
REPVAR1 + ' ' + OPER + ' ' + REPALIAS2 + ' '+ REPVAR2 , ;
' PLEASE CORRECT AND RE-RUN THIS PROCESS')
RETURN .F.
ENDIF
ENDIF
IF EMPTY(REPTYPE1) .OR. EMPTY(REPTYPE2)
ERR_BOX('ERROR DURING RULE EVALUATION - EMPTY FIELDTYPE ' , ;
' The ATT CODE WAS ' + REPVAR1 + ' or ' + REPVAR2 , ;
' The line in error reads as follows ', ;
REPVAR1 + ' ' + OPER + ' ' + REPALIAS2 + ' '+ REPVAR2 , ;
' PLEASE CORRECT AND RE-RUN THIS PROCESS')
RETURN .F.
ENDIF
IF REPVAR2 = '"CATEGORY"' .OR. REPVAR2 = '"MODEL"' .OR. REPVAR2 = '"SYSTEM"' ;
.OR. REPVAR2 = '"MODEL "' .OR. REPVAR2 = '"SYSTEM "'
LVAR2 = ALLTRIM(REPALIAS2)
REPTYPE2 := 'C'
ELSE
LVAR2 := REPVAR2
// CHECK FOR NUMERIC
DO CASE
CASE REPTYPE2 = 'S' //** P3N - 6/29/01
LVAR2 := SPECFLD_VALUE(REPVAR2, RULE_SELFILE) //** P3N - 6/29/01
CASE REPTYPE2 = 'N'
LVAR2 = VAL(LVAR2)
CASE REPTYPE2 = 'C'
LVAR2 = ALLTRIM(STRTRAN(LVAR2,'"', ' '))
CASE REPTYPE2 = 'A'
FOR I = 1 TO LEN(GET_ARR)
IF ALLTRIM(GET_ARR[I,1]) == REPVAR2
LVAR2 = GET_ARR[I,4] //USER_RESP
IF GET_ARR[ELEM,2]$'T'
REPTYPE1 := 'C'
// STRIP THE "V" OFF THE 1ST BYTE OF THE RESULT
IF SUBS(LVAR2,1,1)$'V' .AND. ISDIGIT(SUBS(LVAR2,2,1))
LVAR2 := SUBS(LVAR2,2)
ENDIF
ELSE
IF GET_ARR[I,2]$'UC'
REPTYPE2 := 'N'
LVAR2 := VAL(LVAR2)
ELSE
REPTYPE2 := 'C'
ENDIF
ENDIF
EXIT
ENDIF
NEXT
OTHERWISE
ERR_BOX('ERROR DURING RULE EVALUATION - INVALID FIELDTYPE2 ' , ;
' The line in error reads as follows ', ;
REPVAR1 + ' ' + OPER + ' ' + REPALIAS2 + ' '+ REPVAR2 , ;
' PLEASE CORRECT AND RE-RUN THIS PROCESS')
RETURN .F.
ENDCASE
ENDIF
// LVAR2 IS SET TO EITHER CHARSTR RESPONSE, NUMERIC OR A BLANK
// MAKE LVAR/REPTYPE1 THE SAME AS TYPE2
IF VALTYPE(LVAR1) = 'C'
DO CASE
CASE REPTYPE2 = 'N'
LVAR1 := VAL(LVAR1) // FORCE TO NUMERIC VALUE IN LVAR1
REPTYPE1 := 'N'
CASE REPTYPE2 = 'C' // KEEP AS CHAR TO MATCH LVAR2
REPTYPE1 := 'C'
CASE REPTYPE2 = ' ' // MAKE BOTH CHARACTER SINCE LVAR1 WAS CHAR
REPTYPE1 := 'C'
REPTYPE2 := 'C'
ENDCASE
ELSE
IF VALTYPE(LVAR1) = 'N'
DO CASE
CASE REPTYPE2 = 'N' // KEEP AS NUMERIC SAME AS LVAR1 TYPE
REPTYPE1 := 'N'
CASE REPTYPE2 = 'C' // FORCE LVAR2 TO NUMERIC TO MATCH LVAR1
LVAR2 := VAL(LVAR2)
REPTYPE1 := 'N'
REPTYPE2 := 'N'
CASE REPTYPE2 = ' '
LVAR2 := 0
REPTYPE1 := 'N' // MAKE BOTH NUMERIC TO MATCH LVAR1 TYPE
REPTYPE2 := 'N'
ENDCASE
ENDIF
ENDIF
IF REPTYPE1 = 'C'
LVAR1 = ALLTRIM( STRTRAN(LVAR1, '"', '') )
ENDIF
IF REPTYPE2 = 'C'
LVAR2 = ALLTRIM( STRTRAN(LVAR2, '"', '') )
ENDIF
VTYPE1 := VALTYPE(LVAR1)
VTYPE2 := VALTYPE(LVAR2)
** WHEN COMPARING CHARACTER FIELDS, FORCE TO UPPER CASE
IF VTYPE1 = 'C'
LVAR1 := UPPER(ALLTRIM(LVAR1))
IF LEN(LVAR1) = 0
LVAR1 := ' '
ENDIF
ENDIF
IF VTYPE2 = 'C'
LVAR2 := UPPER(ALLTRIM(LVAR2))
IF LEN(LVAR2) = 0
LVAR2 := ' '
ENDIF
ENDIF
IF LEN(TRIM(OPER)) > 1
DO CASE
CASE OPER = 'LT'
OPER := '< '
CASE OPER = 'GT'
OPER := '> '
CASE OPER = 'EQ'
OPER := '= '
CASE OPER = 'LE'
OPER := '<='
CASE OPER = 'GE'
OPER := '>='
CASE OPER = 'NE'
OPER := '<>'
ENDCASE
ENDIF
CALCSTR := 'LVAR1 ' + OPER + ' LVAR2'
SELECT (SAVESEL)
RETURN &CALCSTR
*******************************************************
**************************************************
STATIC FUNCTION EVALFLD(REPVAR, REPTYPE, REPALIAS)
IF SUBSTR(REPVAR,1) = '"'
REPVAR := ALLTRIM(STRTRAN(REPVAR, '"', ''))
RETURN ALLTRIM(REPVAR)
ELSE
IF REPTYPE$'N'
RETURN VAL(REPVAR)
ELSE
IF REPVAR = 'CURDATE'
RETURN CURDATE
ELSE
IF REPTYPE$'F'
*-*****************************
*-HERE, YOU HAVE TO BE SURE THAT THE ALIAS IS OPEN AND SEEKED
*-ON THE PROPER RECORD. THEN RETSTR := TRIM(AL1 OR AL2) + '->' + REPVAR
///////CHECK FOR CUSTOMER RECORD EXIST IN ALIAS,
FOR L = 1 TO LEN(ALIAS_LIST)
IF TRIM(ALIAS_LIST[L,1]) = TRIM(REPALIAS) .AND. ALIAS_LIST[L,2]
REPVAR := REPALIAS + '->' + REPVAR
RETURN &REPVAR
ENDIF
NEXT
RETURN NIL
ELSE
IF REPTYPE$'D'
RETURN CTOD(REPVAR)
ELSE
IF REPTYPE$'C'
RETURN ALLTRIM( STRTRAN(REPVAR, '"', '') )
ELSE
RETURN NIL
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
*******************************************************
STATIC PROCEDURE UPDATENUMFAIL(MRULE_CODE)
LOCAL I, X, SEEKKEY
SELECT SURV_HIT
SEEKKEY := MRULE_CODE
SEEK SEEKKEY
DO WHILE RULE_CODE = MRULE_CODE .AND. !EOF()
X := 0
SEEKKEY := RULE_CODE + LOCATION
SELECT RULEHIT
SEEK SEEKKEY
DO WHILE RULE_CODE + LOCATION == SEEKKEY
X ++
SKIP 1
ENDDO
SELECT SURV_HIT
REPLACE NUM_FAIL WITH X
SKIP 1
ENDDO
RETURN
*******************************************************
STATIC PROCEDURE WRITEFRREC
*** WRITE THE GRADE FAIL RECORD HERE
SAVESEL := SELECT()
SELECT RULEHIT
CLNUM := MASTER->LOCATION
SEEKKEY := STR(DESCEND(CURDATE)) + MRULE_CODE ;
+ SUBSTR(CLNUM+SPACE(20), 1, 20) ;
+ MRULE_CODE
SEEK SEEKKEY
IF !FOUND()
ADD_REC(3)
REPLACE FAIL_DATE WITH CURDATE
REPLACE RULE_CODE WITH MRULE_CODE
REPLACE LOCATION WITH CLNUM
* REPLACE FAIL_RFILE WITH MFILE_TYPE
REPLACE FAIL_RCODE WITH MRULE_CODE
ENDIF
SELECT &SAVESEL
RETURN
***************************************
FUNCTION CK_IF_NUMERIC(CKFLD)
LOCAL GOODVAR := '', I, CKCHAR
LOCAL REPVAR := ALLTRIM(CKFLD) // -- FIELD TO VALIDATE
LOCAL NUMDEC := 0
** CHECK FOR ALPHA FIELD (!NUMERIC)
FOR I = 1 TO LEN(REPVAR)
CKCHAR := SUBSTR(REPVAR,I,1)
IF !(CKCHAR$'0123456789-.')
I := 999
ELSE
IF (CKCHAR >= CHR(48) .AND. CKCHAR <= CHR(57))
GOODVAR := GOODVAR + CKCHAR
ELSE
IF CKCHAR = '-'
IF I = 1
GOODVAR := GOODVAR + CKCHAR
ELSE
I := 999
ENDIF
ELSE
IF CKCHAR = '.'
NUMDEC ++
IF NUMDEC = 1
GOODVAR := GOODVAR + CKCHAR
ELSE
I := 999
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
NEXT
***IF >= 999, THEN IT WAS AN ALPHA LITERAL STRING
***IF < 999, THEN IT WAS A NUMERIC VALUE
IF I < 999
RETURN .T.
ELSE
RETURN .F.
ENDIF
***********************************************
****THIS FUNCTION WILL CHECK FOR THE VALUE ****
** IN THE SPECIAL FIELDS LIST. IF PASSED A UPDATE
** FIELDNAME, THE SPEC_FLDS LOOKUP WILL UPDATE USERFILE2
**
***********************************************
FUNCTION SPEC_FLD(MNAME, WHEREFROM)
// CHECK FOR MNAME IN SPECIAL FIELD LIST
STATIC SPEC_R_FLDARR
STATIC SPEC_C_FLDARR
STATIC SPEC_M_FLDARR
IF WHEREFROM = NIL
WHEREFROM := 'RULE'
ENDIF
IF SPEC_R_FLDARR = NIL
SPEC_R_FLDARR := SPECIAL_FIELDS(.F., 'RULE') // NO LOOKUP, BUT GET ARRAY
ENDIF
IF SPEC_C_FLDARR = NIL
SPEC_C_FLDARR := SPECIAL_FIELDS(.F., 'CUT') // NO LOOKUP, BUT GET ARRAY
ENDIF
IF SPEC_M_FLDARR = NIL
SPEC_M_FLDARR := SPECIAL_FIELDS(.F., 'MISC') // NO LOOKUP, BUT GET ARRAY
ENDIF
IF WHEREFROM = 'RULE' .AND. ASCAN(SPEC_R_FLDARR, {|X| TRIM(X)==TRIM(MNAME)}) > 0
RETURN .T.
ELSE
IF WHEREFROM = 'CUT' .AND. ASCAN(SPEC_C_FLDARR, {|X| TRIM(X)==TRIM(MNAME)}) > 0
RETURN .T.
ELSE
IF WHEREFROM = 'MISC' .AND. ASCAN(SPEC_M_FLDARR, {|X| TRIM(X)==TRIM(MNAME)}) > 0
RETURN .T.
ELSE
RETURN .F.
ENDIF
ENDIF
ENDIF
***********************************************
// CHECKS TO SEE IF THE FIELD IS A SPECIAL FIELD
***********************************************
FUNCTION RULE_FIELD(UPDATE_FIELDNAME)
**FUNCTION FLD_ERR1(MNAME)
// CALLED DURING RULE PACK SETUP
LOCAL RESULT, VERIFY_VAL, M2
LOCAL WHCHFLD := RIGHT( ALLTRIM(UPDATE_FIELDNAME) ,1)
LOCAL REPTYPEFLD := 'FIELD' + WHCHFLD + 'TYPE'
LOCAL SAVESEL := SELECT()
VERIFY_VAL := &UPDATE_FIELDNAME
IF LASTKEY() = -9 // F10 KEY - NO NEED TO CHECK THIS AGAIN!
RETURN .T.
ENDIF
// CHECK SPECIAL FIELD LIST 1ST
IF EMPTY(VERIFY_VAL) .AND. WHCHFLD = '1'
ERR_BOX('You MUST Specify an ATTRIBUTE')
RETURN .F.
ENDIF
IF SPEC_FLD(VERIFY_VAL)
REPTYPEFLD := 'FIELD' + WHCHFLD + 'TYPE'
REPLACE &REPTYPEFLD WITH 'S'
RETURN .T.
ELSE
// BRING UP THE SPECIAL FIELD LIST
IF UPDATE_FIELDNAME = NIL
? 'ERROR IN RULE_FIELD IN CGWRULE '
WAIT
RETURN .F.
ENDIF
RESULT = SPECIAL_FIELDS(.T., 'RULE') // LOOK IT UP
IF !EMPTY(RESULT)
** SAVESEL = SELECT()
** SELECT USERFILE2
SELECT (SAVESEL)
****REPLACE FIELD1 WITH RESULT
REPLACE &UPDATE_FIELD WITH RESULT
REPLACE &REPTYPEFLD WITH 'S'
** SELECT(SAVESEL)
RETURN .T.
ELSE
IF VAL_LOOKUP(FIELD1, 'ATTRIBUTES', , {'ATT_CODE', 'DESC'} , 'Y',;
.F., STR(SAVESEL,2) + '->FIELD1' ,{4,20,17,52})
***** .F., 'USERFILE2->FIELD1' ,{4,20,17,52})
REPLACE &REPTYPEFLD WITH 'A'
RETURN .T.
ELSE
IF WHCHFLD = '1'
M2 = ''
ELSE
M2 = 'or a CHARACTER STRING, VALUE, or BLANK'
ENDIF
ERR_BOX('INVALID ENTRY - SPECIFY AN ATTRIBUTE ', ;
M2,;
' PLEASE RE-ENTER')
ENDIF
ENDIF
ENDIF
? 'ERROR IN RULE_FIELD IN CGWRULE '
WAIT
RETURN .F.
**********************************************************
FUNCTION PE_SPECFLD(FLD2CK)
LOCAL SAVESEL := SELECT()
LOCAL VERIFY_VAL, RESULT
VERIFY_VAL := &FLD2CK
IF LASTKEY() = K_F10
RETURN .T.
ENDIF
IF SPEC_FLD(VERIFY_VAL)
RETURN .T.
ELSE
RESULT = SPECIAL_FIELDS(.T., 'RULE') // LOOK IT UP
IF !EMPTY(RESULT)
SELECT USERFILE2
REPLACE &FLD2CK WITH RESULT
SELECT(SAVESEL)
RETURN .T.
ENDIF
ENDIF
RETURN .F.
******************************************************************
*********************************************************************

Reference in New Issue View Git Blame Copy Permalink