| 1 | IVMZ7CD ;CKN,BAJ - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006
|
|---|
| 2 | ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
|
|---|
| 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 | ;
|
|---|
| 13 | EN(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 | ;
|
|---|
| 35 | 301 ; 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 | ;
|
|---|
| 43 | 302 ; 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 | ;
|
|---|
| 51 | 303 ; 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 | ;
|
|---|
| 58 | 304 ; 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 | ;
|
|---|
| 66 | 305 ; 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 | ;
|
|---|
| 71 | 306 ; VALID SSN/PSEUDO SSN REQUIRED
|
|---|
| 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 | ;
|
|---|
| 85 | 307 ; PSEUDO SSN REASON REQUIRED
|
|---|
| 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 | ;
|
|---|
| 94 | 308 ; 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 | ;
|
|---|
| 99 | 309 ; 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 | ;
|
|---|
| 112 | 310 ; 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 | ;
|
|---|
| 118 | 311 ; 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 | ;
|
|---|
| 124 | 312 ; 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 | ;
|
|---|
