Changeset 623 for WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m (modified) (1 diff)

WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m

@@ -1 @@
-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