Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m
===================================================================
--- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m	(revision 623)
@@ -1,86 +1,85 @@
-IVMZ7CE	;TDM,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 12/4/07 2:56pm
-	;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
-	;
-	; Eligibility Consistency Checks
-	; This routine checks the various elements of service information
-	; prior to building a Z07 record.  Any tests which fail consistency
-	; check will be saved to the ^DGIN(38.6 record for the patient.
-	;
-	; Must be called from entry point
-	Q
-	;
-EN(DFN,DGP)	; entry point.  Patient DFN is sent from calling routine.
-	; initialize working variables
-	N RULE,Y,X,FILERR
-	;
-	; loop through rules in INCONSISTENT DATA ELEMENTS file.
-	; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07
-	; CHECKS fields are turned ON.
-	;
-	; ***NOTE loop boundary (401-413) must be changed if rule numbers
-	; are added ***
-	F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D
-	. S Y=^DGIN(38.6,RULE,0)
-	. I '$P(Y,U,5),$P(Y,U,6) D @RULE
-	I $D(FILERR) M ^TMP($J,DFN)=FILERR
-	Q
-	;
-401	; RATED INCOMPETENT INVALID
-	S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
-	Q
-	;
-402	; ELIGIBLE FOR MEDICAID INVALID
-	S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
-	Q
-	;
-403	; DT MEDICAID LAST ASKED INVALID
-	I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)=""
-	Q
-	;
-404	; INELIGIBLE REASON INVALID
-	; Note: RULE #15 in IVMZ7CR is a duplicate of this rule
-	Q
-	;
-405	; NON VETERAN ELIG CODE INVALID
-	; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
-	Q
-	;
-406	; CLAIM FOLDER NUMBER INVALID
-	S X=$P(DGP("PAT",.31),U,3)
-	I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)=""
-	Q
-	;
-407	; ELIGIBILITY STATUS INVALID
-	S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)=""
-	Q
-	;
-408	; DECLINE TO GIVE INCOME INVALID
-	; This CC removed per customer 05/08/2006 -- BAJ
-	; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)=""
-	Q
-	;
-409	; AGREE TO PAY DEDUCT INVALID
-	; this CC inactivated by DG*5.3*771
-	; 2  PENDING ADJUDICATION     MEANS TEST
-	; 6  MT COPAY REQUIRED     MEANS TEST
-	;16  GMT COPAY REQUIRED     MEANS TEST
-	I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D
-	. S X=$P(DGP("MEANS",0),U,3)
-	. I (X=2)!(X=6) S FILERR(RULE)="" Q
-	. I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)=""
-	Q
-	;
-410	; Note: RULE #404 above is a duplicate of this rule
-	Q
-	;
-411	; ENROLLMENT APP DATE INVALID
-	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)=""
-	Q
-	;
-412	; POS/ELIG CODE INVALID
-	; Note: RULE #24 in IVMZ7CR is a duplicate of this rule
-	Q
-	;
-413	; POS INVALID
-	; Note: RULE #13 in IVMZ7CR is a duplicate of this rule
-	Q
+IVMZ7CE ;TDM,BAJ - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 01/23/07
+ ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
+ ;
+ ; Eligibility Consistency Checks
+ ; This routine checks the various elements of service information
+ ; prior to building a Z07 record.  Any tests which fail consistency
+ ; check will be saved to the ^DGIN(38.6 record for the patient.
+ ;
+ ; Must be called from entry point
+ Q
+ ;
+EN(DFN,DGP) ; entry point.  Patient DFN is sent from calling routine.
+ ; initialize working variables
+ N RULE,Y,X,FILERR
+ ;
+ ; loop through rules in INCONSISTENT DATA ELEMENTS file.
+ ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07
+ ; CHECKS fields are turned ON.
+ ;
+ ; ***NOTE loop boundary (401-413) must be changed if rule numbers
+ ; are added ***
+ F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D
+ . S Y=^DGIN(38.6,RULE,0)
+ . I '$P(Y,U,5),$P(Y,U,6) D @RULE
+ I $D(FILERR) M ^TMP($J,DFN)=FILERR
+ Q
+ ;
+401 ; RATED INCOMPETENT INVALID
+ S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
+ Q
+ ;
+402 ; ELIGIBLE FOR MEDICAID INVALID
+ S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
+ Q
+ ;
+403 ; DT MEDICAID LAST ASKED INVALID
+ I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)=""
+ Q
+ ;
+404 ; INELIGIBLE REASON INVALID
+ ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule
+ Q
+ ;
+405 ; NON VETERAN ELIG CODE INVALID
+ ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
+ Q
+ ;
+406 ; CLAIM FOLDER NUMBER INVALID
+ S X=$P(DGP("PAT",.31),U,3)
+ I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)=""
+ Q
+ ;
+407 ; ELIGIBILITY STATUS INVALID
+ S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)=""
+ Q
+ ;
+408 ; DECLINE TO GIVE INCOME INVALID
+ ; This CC removed per customer 05/08/2006 -- BAJ
+ ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)=""
+ Q
+ ;
+409 ; AGREE TO PAY DEDUCT INVALID
+ ; 2  PENDING ADJUDICATION     MEANS TEST
+ ; 6  MT COPAY REQUIRED     MEANS TEST
+ ;16  GMT COPAY REQUIRED     MEANS TEST
+ I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D
+ . S X=$P(DGP("MEANS",0),U,3)
+ . I (X=2)!(X=6) S FILERR(RULE)="" Q
+ . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)=""
+ Q
+ ;
+410 ; Note: RULE #404 above is a duplicate of this rule
+ Q
+ ;
+411 ; ENROLLMENT APP DATE INVALID
+ 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)=""
+ Q
+ ;
+412 ; POS/ELIG CODE INVALID
+ ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule
+ Q
+ ;
+413 ; POS INVALID
+ ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule
+ Q
