VistA-WorldVistAEHR/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CS.m

108 lines
3.3 KiB
Mathematica

IVMZ7CS ;TDM - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 07/21/06 7:32am
;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
;
; Service 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 (501-517) must be changed if rule numbers
; are added ***
F RULE=501:1:517 I $D(^DGIN(38.6,RULE)) D
. S Y=^DGIN(38.6,RULE,0)
. I '$P(Y,U,5),$P(Y,U,6) D @RULE
I $D(FILERR) M ^TMP($J,DFN)=FILERR
Q
;
501 ; POW STATUS INVALID
S X=$P(DGP("PAT",.52),U,5) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
Q
;
502 ; MIL DIS RETIREMENT INVALID
S X=$P(DGP("PAT",.36),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
Q
;
503 ; DISCHARGE DUE TO DISAB INVALID
S X=$P(DGP("PAT",.36),U,13) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
Q
;
504 ; AGENT ORANGE EXPOSURE INVALID
S X=$P(DGP("PAT",.321),U,2) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
Q
;
505 ; RADIATION EXPOSURE INVALID
S X=$P(DGP("PAT",.321),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
Q
;
506 ; ENV CONTAMINANTS EXP INVALID
S X=$P(DGP("PAT",.322),U,13) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
Q
;
507 ; RAD EXPOSURE METHOD INVALID
I $P(DGP("PAT",.321),U,3)="Y" S X=$P(DGP("PAT",.321),U,12) I X'?1N!(X<2)!(X>7) S FILERR(RULE)=""
Q
;
508 ; MST STATUS INVALID
S X=$P($G(DGP("MST",0)),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="D")&(X'="U") S FILERR(RULE)=""
Q
;
509 ; MST STATUS CHANGE DATE MISSING
S X=$P($G(DGP("MST",0)),U,3) I ((X="Y")!(X="N")!(X="D")!(X="U")),$P(DGP("MST",0),U)<1 S FILERR(RULE)=""
Q
;
510 ; MST STATUS SITE REQUIRED
S X=$P($G(DGP("MST",0)),U,3) I ((X="Y")!(X="N")!(X="D")!(X="U")),$P(DGP("MST",0),U,6)="" S FILERR(RULE)=""
Q
;
511 ; MST STATUS SITE INVALID
S X=$P($G(DGP("MST",0)),U,6) I X'="",'$$TF^XUAF4(X) S FILERR(RULE)=""
Q
;
512 ; AO EXPOSURE LOCATION MISSING
; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
Q
;
513 ; MS ENTRY DATE REQUIRED
; Note: RULE #72 in IVMZ7CR is a duplicate of this rule
Q
;
514 ; MS SEPARATION DATE REQUIRED
; Note: RULE #72 in IVMZ7CR is a duplicate of this rule
Q
;
515 ; CONFLICT FROM/TO DATE REQUIRED
; Note: RULE #74 in IVMZ7CR is a duplicate of this rule
Q
;
516 ; DOB INVALID-MEXICAN BORDER WAR
N MBW
I $D(^DPT(DFN,"E")) D
. S MBW=$O(^DIC(8,"B","MEXICAN BORDER WAR","")) Q:MBW=""
. S X=0 F S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE)) D
. . I $P(^DPT(DFN,"E",X,0),U)=MBW,$P(DGP("PAT",0),U,3)>2061231 S FILERR(RULE)=""
Q
;
517 ; DOB INVALID-WORLD WAR I
N WWI
I $D(^DPT(DFN,"E")) D
. S WWI=$O(^DIC(8,"B","WORLD WAR I","")) Q:WWI=""
. S X=0 F S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE)) D
. . I $P(^DPT(DFN,"E",X,0),U)=WWI,$P(DGP("PAT",0),U,3)>2071231 S FILERR(RULE)=""
Q
YM(X) ; Returns whether date has year & month values: 1=yes, 0=no
Q ($E(X,1,3)>0)&($E(X,4,5)>0)
;
YY(X) ; Returns whether date has year a value: 1=yes, 0=no
Q ($E(X,1,3)>0)