Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IVMZ7CE

IVMZ7CE.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Eligibility Consistency Checks
  1.  ; This routine checks the various elements of service information
  1.  ; prior to building a Z07 record.  Any tests which fail consistency
  1.  ; check will be saved to the ^DGIN(38.6 record for the patient.
  1.  ;
  1.  ; Must be called from entry point
  1.  Q
  1.  ;
  1. EN(DFN,DGP) ; entry point.  Patient DFN is sent from calling routine.
  1.  ; initialize working variables
  1.  N RULE,Y,X,FILERR
  1.  ;
  1.  ; loop through rules in INCONSISTENT DATA ELEMENTS file.
  1.  ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07
  1.  ; CHECKS fields are turned ON.
  1.  ;
  1.  ; ***NOTE loop boundary (401-413) must be changed if rule numbers
  1.  ; are added ***
  1.  F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D
  1.  . S Y=^DGIN(38.6,RULE,0)
  1.  . I $P(Y,U,6) D @RULE
  1.  I $D(FILERR) M ^TMP($J,DFN)=FILERR
  1.  Q
  1.  ;
  1. 401 ; RATED INCOMPETENT INVALID
  1.  S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 402 ; ELIGIBLE FOR MEDICAID INVALID
  1.  S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 403 ; DT MEDICAID LAST ASKED INVALID
  1.  I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 404 ; INELIGIBLE REASON INVALID
  1.  ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule
  1.  Q
  1.  ;
  1. 405 ; NON VETERAN ELIG CODE INVALID
  1.  ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
  1.  Q
  1.  ;
  1. 406 ; CLAIM FOLDER NUMBER INVALID
  1.  S X=$P(DGP("PAT",.31),U,3)
  1.  I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 407 ; ELIGIBILITY STATUS INVALID
  1.  S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 408 ; DECLINE TO GIVE INCOME INVALID
  1.  ; This CC removed per customer 05/08/2006 -- BAJ
  1.  ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 409 ; AGREE TO PAY DEDUCT INVALID
  1.  ; this CC inactivated by DG*5.3*771
  1.  ; 2  PENDING ADJUDICATION     MEANS TEST
  1.  ; 6  MT COPAY REQUIRED     MEANS TEST
  1.  ;16  GMT COPAY REQUIRED     MEANS TEST
  1.  I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D
  1.  . S X=$P(DGP("MEANS",0),U,3)
  1.  . I (X=2)!(X=6) S FILERR(RULE)="" Q
  1.  . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)=""
  1.  Q
  1.  ;
  1. 410 ; Note: RULE #404 above is a duplicate of this rule
  1.  Q
  1.  ;
  1. 411 ; ENROLLMENT APP DATE INVALID
  1.  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)=""
  1.  Q
  1.  ;
  1. 412 ; POS/ELIG CODE INVALID
  1.  ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule
  1.  Q
  1.  ;
  1. 413 ; POS INVALID
  1.  ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule
  1.  Q