- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m
r613 r623 1 IVMZ7CE ;TDM,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 12/4/07 2:56pm 2 ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 3 ; 4 ; Eligibility Consistency Checks 5 ; This routine checks the various elements of service information 6 ; prior to building a Z07 record. Any tests which fail consistency 7 ; check will be saved to the ^DGIN(38.6 record for the patient. 8 ; 9 ; Must be called from entry point 10 Q 11 ; 12 EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. 13 ; initialize working variables 14 N RULE,Y,X,FILERR 15 ; 16 ; loop through rules in INCONSISTENT DATA ELEMENTS file. 17 ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 18 ; CHECKS fields are turned ON. 19 ; 20 ; ***NOTE loop boundary (401-413) must be changed if rule numbers 21 ; are added *** 22 F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D 23 . S Y=^DGIN(38.6,RULE,0) 24 . I '$P(Y,U,5),$P(Y,U,6) D @RULE 25 I $D(FILERR) M ^TMP($J,DFN)=FILERR 26 Q 27 ; 28 401 ; RATED INCOMPETENT INVALID 29 S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" 30 Q 31 ; 32 402 ; ELIGIBLE FOR MEDICAID INVALID 33 S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" 34 Q 35 ; 36 403 ; DT MEDICAID LAST ASKED INVALID 37 I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" 38 Q 39 ; 40 404 ; INELIGIBLE REASON INVALID 41 ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule 42 Q 43 ; 44 405 ; NON VETERAN ELIG CODE INVALID 45 ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule 46 Q 47 ; 48 406 ; CLAIM FOLDER NUMBER INVALID 49 S X=$P(DGP("PAT",.31),U,3) 50 I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" 51 Q 52 ; 53 407 ; ELIGIBILITY STATUS INVALID 54 S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" 55 Q 56 ; 57 408 ; DECLINE TO GIVE INCOME INVALID 58 ; This CC removed per customer 05/08/2006 -- BAJ 59 ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" 60 Q 61 ; 62 409 ; AGREE TO PAY DEDUCT INVALID 63 ; this CC inactivated by DG*5.3*771 64 ; 2 PENDING ADJUDICATION MEANS TEST 65 ; 6 MT COPAY REQUIRED MEANS TEST 66 ;16 GMT COPAY REQUIRED MEANS TEST 67 I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D 68 . S X=$P(DGP("MEANS",0),U,3) 69 . I (X=2)!(X=6) S FILERR(RULE)="" Q 70 . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" 71 Q 72 ; 73 410 ; Note: RULE #404 above is a duplicate of this rule 74 Q 75 ; 76 411 ; ENROLLMENT APP DATE INVALID 77 I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" 78 Q 79 ; 80 412 ; POS/ELIG CODE INVALID 81 ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule 82 Q 83 ; 84 413 ; POS INVALID 85 ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule 86 Q 1 IVMZ7CE ;TDM,BAJ - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 01/23/07 2 ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 3 ; 4 ; Eligibility Consistency Checks 5 ; This routine checks the various elements of service information 6 ; prior to building a Z07 record. Any tests which fail consistency 7 ; check will be saved to the ^DGIN(38.6 record for the patient. 8 ; 9 ; Must be called from entry point 10 Q 11 ; 12 EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. 13 ; initialize working variables 14 N RULE,Y,X,FILERR 15 ; 16 ; loop through rules in INCONSISTENT DATA ELEMENTS file. 17 ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 18 ; CHECKS fields are turned ON. 19 ; 20 ; ***NOTE loop boundary (401-413) must be changed if rule numbers 21 ; are added *** 22 F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D 23 . S Y=^DGIN(38.6,RULE,0) 24 . I '$P(Y,U,5),$P(Y,U,6) D @RULE 25 I $D(FILERR) M ^TMP($J,DFN)=FILERR 26 Q 27 ; 28 401 ; RATED INCOMPETENT INVALID 29 S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" 30 Q 31 ; 32 402 ; ELIGIBLE FOR MEDICAID INVALID 33 S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" 34 Q 35 ; 36 403 ; DT MEDICAID LAST ASKED INVALID 37 I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" 38 Q 39 ; 40 404 ; INELIGIBLE REASON INVALID 41 ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule 42 Q 43 ; 44 405 ; NON VETERAN ELIG CODE INVALID 45 ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule 46 Q 47 ; 48 406 ; CLAIM FOLDER NUMBER INVALID 49 S X=$P(DGP("PAT",.31),U,3) 50 I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" 51 Q 52 ; 53 407 ; ELIGIBILITY STATUS INVALID 54 S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" 55 Q 56 ; 57 408 ; DECLINE TO GIVE INCOME INVALID 58 ; This CC removed per customer 05/08/2006 -- BAJ 59 ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" 60 Q 61 ; 62 409 ; AGREE TO PAY DEDUCT INVALID 63 ; 2 PENDING ADJUDICATION MEANS TEST 64 ; 6 MT COPAY REQUIRED MEANS TEST 65 ;16 GMT COPAY REQUIRED MEANS TEST 66 I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D 67 . S X=$P(DGP("MEANS",0),U,3) 68 . I (X=2)!(X=6) S FILERR(RULE)="" Q 69 . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" 70 Q 71 ; 72 410 ; Note: RULE #404 above is a duplicate of this rule 73 Q 74 ; 75 411 ; ENROLLMENT APP DATE INVALID 76 I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" 77 Q 78 ; 79 412 ; POS/ELIG CODE INVALID 80 ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule 81 Q 82 ; 83 413 ; POS INVALID 84 ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule 85 Q
Note:
See TracChangeset
for help on using the changeset viewer.
