source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CS.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1IVMZ7CS ;TDM - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 07/21/06 7:32am
2 ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
3 ;
4 ; Service Consistency Checks
5 ; This routine checks the various elements of service information
6 ; prior to building a Z07 record. Any tests which fail consistency
7 ; check will be saved to the ^DGIN(38.6 record for the patient.
8 ;
9 ; Must be called from entry point
10 Q
11 ;
12EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine.
13 ; initialize working variables
14 N RULE,Y,X,FILERR
15 ;
16 ; loop through rules in INCONSISTENT DATA ELEMENTS file.
17 ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07
18 ; CHECKS fields are turned ON.
19 ;
20 ; ***NOTE loop boundary (501-517) must be changed if rule numbers
21 ; are added ***
22 F RULE=501:1:517 I $D(^DGIN(38.6,RULE)) D
23 . S Y=^DGIN(38.6,RULE,0)
24 . I '$P(Y,U,5),$P(Y,U,6) D @RULE
25 I $D(FILERR) M ^TMP($J,DFN)=FILERR
26 Q
27 ;
28501 ; POW STATUS INVALID
29 S X=$P(DGP("PAT",.52),U,5) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
30 Q
31 ;
32502 ; MIL DIS RETIREMENT INVALID
33 S X=$P(DGP("PAT",.36),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
34 Q
35 ;
36503 ; DISCHARGE DUE TO DISAB INVALID
37 S X=$P(DGP("PAT",.36),U,13) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""
38 Q
39 ;
40504 ; AGENT ORANGE EXPOSURE INVALID
41 S X=$P(DGP("PAT",.321),U,2) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
42 Q
43 ;
44505 ; RADIATION EXPOSURE INVALID
45 S X=$P(DGP("PAT",.321),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
46 Q
47 ;
48506 ; ENV CONTAMINANTS EXP INVALID
49 S X=$P(DGP("PAT",.322),U,13) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""
50 Q
51 ;
52507 ; RAD EXPOSURE METHOD INVALID
53 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)=""
54 Q
55 ;
56508 ; MST STATUS INVALID
57 S X=$P($G(DGP("MST",0)),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="D")&(X'="U") S FILERR(RULE)=""
58 Q
59 ;
60509 ; MST STATUS CHANGE DATE MISSING
61 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)=""
62 Q
63 ;
64510 ; MST STATUS SITE REQUIRED
65 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)=""
66 Q
67 ;
68511 ; MST STATUS SITE INVALID
69 S X=$P($G(DGP("MST",0)),U,6) I X'="",'$$TF^XUAF4(X) S FILERR(RULE)=""
70 Q
71 ;
72512 ; AO EXPOSURE LOCATION MISSING
73 ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule
74 Q
75 ;
76513 ; MS ENTRY DATE REQUIRED
77 ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule
78 Q
79 ;
80514 ; MS SEPARATION DATE REQUIRED
81 ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule
82 Q
83 ;
84515 ; CONFLICT FROM/TO DATE REQUIRED
85 ; Note: RULE #74 in IVMZ7CR is a duplicate of this rule
86 Q
87 ;
88516 ; DOB INVALID-MEXICAN BORDER WAR
89 N MBW
90 I $D(^DPT(DFN,"E")) D
91 . S MBW=$O(^DIC(8,"B","MEXICAN BORDER WAR","")) Q:MBW=""
92 . S X=0 F S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE)) D
93 . . I $P(^DPT(DFN,"E",X,0),U)=MBW,$P(DGP("PAT",0),U,3)>2061231 S FILERR(RULE)=""
94 Q
95 ;
96517 ; DOB INVALID-WORLD WAR I
97 N WWI
98 I $D(^DPT(DFN,"E")) D
99 . S WWI=$O(^DIC(8,"B","WORLD WAR I","")) Q:WWI=""
100 . S X=0 F S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE)) D
101 . . I $P(^DPT(DFN,"E",X,0),U)=WWI,$P(DGP("PAT",0),U,3)>2071231 S FILERR(RULE)=""
102 Q
103YM(X) ; Returns whether date has year & month values: 1=yes, 0=no
104 Q ($E(X,1,3)>0)&($E(X,4,5)>0)
105 ;
106YY(X) ; Returns whether date has year a value: 1=yes, 0=no
107 Q ($E(X,1,3)>0)
Note: See TracBrowser for help on using the repository browser.