Index: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m
===================================================================
--- WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m	(revision 623)
@@ -1,249 +1,250 @@
-IVMZ7CR	;BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/6/07 8:51am
-	;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
-	;
-	; Registration Consistency Checks
-	Q       ; Entry point must be specified
-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 #
-	;initialize variables
-	N RULE,Y,X,FILERR,SPDEP
-	S SPDEP=$D(DGSD("DEP"))
-	; we do not count through all numbers to save routine space
-	F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,75,76,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D
-	. I $$ON(RULE) D @RULE
-	I $D(FILERR) M ^TMP($J,DFN)=FILERR
-	Q
-4	; DOB UNSPECIFIED
-	; Note: RULE #302 in IVMZ7CD is a duplicate of this rule
-	N RIEN
-	I $P($G(DGP("PAT",0)),U,3)="" S FILERR(RULE)=""
-	I 'SPDEP Q
-	S RIEN=0 F  S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN=""  D
-	. I $P(DGSD("DEP",RIEN,0),U,3)="" S FILERR(RULE)=""
-	Q
-7	; SSN UNSPECIFIED
-	; Note: RULE #305 in IVMZ7CD is a duplicate of this rule
-	I $P($G(DGP("PAT",0)),U,9)="" S FILERR(RULE)=""
-	Q
-9	; VETERAN STATUS UNSPECIFIED
-	I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)=""
-	Q
-11	; SC PROMPT INCONSISTENT
-	N VET,SC,PTYPE
-	; If VET Status is not specified (RULE 9) no need for this test
-	Q:$P($G(DGP("PAT","VET")),U)=""
-	S VET=$P(DGP("PAT","VET"),U,1)="Y",SC=$P(DGP("PAT",.3),U,1)="Y"
-	I 'VET,SC S FILERR(RULE)=""
-	Q
-13	; POS UNSPECIFIED
-	; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule
-	Q:$P($G(DGP("PAT","VET")),U,1)'="Y"
-	; Make sure that the value in the field is valid -- DGRPC does this as well
-	I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),0)) S FILERR(RULE)=""
-	Q
-15	; INEL REASON UNSPECIFIED
-	; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule
-	I $P(DGP("PAT",.15),U,2),$P($G(DGP("PAT",.3)),U,7)="" S FILERR(RULE)=""
-	Q
-16	; DATE OF DEATH IN FUTURE
-	; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule
-	S X=$P($G(DGP("PAT",.35)),U) I X']"" Q
-	; Compare DOD to right now
-	I X>$$DT^XLFDT S FILERR(RULE)=""
-	Q
-19	; ELIG/NONVET STAT INCONSISTENT
-	; Note: Rule #405 in IVMZ7CE is a duplicate of this rule
-	N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE
-	; Patient's VET status
-	S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q
-	; do this check for NON-VET status only
-	Q:VET="Y"
-	; Check PT type to see if we skip VET checks
-	S PTYPE=$P($G(DGP("PAT","TYPE")),U,1)
-	I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q
-	; Eligibility Code
-	S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q
-	;start in File #8
-	S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q
-	;using the pointer value in field #8 (node 0; piece 9)
-	S MPTR=$P(FILE8,U,9)
-	;find the record in File #8.1
-	S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q
-	;check the Type field #4 (node 0; piece 5). 
-	S MTYPE=$P(FILE81,U,5)
-	; Pt's VET status must match NON-VET Status of Eligibility Code
-	I VET'=MTYPE S FILERR(RULE)=""
-	Q
-24	; POS/ELIG CODE INCONSISTENT
-	; Note: Rule #412 in IVMZ7CE is a duplicate of this rule
-	I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)=""
-	Q
-29	; A&A CLAIMED, NONVET
-	I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)=""
-	Q
-30	; HOUSEBOUND CLAIMED, NONVET
-	I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)=""
-	Q
-31	; VA PENSION CLAIMED, NONVET
-	I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)=""
-	Q
-34	; POW CLAIMED, NONVET
-	I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)=""
-	Q
-60	; AGENT ORANGE EXP LOC MISSING
-	; Note: Rule #512 in IVMZ7CS is a duplicate of this rule.
-	I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)=""
-	Q
-72	; MSE DATA MISSING/INCOMPLETE, turned off with DG*5.3*765
-	; Note: Rule #513 in IVMZ7CS is a duplicate of this rule.
-	N I,X
-	S X=DGP("PAT",.32)
-	F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q     ;LAST
-	F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q  ;NTL
-	F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)=""   ;NNTL
-	Q
-	;
-74	; CONFLICT DT MISSING/INCOMPLETE, turned off with DG*5.3*765 
-	; Note:#515 IVMZ7CS is a duplicate, turned off with DG*5.3*771
-75	; ALSO # 75 CONFLICT TO DT BEFORE FROM DT
-76	;      # 76 INACCURATE CONFLICT DATE, turned off with DG*5.3*771
-	; 
-	N I,T,FROM,TO,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON74,ON75,ON76
-	S ON74=$$ON(74),ON75=$$ON(75),ON76=$$ON(76)
-	S I=$$RANGE^DGMSCK()    ; load range table
-	F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT"  D
-	. ;we have to have a flag ERR because we don't want multiple
-	. ;inconsistencies on a single conflict but we do want to
-	. ;flag a single inconsistency on multiple conflicts
-	. S ERR=0
-	. S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4)
-	. S RNGE=$P(CONFL,U,5)
-	. Q:$P(DGP("PAT",NODE),U,PCE)'="Y"
-	. S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
-	. ; check rule 74 CONFLICT DT MISSING/INCOMPLETE
-	. I ON74,(RULE=74) F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1
-	. Q:ERR
-	. ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT
-	. I ON75,(RULE=75),(FROM>TO) S FILERR(RULE)="",ERR=1
-	. Q:ERR
-	. ; check rule 76 INACCURATE CONFLICT DATE
-	. Q:ERR
-	. Q:'$D(RANGE(RNGE))  ; can't calculate if range table is missing
-	. ; determine whether dates are withing conflict range
-	. S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
-	. I ON76,(RULE=76) D
-	. . I '((RFR'>FROM)&((RTO'<TO))) S FILERR(RULE)=""
-	Q
-78	; INACCURATE COMBAT DT/LOC, turned off with DG*5.3*771
-	N I,T,FROM,TO,RULE,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON78,LOC
-	; This tag checks COMBAT status and verifies that valid FROM & TO dates are found
-	S RULE=78
-	I '$$ON(RULE) Q
-	S I=$$RANGE^DGMSCK()    ; load range table
-	F I=1:1 S CONFL=$P($T(COMLIST+I),";;",3) Q:CONFL="QUIT"  D
-	. S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4)
-	. S RNGE=$P(CONFL,U,5)
-	. ; if we have COMBAT data, get Service Location info, it comes under a different rule
-	. Q:$P(DGP("PAT",NODE),U,PCE)'="Y"
-	. S RNGE=$$COMPOW^DGRPMS($P(DGP("PAT",.52),U,12)) I $G(RNGE)="" S FILERR(RULE)="" Q
-	. S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
-	. ; determine whether Pt dates are within conflict range for specified location
-	. S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
-	. I '(RFR'>FROM&((FROM'>RTO)&((RTO'<TO)&((TO'<RFR))))) S FILERR(RULE)=""
-	Q
-81	; COMBAT DT NOT WITHIN MSE, turned off with DG*5.3*765
-	; this code is copied from DGRP3
-	; MSFROMTO^DGMSCK creates a block for a continual MSE
-	N MSE,MSECHK,MSESET,ANYMSE,DGP81
-	I '$P($G(DGP("PAT",.52)),U,12) Q
-	;
-	; we're calling into DG Legacy code so we have to modify some arrays
-	M DGP81=DGP K DGP
-	M DGP=DGP81("PAT")
-	; set up the check
-	S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
-	; If COMBAT, but no MSE, then Range is NOT within MSE
-	I '$G(ANYMSE) D  Q
-	. S FILERR(RULE)=""
-	. K DGP M DGP=DGP81
-	I '$$RWITHIN^DGRPDT($P(MSESET,U,1),$P(MSESET,U,2),$P($G(DGP81("PAT",.52)),U,13),$P($G(DGP81("PAT",.52)),U,14)) S FILERR(RULE)=""
-	K DGP M DGP=DGP81
-	Q
-	;
-83	; BOS REQUIRES DATE W/IN WWII
-	; this code is copied from DGRP3
-	N BOS,BOSN,MS,MSE,DGP83
-	Q:'$D(DGP("PAT",.32))
-	; we're calling into DG Legacy code so we have to modify some arrays
-	M DGP83=DGP K DGP
-	M DGP=DGP83("PAT")
-	F MS=1:1:3 D
-	. I MS=2,$P(DGP83("PAT",.32),U,19)'="Y" Q
-	. I MS=3,$P(DGP83("PAT",.32),U,20)'="Y" Q
-	. S BOS=$P(DGP83("PAT",.32),U,(5*MS)) Q:'BOS  S BOSN=$P($G(^DIC(23,BOS,0)),U)
-	. S MSE=$P("MSL^MSNTL^MSNNTL",U,MS)
-	. I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S FILERR(RULE)=""
-	; fix the arrays before we leave
-	K DGP M DGP=DGP83
-	Q
-85	; FILIPINO VET SHOULD BE VET='Y'
-	; this code is copied from DGRP3
-	N MS,BOS,FV,FILV,NOTFV,MSE,RULE2,DGVT,DGP85
-	Q:'$D(DGP("PAT",.32))
-	; we're calling into DG Legacy code so we have to modify some arrays
-	S DGVT=$P($G(DGP("PAT","VET")),U)="Y"
-	M DGP85=DGP K DGP
-	M DGP=DGP85("PAT")
-	S RULE2=86   ; will also check RULE #86 INEL FIL VET SHOULD BE VET='N'
-	F MS=1:1:3 D
-	. I MS=2,$P(DGP85("PAT",.32),U,19)'="Y" Q
-	. I MS=3,$P(DGP85("PAT",.32),U,20)'="Y" Q
-	. S BOS=$P(DGP85("PAT",.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
-	. S MSE=$P("MSL^MSNTL^MSNNTL",U,MS)
-	. I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
-	. I FV=2 S FILV("E")="" Q
-	. I $P(DGP85("PAT",.321),U,14)=""!($P(DGP85("PAT",.321),U,14)="NO") S FILV("I")="" Q
-	. S FILV("E")=""
-	I $D(FILV) D
-	. I DGVT'=1,$D(FILV("E")) S FILERR(RULE)=""
-	. I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S FILERR(RULE2)=""
-	; fix the arrays before we leave
-	K DGP M DGP=DGP85
-	Q
-86	; INEL FIL VET SHOULD BE VET='N'
-	; This rule is satisfied in #85 above
-	Q
-ON(RULE)	;verify RULE is turned on
-	N ON,Y
-	S ON=0
-	S Y=^DGIN(38.6,RULE,0)
-	I '$P(Y,U,5),$P(Y,U,6) S ON=1
-	Q ON
-CONLIST	;;CONFLICT;;NODE^PIECE^FROM^TO^RANGE  -- offset list, do not add comments
-	;;VIETNAM;;.321^1^4^5^VIET
-	;;LEBANON;;.322^1^2^3^LEB
-	;;GRENADA;;.322^4^5^6^GREN
-	;;PANAMA;;.322^7^8^9^PAN
-	;;PERSIAN GULF;;.322^10^11^12^GULF
-	;;SOMALIA;;.322^16^17^18^SOM
-	;;YUGOSLAVIA;;.322^19^20^21^YUG
-	;;QUIT;;QUIT
-COMLIST	;;COMBAT;;NODE^PIECE^FROM^TO^RANGE  -- offset list, do not add comments
-	;;WWI;;.52^11^13^14^WWI
-	;;WWIIE;;.52^11^13^14^WWIIE
-	;;WWIIP;;.52^11^13^14^WWIIP
-	;;KOREA;;.52^11^13^14^KOR
-	;;OTHER;;.52^11^13^14^OTHER
-	;;VIETNAM;;.52^11^13^14^VIET
-	;;LEBANON;;.52^11^13^14^LEB
-	;;GRENADA;;.52^11^13^14^GREN
-	;;PANAMA;;.52^11^13^14^PAN
-	;;PERSIAN GULF;;.52^11^13^14^GULF
-	;;SOMALIA;;.52^11^13^14^SOM
-	;;YUGOSLAVIA;;.52^11^13^14^YUG
-	;;QUIT;;QUIT
+IVMZ7CR ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/7/05 12:24pm
+ ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
+ ;
+ ; Registration Consistency Checks
+ Q       ; Entry point must be specified
+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 #
+ ;initialize variables
+ N RULE,Y,X,FILERR,SPDEP
+ S SPDEP=$D(DGSD("DEP"))
+ ; we do not count through all numbers to save routine space
+ F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D
+ . I $$ON(RULE) D @RULE
+ I $D(FILERR) M ^TMP($J,DFN)=FILERR
+ Q
+4 ; DOB UNSPECIFIED
+ ; Note: RULE #302 in IVMZ7CD is a duplicate of this rule
+ N RIEN
+ I $P($G(DGP("PAT",0)),U,3)="" S FILERR(RULE)=""
+ I 'SPDEP Q
+ S RIEN=0 F  S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN=""  D
+ . I $P(DGSD("DEP",RIEN,0),U,3)="" S FILERR(RULE)=""
+ Q
+7 ; SSN UNSPECIFIED
+ ; Note: RULE #305 in IVMZ7CD is a duplicate of this rule
+ I $P($G(DGP("PAT",0)),U,9)="" S FILERR(RULE)=""
+ Q
+9 ; VETERAN STATUS UNSPECIFIED
+ I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)=""
+ Q
+11 ; SC PROMPT INCONSISTENT
+ N VET,SC,PTYPE
+ ; If VET Status is not specified (RULE 9) no need for this test
+ Q:$P($G(DGP("PAT","VET")),U)=""
+ S VET=$P(DGP("PAT","VET"),U,1)="Y",SC=$P(DGP("PAT",.3),U,1)="Y"
+ I 'VET,SC S FILERR(RULE)=""
+ Q
+13 ; POS UNSPECIFIED
+ ; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule
+ Q:$P($G(DGP("PAT","VET")),U,1)'="Y"
+ ; Make sure that the value in the field is valid -- DGRPC does this as well
+ I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),0)) S FILERR(RULE)=""
+ Q
+15 ; INEL REASON UNSPECIFIED
+ ; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule
+ I $P(DGP("PAT",.15),U,2),$P($G(DGP("PAT",.3)),U,7)="" S FILERR(RULE)=""
+ Q
+16 ; DATE OF DEATH IN FUTURE
+ ; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule
+ S X=$P($G(DGP("PAT",.35)),U) I X']"" Q
+ ; Compare DOD to right now
+ I X>$$DT^XLFDT S FILERR(RULE)=""
+ Q
+19 ; ELIG/NONVET STAT INCONSISTENT
+ ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule
+ N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE
+ ; Patient's VET status
+ S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q
+ ; do this check for NON-VET status only
+ Q:VET="Y"
+ ; Check PT type to see if we skip VET checks
+ S PTYPE=$P($G(DGP("PAT","TYPE")),U,1)
+ I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q
+ ; Eligibility Code
+ S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q
+ ;start in File #8
+ S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q
+ ;using the pointer value in field #8 (node 0; piece 9)
+ S MPTR=$P(FILE8,U,9)
+ ;find the record in File #8.1
+ S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q
+ ;check the Type field #4 (node 0; piece 5). 
+ S MTYPE=$P(FILE81,U,5)
+ ; Pt's VET status must match NON-VET Status of Eligibility Code
+ I VET'=MTYPE S FILERR(RULE)=""
+ Q
+24 ; POS/ELIG CODE INCONSISTENT
+ ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule
+ I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)=""
+ Q
+29 ; A&A CLAIMED, NONVET
+ I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)=""
+ Q
+30 ; HOUSEBOUND CLAIMED, NONVET
+ I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)=""
+ Q
+31 ; VA PENSION CLAIMED, NONVET
+ I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)=""
+ Q
+34 ; POW CLAIMED, NONVET
+ I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)=""
+ Q
+60 ; AGENT ORANGE EXP LOC MISSING
+ ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule.
+ I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)=""
+ Q
+72 ; MSE DATA MISSING/INCOMPLETE
+ ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule.
+ N I,X
+ S X=DGP("PAT",.32)
+ F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q     ;LAST
+ F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q  ;NTL
+ F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)=""   ;NNTL
+ Q
+ ;
+74 ; CONFLICT DT MISSING/INCOMPLETE
+ ; Note: Rule #515 in IVMZ7CS is a duplicate of this rule.
+ ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT
+ ;      # 76 INACCURATE CONFLICT DATE
+ ; 
+ N I,T,FROM,TO,RULE1,RULE2,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON75,ON76
+ S RULE1=75,RULE2=76
+ S ON75=$$ON(75),ON76=$$ON(76)
+ S I=$$RANGE^DGMSCK()    ; load range table
+ F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT"  D
+ . ;we have to have a flag ERR because we don't want multiple
+ . ;inconsistencies on a single conflict but we do want to
+ . ;flag a single inconsistency on multiple conflicts
+ . S ERR=0
+ . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4)
+ . S RNGE=$P(CONFL,U,5)
+ . Q:$P(DGP("PAT",NODE),U,PCE)'="Y"
+ . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
+ . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE
+ . F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1
+ . Q:ERR
+ . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT
+ . I ON75,FROM>TO S FILERR(RULE1)="",ERR=1
+ . Q:ERR
+ . ; check rule 76 INACCURATE CONFLICT DATE
+ . Q:ERR
+ . Q:'$D(RANGE(RNGE))  ; can't calculate if range table is missing
+ . ; determine whether dates are withing conflict range
+ . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
+ . I ON76 D
+ . . I '((RFR'>FROM)&((RTO'<TO))) S FILERR(RULE2)=""
+ Q
+78 ; INACCURATE COMBAT DT/LOC
+ N I,T,FROM,TO,RULE,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON78,LOC
+ ; This tag checks COMBAT status and verifies that valid FROM & TO dates are found
+ S RULE=78
+ I '$$ON(RULE) Q
+ S I=$$RANGE^DGMSCK()    ; load range table
+ F I=1:1 S CONFL=$P($T(COMLIST+I),";;",3) Q:CONFL="QUIT"  D
+ . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4)
+ . S RNGE=$P(CONFL,U,5)
+ . ; if we have COMBAT data, get Service Location info, it comes under a different rule
+ . Q:$P(DGP("PAT",NODE),U,PCE)'="Y"
+ . S RNGE=$$COMPOW^DGRPMS($P(DGP("PAT",.52),U,12)) I $G(RNGE)="" S FILERR(RULE)="" Q
+ . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
+ . ; determine whether Pt dates are within conflict range for specified location
+ . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
+ . I '(RFR'>FROM&((FROM'>RTO)&((RTO'<TO)&((TO'<RFR))))) S FILERR(RULE)=""
+ Q
+81 ; COMBAT DT NOT WITHIN MSE
+ ; this code is copied from DGRP3
+ ; MSFROMTO^DGMSCK creates a block for a continual MSE
+ N MSE,MSECHK,MSESET,ANYMSE,DGP81
+ I '$P($G(DGP("PAT",.52)),U,12) Q
+ ;
+ ; we're calling into DG Legacy code so we have to modify some arrays
+ M DGP81=DGP K DGP
+ M DGP=DGP81("PAT")
+ ; set up the check
+ S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
+ ; If COMBAT, but no MSE, then Range is NOT within MSE
+ I '$G(ANYMSE) D  Q
+ . S FILERR(RULE)=""
+ . K DGP M DGP=DGP81
+ I '$$RWITHIN^DGRPDT($P(MSESET,U,1),$P(MSESET,U,2),$P($G(DGP81("PAT",.52)),U,13),$P($G(DGP81("PAT",.52)),U,14)) S FILERR(RULE)=""
+ K DGP M DGP=DGP81
+ Q
+ ;
+83 ; BOS REQUIRES DATE W/IN WWII
+ ; this code is copied from DGRP3
+ N BOS,BOSN,MS,MSE,DGP83
+ Q:'$D(DGP("PAT",.32))
+ ; we're calling into DG Legacy code so we have to modify some arrays
+ M DGP83=DGP K DGP
+ M DGP=DGP83("PAT")
+ F MS=1:1:3 D
+ . I MS=2,$P(DGP83("PAT",.32),U,19)'="Y" Q
+ . I MS=3,$P(DGP83("PAT",.32),U,20)'="Y" Q
+ . S BOS=$P(DGP83("PAT",.32),U,(5*MS)) Q:'BOS  S BOSN=$P($G(^DIC(23,BOS,0)),U)
+ . S MSE=$P("MSL^MSNTL^MSNNTL",U,MS)
+ . I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S FILERR(RULE)=""
+ ; fix the arrays before we leave
+ K DGP M DGP=DGP83
+ Q
+85 ; FILIPINO VET SHOULD BE VET='Y'
+ ; this code is copied from DGRP3
+ N MS,BOS,FV,FILV,NOTFV,MSE,RULE2,DGVT,DGP85
+ Q:'$D(DGP("PAT",.32))
+ ; we're calling into DG Legacy code so we have to modify some arrays
+ S DGVT=$P($G(DGP("PAT","VET")),U)="Y"
+ M DGP85=DGP K DGP
+ M DGP=DGP85("PAT")
+ S RULE2=86   ; will also check RULE #86 INEL FIL VET SHOULD BE VET='N'
+ F MS=1:1:3 D
+ . I MS=2,$P(DGP85("PAT",.32),U,19)'="Y" Q
+ . I MS=3,$P(DGP85("PAT",.32),U,20)'="Y" Q
+ . S BOS=$P(DGP85("PAT",.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
+ . S MSE=$P("MSL^MSNTL^MSNNTL",U,MS)
+ . I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
+ . I FV=2 S FILV("E")="" Q
+ . I $P(DGP85("PAT",.321),U,14)=""!($P(DGP85("PAT",.321),U,14)="NO") S FILV("I")="" Q
+ . S FILV("E")=""
+ I $D(FILV) D
+ . I DGVT'=1,$D(FILV("E")) S FILERR(RULE)=""
+ . I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S FILERR(RULE2)=""
+ ; fix the arrays before we leave
+ K DGP M DGP=DGP85
+ Q
+86 ; INEL FIL VET SHOULD BE VET='N'
+ ; This rule is satisfied in #85 above
+ Q
+ON(RULE) ;verify RULE is turned on
+ N ON,Y
+ S ON=0
+ S Y=^DGIN(38.6,RULE,0)
+ I '$P(Y,U,5),$P(Y,U,6) S ON=1
+ Q ON
+CONLIST ;;CONFLICT;;NODE^PIECE^FROM^TO^RANGE  -- offset list, do not add comments
+ ;;VIETNAM;;.321^1^4^5^VIET
+ ;;LEBANON;;.322^1^2^3^LEB
+ ;;GRENADA;;.322^4^5^6^GREN
+ ;;PANAMA;;.322^7^8^9^PAN
+ ;;PERSIAN GULF;;.322^10^11^12^GULF
+ ;;SOMALIA;;.322^16^17^18^SOM
+ ;;YUGOSLAVIA;;.322^19^20^21^YUG
+ ;;QUIT;;QUIT
+COMLIST ;;COMBAT;;NODE^PIECE^FROM^TO^RANGE  -- offset list, do not add comments
+ ;;WWI;;.52^11^13^14^WWI
+ ;;WWIIE;;.52^11^13^14^WWIIE
+ ;;WWIIP;;.52^11^13^14^WWIIP
+ ;;KOREA;;.52^11^13^14^KOR
+ ;;OTHER;;.52^11^13^14^OTHER
+ ;;VIETNAM;;.52^11^13^14^VIET
+ ;;LEBANON;;.52^11^13^14^LEB
+ ;;GRENADA;;.52^11^13^14^GREN
+ ;;PANAMA;;.52^11^13^14^PAN
+ ;;PERSIAN GULF;;.52^11^13^14^GULF
+ ;;SOMALIA;;.52^11^13^14^SOM
+ ;;YUGOSLAVIA;;.52^11^13^14^YUG
+ ;;QUIT;;QUIT
