IVMZ7CD ;CKN,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 8/1/08 1:54pm
;;2.0;INCOME VERIFICATION MATCH;**105,127,132,115**;OCT 21,1994;Build 28
;
; Demographic Consistency Checks
; This routine will be called from driver routine and it checks the
; various elements of Person demographic information prior to
; building a Z07 record. Any test which fails consistency check will
; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person.
;
Q
;
EN(DFN,DGP,DGSD) ;Entry point
; input: DFN - Patient IEN
; DGP - Patient data array
; DGSD - Spouse and Dependent data array
; output: ^TMP($J,DFN,RULE) global
; DFN - Patient IEN
; RULE - Consistency rule #
;initializing 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 (301-311) must be changed if rule numbers
; are added ***
F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D
. S Y=^DGIN(38.6,RULE,0)
. I $P(Y,"^",6) D @RULE
I $D(FILERR) M ^TMP($J,DFN)=FILERR
Q
;
301 ; PERSON LASTNAME REQUIRED
S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)=""
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S X=$P(DGSD("DEP",RIEN,0),U)
. S X=$P(X,",") I X="" S FILERR(RULE)=""
Q
;
302 ; DATE OF BIRTH REQUIRED - Duplicate with #4
Q ;This tag needs to be removed after its placement in IVMZ7CR
S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)=""
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)=""
Q
;
303 ; GENDER REQUIRED
S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)=""
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)=""
Q
;
304 ; GENDER INVALID
S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)=""
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S X=$P(DGSD("DEP",RIEN,0),U,2)
. I X]"",X'="M",X'="F" S FILERR(RULE)=""
Q
;
305 ; VETERAN SSN MISSING - Duplicate with #7
Q ;This tag needs to be removed after its placement in IVMZ7CR
S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)=""
Q
;
306 ; VALID SSN/PSEUDO SSN REQUIRED, turned off with DG*5.3*771
N Z
S X=$P($G(DGP("PAT",0)),U,9)
Q:X="" ;quit if no SSN
Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo
I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero
S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same
I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros
I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros
I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros
I X=123456789 S FILERR(RULE)="" ;SSN is 123456789
Q
;
307 ; PSEUDO SSN REASON REQUIRED, turned off with DG*5.3*771
S X=$P($G(DGP("PAT",0)),U,9)
I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)=""
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S X=$P(DGSD("DEP",RIEN,0),U,9)
. I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)=""
Q
;
308 ; DATE OF DEATH BEFORE DOB
S X=$P($G(DGP("PAT",.35)),U) I X']"" Q
I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)=""
Q
;
309 ; PATIENT RELATIONSHIP INVALID
N DEPSEX,RELSEX,DEPREL
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S DEPREL=$G(DGSD("DEP",RIEN))
. I DEPREL="" S FILERR(RULE)="" Q
. I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q
. S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2)
. S RELSEX=$P(^DG(408.11,DEPREL,0),U,3)
. I RELSEX="E" Q ;Gender for relation can be either
. I DEPSEX'=RELSEX S FILERR(RULE)=""
Q
;
310 ; DEPENDENT EFF. DATE REQUIRED
I '$D(DGSD("DEP")) Q
S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
. S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)=""
Q
;
311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16
Q ;This tag needs to be removed after its placement in IVMZ7CR
S X=$P($G(DGP("PAT",.35)),U)
I X]"",X>$$NOW^XLFDT() S FILERR(RULE)=""
Q
;
312 ; PERSON MUST HAVE NATIONAL ICN
I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN
I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMZ7CD 4452 printed Apr 09, 2024@21:01:30 Page 2
IVMZ7CD ;CKN,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 8/1/08 1:54pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**105,127,132,115**;OCT 21,1994;Build 28
+2 ;
+3 ; Demographic Consistency Checks
+4 ; This routine will be called from driver routine and it checks the
+5 ; various elements of Person demographic information prior to
+6 ; building a Z07 record. Any test which fails consistency check will
+7 ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person.
+8 ;
+9 QUIT
+10 ;
EN(DFN,DGP,DGSD) ;Entry point
+1 ; input: DFN - Patient IEN
+2 ; DGP - Patient data array
+3 ; DGSD - Spouse and Dependent data array
+4 ; output: ^TMP($J,DFN,RULE) global
+5 ; DFN - Patient IEN
+6 ; RULE - Consistency rule #
+7 ;initializing variables
+8 NEW RULE,Y,X,FILERR
+9 ;
+10 ; loop through rules in INCONSISTENT DATA ELEMENTS file.
+11 ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07
+12 ; CHECKS fields are turned ON.
+13 ;
+14 ; ***NOTE loop boundary (301-311) must be changed if rule numbers
+15 ; are added ***
+16 FOR RULE=301:1:312
IF $DATA(^DGIN(38.6,RULE))
Begin DoDot:1
+17 SET Y=^DGIN(38.6,RULE,0)
+18 IF $PIECE(Y,"^",6)
DO @RULE
End DoDot:1
+19 IF $DATA(FILERR)
MERGE ^TMP($JOB,DFN)=FILERR
+20 QUIT
+21 ;
301 ; PERSON LASTNAME REQUIRED
+1 SET X=$PIECE($GET(DGP("NAME",1)),U)
IF X=""
SET FILERR(RULE)=""
+2 IF '$DATA(DGSD("DEP"))
QUIT
+3 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+4 SET X=$PIECE(DGSD("DEP",RIEN,0),U)
+5 SET X=$PIECE(X,",")
IF X=""
SET FILERR(RULE)=""
End DoDot:1
+6 QUIT
+7 ;
302 ; DATE OF BIRTH REQUIRED - Duplicate with #4
+1 ;This tag needs to be removed after its placement in IVMZ7CR
QUIT
+2 SET X=$PIECE($GET(DGP("PAT",0)),U,3)
IF X=""
SET FILERR(RULE)=""
+3 IF '$DATA(DGSD("DEP"))
QUIT
+4 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+5 SET X=$PIECE(DGSD("DEP",RIEN,0),U,3)
IF X=""
SET FILERR(RULE)=""
End DoDot:1
+6 QUIT
+7 ;
303 ; GENDER REQUIRED
+1 SET X=$PIECE($GET(DGP("PAT",0)),U,2)
IF X=""
SET FILERR(RULE)=""
+2 IF '$DATA(DGSD("DEP"))
QUIT
+3 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+4 SET X=$PIECE(DGSD("DEP",RIEN,0),U,2)
IF X=""
SET FILERR(RULE)=""
End DoDot:1
+5 QUIT
+6 ;
304 ; GENDER INVALID
+1 SET X=$PIECE($GET(DGP("PAT",0)),U,2)
IF X]""
IF X'="M"
IF X'="F"
SET FILERR(RULE)=""
+2 IF '$DATA(DGSD("DEP"))
QUIT
+3 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+4 SET X=$PIECE(DGSD("DEP",RIEN,0),U,2)
+5 IF X]""
IF X'="M"
IF X'="F"
SET FILERR(RULE)=""
End DoDot:1
+6 QUIT
+7 ;
305 ; VETERAN SSN MISSING - Duplicate with #7
+1 ;This tag needs to be removed after its placement in IVMZ7CR
QUIT
+2 SET X=$PIECE($GET(DGP("PAT",0)),U,9)
IF X=""
SET FILERR(RULE)=""
+3 QUIT
+4 ;
306 ; VALID SSN/PSEUDO SSN REQUIRED, turned off with DG*5.3*771
+1 NEW Z
+2 SET X=$PIECE($GET(DGP("PAT",0)),U,9)
+3 ;quit if no SSN
if X=""
QUIT
+4 ;quit if SSN is a Pseudo
if $EXTRACT(X,$LENGTH(X))="P"
QUIT
+5 ;First 5 number are zero
IF $EXTRACT(X,1,5)="00000"
SET FILERR(RULE)=""
+6 ;all numbers are same
SET $PIECE(Z,$EXTRACT(X),9)=$EXTRACT(X)
IF X=Z
SET FILERR(RULE)=""
+7 ;First 3 digits are zeros
IF $EXTRACT(X,1,3)="000"
SET FILERR(RULE)=""
+8 ;4th & 5th are zeros
IF $EXTRACT(X,4,5)="00"
SET FILERR(RULE)=""
+9 ;Last 4 digits are zeros
IF $EXTRACT(X,6,9)="0000"
SET FILERR(RULE)=""
+10 ;SSN is 123456789
IF X=123456789
SET FILERR(RULE)=""
+11 QUIT
+12 ;
307 ; PSEUDO SSN REASON REQUIRED, turned off with DG*5.3*771
+1 SET X=$PIECE($GET(DGP("PAT",0)),U,9)
+2 IF X]""
IF X["P"
IF $PIECE($GET(DGP("PAT","SSN")),U)=""
SET FILERR(RULE)=""
+3 IF '$DATA(DGSD("DEP"))
QUIT
+4 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+5 SET X=$PIECE(DGSD("DEP",RIEN,0),U,9)
+6 IF X]""
IF X["P"
IF $PIECE(DGSD("DEP",RIEN,0),U,10)=""
SET FILERR(RULE)=""
End DoDot:1
+7 QUIT
+8 ;
308 ; DATE OF DEATH BEFORE DOB
+1 SET X=$PIECE($GET(DGP("PAT",.35)),U)
IF X']""
QUIT
+2 IF X<$PIECE($GET(DGP("PAT",0)),U,3)
SET FILERR(RULE)=""
+3 QUIT
+4 ;
309 ; PATIENT RELATIONSHIP INVALID
+1 NEW DEPSEX,RELSEX,DEPREL
+2 IF '$DATA(DGSD("DEP"))
QUIT
+3 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+4 SET DEPREL=$GET(DGSD("DEP",RIEN))
+5 IF DEPREL=""
SET FILERR(RULE)=""
QUIT
+6 IF '$DATA(^DG(408.11,DEPREL))
SET FILERR(RULE)=""
QUIT
+7 SET DEPSEX=$PIECE(DGSD("DEP",RIEN,0),U,2)
+8 SET RELSEX=$PIECE(^DG(408.11,DEPREL,0),U,3)
+9 ;Gender for relation can be either
IF RELSEX="E"
QUIT
+10 IF DEPSEX'=RELSEX
SET FILERR(RULE)=""
End DoDot:1
+11 QUIT
+12 ;
310 ; DEPENDENT EFF. DATE REQUIRED
+1 IF '$DATA(DGSD("DEP"))
QUIT
+2 SET RIEN=0
FOR
SET RIEN=$ORDER(DGSD("DEP",RIEN))
if RIEN=""
QUIT
Begin DoDot:1
+3 SET X=$GET(DGSD("DEP",RIEN,"EFF"))
IF 'X
SET FILERR(RULE)=""
End DoDot:1
+4 QUIT
+5 ;
311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16
+1 ;This tag needs to be removed after its placement in IVMZ7CR
QUIT
+2 SET X=$PIECE($GET(DGP("PAT",.35)),U)
+3 IF X]""
IF X>$$NOW^XLFDT()
SET FILERR(RULE)=""
+4 QUIT
+5 ;
312 ; PERSON MUST HAVE NATIONAL ICN
+1 ;No ICN
IF $$GETICN^MPIF001(DFN)<0
SET FILERR(RULE)=""
QUIT
+2 ;Not National ICN
IF $$IFLOCAL^MPIF001(DFN)=1
SET FILERR(RULE)=""
+3 QUIT
+4 ;
