source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m@ 1140

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

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1IVMZ7CD ;CKN,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006
2 ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
3 ;
4 ; Demographic Consistency Checks
5 ; This routine will be called from driver routine and it checks the
6 ; various elements of Person demographic information prior to
7 ; building a Z07 record. Any test which fails consistency check will
8 ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person.
9 ;
10 ;It is all facade
11 Q
12 ;
13EN(DFN,DGP,DGSD) ;Entry point
14 ; input: DFN - Patient IEN
15 ; DGP - Patient data array
16 ; DGSD - Spouse and Dependent data array
17 ; output: ^TMP($J,DFN,RULE) global
18 ; DFN - Patient IEN
19 ; RULE - Consistency rule #
20 ;initializing variables
21 N RULE,Y,X,FILERR
22 ;
23 ; loop through rules in INCONSISTENT DATA ELEMENTS file.
24 ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07
25 ; CHECKS fields are turned ON.
26 ;
27 ; ***NOTE loop boundary (301-311) must be changed if rule numbers
28 ; are added ***
29 F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D
30 . S Y=^DGIN(38.6,RULE,0)
31 . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE
32 I $D(FILERR) M ^TMP($J,DFN)=FILERR
33 Q
34 ;
35301 ; PERSON LASTNAME REQUIRED
36 S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)=""
37 I '$D(DGSD("DEP")) Q
38 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
39 . S X=$P(DGSD("DEP",RIEN,0),U)
40 . S X=$P(X,",") I X="" S FILERR(RULE)=""
41 Q
42 ;
43302 ; DATE OF BIRTH REQUIRED - Duplicate with #4
44 Q ;This tag needs to be removed after its placement in IVMZ7CR
45 S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)=""
46 I '$D(DGSD("DEP")) Q
47 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
48 . S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)=""
49 Q
50 ;
51303 ; GENDER REQUIRED
52 S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)=""
53 I '$D(DGSD("DEP")) Q
54 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
55 . S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)=""
56 Q
57 ;
58304 ; GENDER INVALID
59 S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)=""
60 I '$D(DGSD("DEP")) Q
61 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
62 . S X=$P(DGSD("DEP",RIEN,0),U,2)
63 . I X]"",X'="M",X'="F" S FILERR(RULE)=""
64 Q
65 ;
66305 ; VETERAN SSN MISSING - Duplicate with #7
67 Q ;This tag needs to be removed after its placement in IVMZ7CR
68 S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)=""
69 Q
70 ;
71306 ; VALID SSN/PSEUDO SSN REQUIRED, turned off with DG*5.3*771
72 N Z
73 S X=$P($G(DGP("PAT",0)),U,9)
74 Q:X="" ;quit if no SSN
75 Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo
76 I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero
77 S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same
78 I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros
79 I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros
80 I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros
81 I X=123456789 S FILERR(RULE)="" ;SSN is 123456789
82 I X>728999999 S FILERR(RULE)="" ;SSN is greater than 728999999
83 Q
84 ;
85307 ; PSEUDO SSN REASON REQUIRED, turned off with DG*5.3*771
86 S X=$P($G(DGP("PAT",0)),U,9)
87 I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)=""
88 I '$D(DGSD("DEP")) Q
89 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
90 . S X=$P(DGSD("DEP",RIEN,0),U,9)
91 . I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)=""
92 Q
93 ;
94308 ; DATE OF DEATH BEFORE DOB
95 S X=$P($G(DGP("PAT",.35)),U) I X']"" Q
96 I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)=""
97 Q
98 ;
99309 ; PATIENT RELATIONSHIP INVALID
100 N DEPSEX,RELSEX,DEPREL
101 I '$D(DGSD("DEP")) Q
102 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
103 . S DEPREL=$G(DGSD("DEP",RIEN))
104 . I DEPREL="" S FILERR(RULE)="" Q
105 . I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q
106 . S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2)
107 . S RELSEX=$P(^DG(408.11,DEPREL,0),U,3)
108 . I RELSEX="E" Q ;Gender for relation can be either
109 . I DEPSEX'=RELSEX S FILERR(RULE)=""
110 Q
111 ;
112310 ; DEPENDENT EFF. DATE REQUIRED
113 I '$D(DGSD("DEP")) Q
114 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
115 . S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)=""
116 Q
117 ;
118311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16
119 Q ;This tag needs to be removed after its placement in IVMZ7CR
120 S X=$P($G(DGP("PAT",.35)),U)
121 I X]"",X>$$NOW^XLFDT() S FILERR(RULE)=""
122 Q
123 ;
124312 ; PERSON MUST HAVE NATIONAL ICN
125 I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN
126 I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN
127 Q
128 ;
Note: See TracBrowser for help on using the repository browser.