source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m@ 1166

Last change on this file since 1166 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1IVMZ7CE ;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 ;
12EN(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 ;
28401 ; RATED INCOMPETENT INVALID
29 S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
30 Q
31 ;
32402 ; ELIGIBLE FOR MEDICAID INVALID
33 S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
34 Q
35 ;
36403 ; 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 ;
40404 ; INELIGIBLE REASON INVALID
41 ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule
42 Q
43 ;
44405 ; NON VETERAN ELIG CODE INVALID
45 ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
46 Q
47 ;
48406 ; 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 ;
53407 ; 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 ;
57408 ; 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 ;
62409 ; 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 ;
73410 ; Note: RULE #404 above is a duplicate of this rule
74 Q
75 ;
76411 ; 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 ;
80412 ; POS/ELIG CODE INVALID
81 ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule
82 Q
83 ;
84413 ; POS INVALID
85 ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule
86 Q
Note: See TracBrowser for help on using the repository browser.