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