Routine: IVMZ7CR

IVMZ7CR ;BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/6/07 8:51am

 ;;2.0;INCOME VERIFICATION MATCH;**105,127,132,153**;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,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

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)=""

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)=""

9 ; VETERAN STATUS UNSPECIFIED

 I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)=""

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)=""

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)=""

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)=""

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>$$NOW^XLFDT S FILERR(RULE)=""

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)=""

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)=""

29 ; A&A CLAIMED, NONVET

 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)=""

30 ; HOUSEBOUND CLAIMED, NONVET

 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)=""

31 ; VA PENSION CLAIMED, NONVET

 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)=""

34 ; POW CLAIMED, NONVET

 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)=""

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)=""

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

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)=""

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)=""

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

83 ; BOS REQUIRES DATE W/IN WWII

 ; this code is copied from DGRP3

 N BOS,BOSN,MS,MSE,DGP83,OUT

 ;IVM*2*153 uses mse data from DGPMSE array, if it exists

 I $D(DGPMSE) D  Q

 .S MS=0 F  S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT))  D

 ..I $P(DGPMSE(MS),U,7) Q  ;Don't check MSE if verified by HEC

 ..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS  S BOSN=$P(^DIC(23,BOS,0),U)

 ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE  S MSE="MSE-"_MSE

 ..I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S FILERR(RULE)="",OUT=1 Q

 ;Otherwise, get MSE data from DGP("PAT",.32)

 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

85 ; FILIPINO VET SHOULD BE VET='Y'

 ; this code is copied from DGRP3

 N MS,BOS,FV,FILV,NOTFV,MSE,RULE2,DGVT,DGP85

 ;IVM*2*153 use mse data from DGPMSE array, if it exists

 ; we're calling into DG Legacy code so we have to modify some arrays

 S DGVT=$P($G(DGP("PAT","VET")),U)="Y"

 S RULE2=86   ; will also check RULE #86 INEL FIL VET SHOULD BE VET='N'

 I $D(DGPMSE) D

 .S MS=0 F  S MS=$O(DGPMSE(MS)) Q:'MS  D

 ..I $P(DGPMSE(MS),U,7) Q  ;Don't check MSE if verified by HEC

 ..S BOS=$P(DGPMSE(MS),U,3),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q

 ..S MSE=$O(DGPMSE(MS,0)) Q:'MSE  S MSE="MSE-"_MSE

 ..I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q

 ..I FV=2 S FILV("E")="" Q

 ..I $P(DGP("PAT",.321),U,14)=""!($P(DGP("PAT",.321),U,14)="NO") S FILV("I")="" Q

 ..S FILV("E")=""

 ;Otherwise, get MSE data from DGP(.32)

 E  I $D(DGP("PAT",.32)) D

 .; we're calling into DG Legacy code so we have to modify some arrays

 .M DGP85=DGP K DGP

 .M DGP=DGP85("PAT")

 .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")=""

 .; fix the arrays

 .K DGP M DGP=DGP85

 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)=""

86 ; INEL FIL VET SHOULD BE VET='N'

 ; This rule is satisfied in #85 above

ON(RULE) ;verify RULE is turned on

 N ON,Y

 S ON=0

 S Y=^DGIN(38.6,RULE,0)

 I $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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMZ7CR   11035     printed  Mar 13, 2025@21:07:15                                                                                                                                                                                                    Page 2

IVMZ7CR   ;BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/6/07 8:51am

 +1       ;;2.0;INCOME VERIFICATION MATCH;**105,127,132,153**;JUL 8,1996;Build 2

 +2       ;

 +3       ; Registration Consistency Checks

 +4       ; Entry point must be specified

           QUIT

EN(DFN,DGP,DGSD) ;Entry point

 +1       ;  input:  DFN - Patient IEN

 +2       ;          DGP - Patient data array

 +3       ;          DGSD - Spouse and Dependent data array

 +4       ; output: ^TMP($J,DFN,RULE) global

 +5       ;          DFN - Patient IEN

 +6       ;          RULE - Consistency rule #

 +7       ;initialize variables

 +8        NEW RULE,Y,X,FILERR,SPDEP

 +9        SET SPDEP=$DATA(DGSD("DEP"))

 +10      ; we do not count through all numbers to save routine space

 +11       FOR RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,75,76,78,81,83,85,86

               IF $DATA(^DGIN(38.6,RULE))

                   Begin DoDot:1

 +12                   IF $$ON(RULE)

                           DO @RULE

                   End DoDot:1

 +13       IF $DATA(FILERR)

               MERGE ^TMP($JOB,DFN)=FILERR

 +14       QUIT

4         ; DOB UNSPECIFIED

 +1       ; Note: RULE #302 in IVMZ7CD is a duplicate of this rule

 +2        NEW RIEN

 +3        IF $PIECE($GET(DGP("PAT",0)),U,3)=""

               SET FILERR(RULE)=""

 +4        IF 'SPDEP

               QUIT

 +5        SET RIEN=0

FOR

               SET RIEN=$ORDER(DGSD("DEP",RIEN))

               if RIEN=""

                   QUIT

               Begin DoDot:1

 +6                IF $PIECE(DGSD("DEP",RIEN,0),U,3)=""

                       SET FILERR(RULE)=""

               End DoDot:1

 +7        QUIT

7         ; SSN UNSPECIFIED

 +1       ; Note: RULE #305 in IVMZ7CD is a duplicate of this rule

 +2        IF $PIECE($GET(DGP("PAT",0)),U,9)=""

               SET FILERR(RULE)=""

 +3        QUIT

9         ; VETERAN STATUS UNSPECIFIED

 +1        IF $PIECE($GET(DGP("PAT","VET")),U)=""

               SET FILERR(RULE)=""

 +2        QUIT

11        ; SC PROMPT INCONSISTENT

 +1        NEW VET,SC,PTYPE

 +2       ; If VET Status is not specified (RULE 9) no need for this test

 +3        if $PIECE($GET(DGP("PAT","VET")),U)=""

               QUIT

 +4        SET VET=$PIECE(DGP("PAT","VET"),U,1)="Y"

           SET SC=$PIECE(DGP("PAT",.3),U,1)="Y"

 +5        IF 'VET

               IF SC

                   SET FILERR(RULE)=""

 +6        QUIT

13        ; POS UNSPECIFIED

 +1       ; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule

 +2        if $PIECE($GET(DGP("PAT","VET")),U,1)'="Y"

               QUIT

 +3       ; Make sure that the value in the field is valid -- DGRPC does this as well

 +4        IF '$DATA(^DIC(21,+$PIECE(DGP("PAT",.32),U,3),0))

               SET FILERR(RULE)=""

 +5        QUIT

15        ; INEL REASON UNSPECIFIED

 +1       ; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule

 +2        IF $PIECE(DGP("PAT",.15),U,2)

               IF $PIECE($GET(DGP("PAT",.3)),U,7)=""

                   SET FILERR(RULE)=""

 +3        QUIT

16        ; DATE OF DEATH IN FUTURE

 +1       ; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule

 +2        SET X=$PIECE($GET(DGP("PAT",.35)),U)

           IF X']""

               QUIT

 +3       ; Compare DOD to right now

 +4        IF X>$$NOW^XLFDT

               SET FILERR(RULE)=""

 +5        QUIT

19        ; ELIG/NONVET STAT INCONSISTENT

 +1       ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule

 +2        NEW VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE

 +3       ; Patient's VET status

 +4        SET VET=$PIECE($GET(DGP("PAT","VET")),U,1)

           IF VET=""

               SET FILERR(RULE)=""

               QUIT

 +5       ; do this check for NON-VET status only

 +6        if VET="Y"

               QUIT

 +7       ; Check PT type to see if we skip VET checks

 +8        SET PTYPE=$PIECE($GET(DGP("PAT","TYPE")),U,1)

 +9        IF PTYPE]""

               IF $PIECE(^DG(391,PTYPE,0),U,2)

                   QUIT

 +10      ; Eligibility Code

 +11       SET ELIG=$PIECE($GET(DGP("PAT",.36)),U,1)

           IF ELIG=""

               SET FILERR(RULE)=""

               QUIT

 +12      ;start in File #8

 +13       SET FILE8=$GET(^DIC(8,ELIG,0))

           IF FILE8=""

               SET FILERR(RULE)=""

               QUIT

 +14      ;using the pointer value in field #8 (node 0; piece 9)

 +15       SET MPTR=$PIECE(FILE8,U,9)

 +16      ;find the record in File #8.1

 +17       SET FILE81=$GET(^DIC(8.1,MPTR,0))

           IF FILE81=""

               SET FILERR(RULE)=""

               QUIT

 +18      ;check the Type field #4 (node 0; piece 5).

 +19       SET MTYPE=$PIECE(FILE81,U,5)

 +20      ; Pt's VET status must match NON-VET Status of Eligibility Code

 +21       IF VET'=MTYPE

               SET FILERR(RULE)=""

 +22       QUIT

24        ; POS/ELIG CODE INCONSISTENT

 +1       ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule

 +2        IF '$DATA(^DIC(21,+$PIECE(DGP("PAT",.32),U,3),"E",+$PIECE(DGP("PAT",.36),U,1)))

               SET FILERR(RULE)=""

 +3        QUIT

29        ; A&A CLAIMED, NONVET

 +1        IF $PIECE(DGP("PAT","VET"),U,1)'="Y"

               IF $PIECE($GET(^DPT(DFN,.362)),U,12)="Y"

                   SET FILERR(RULE)=""

 +2        QUIT

30        ; HOUSEBOUND CLAIMED, NONVET

 +1        IF $PIECE(DGP("PAT","VET"),U,1)'="Y"

               IF $PIECE($GET(^DPT(DFN,.362)),U,13)="Y"

                   SET FILERR(RULE)=""

 +2        QUIT

31        ; VA PENSION CLAIMED, NONVET

 +1        IF $PIECE(DGP("PAT","VET"),U,1)'="Y"

               IF $PIECE($GET(^DPT(DFN,.362)),U,14)="Y"

                   SET FILERR(RULE)=""

 +2        QUIT

34        ; POW CLAIMED, NONVET

 +1        IF $PIECE(DGP("PAT","VET"),U,1)'="Y"

               IF $PIECE($GET(^DPT(DFN,.52)),U,5)="Y"

                   SET FILERR(RULE)=""

 +2        QUIT

60        ; AGENT ORANGE EXP LOC MISSING

 +1       ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule.

 +2        IF $PIECE(DGP("PAT",.321),U,2)="Y"

               IF $PIECE(DGP("PAT",.321),U,13)=""

                   SET FILERR(RULE)=""

 +3        QUIT

72        ; MSE DATA MISSING/INCOMPLETE, turned off with DG*5.3*765

 +1       ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule.

 +2        NEW I,X

 +3        SET X=DGP("PAT",.32)

 +4       ;LAST

           FOR I=4,5,8

               IF $PIECE(X,U,I)'=""

                   IF '$$YY^IVMZ7CS($PIECE(X,U,6))

                       SET FILERR(RULE)=""

                       QUIT

 +5       ;NTL

           FOR I=9,10,13

               IF $PIECE(X,U,I)'=""

                   IF '$$YY^IVMZ7CS($PIECE(X,U,11))

                       SET FILERR(RULE)=""

                       QUIT

 +6       ;NNTL

           FOR I=14,15,18

               IF $PIECE(X,U,I)'=""

                   IF '$$YY^IVMZ7CS($PIECE(X,U,11))

                       SET FILERR(RULE)=""

 +7        QUIT

 +8       ;

74        ; CONFLICT DT MISSING/INCOMPLETE, turned off with DG*5.3*765

 +1       ; 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

 +1       ;

 +2        NEW I,T,FROM,TO,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON74,ON75,ON76

 +3        SET ON74=$$ON(74)

           SET ON75=$$ON(75)

           SET ON76=$$ON(76)

 +4       ; load range table

           SET I=$$RANGE^DGMSCK()

 +5        FOR I=1:1

               SET CONFL=$PIECE($TEXT(CONLIST+I),";;",3)

               if CONFL="QUIT"

                   QUIT

               Begin DoDot:1

 +6       ;we have to have a flag ERR because we don't want multiple

 +7       ;inconsistencies on a single conflict but we do want to

 +8       ;flag a single inconsistency on multiple conflicts

 +9                SET ERR=0

 +10               SET NODE=$PIECE(CONFL,U,1)

                   SET PCE=$PIECE(CONFL,U,2)

                   SET PCEFR=$PIECE(CONFL,U,3)

                   SET PCETO=$PIECE(CONFL,U,4)

 +11               SET RNGE=$PIECE(CONFL,U,5)

 +12               if $PIECE(DGP("PAT",NODE),U,PCE)'="Y"

                       QUIT

 +13               SET FROM=$PIECE(DGP("PAT",NODE),U,PCEFR)

                   SET TO=$PIECE(DGP("PAT",NODE),U,PCETO)

 +14      ; check rule 74 CONFLICT DT MISSING/INCOMPLETE

 +15               IF ON74

                       IF (RULE=74)

                           FOR T=FROM,TO

                               IF '$$YM^IVMZ7CS(T)

                                   SET FILERR(RULE)=""

                                   SET ERR=1

 +16               if ERR

                       QUIT

 +17      ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT

 +18               IF ON75

                       IF (RULE=75)

                           IF (FROM>TO)

                               SET FILERR(RULE)=""

                               SET ERR=1

 +19               if ERR

                       QUIT

 +20      ; check rule 76 INACCURATE CONFLICT DATE

 +21               if ERR

                       QUIT

 +22      ; can't calculate if range table is missing

                   if '$DATA(RANGE(RNGE))

                       QUIT

 +23      ; determine whether dates are withing conflict range

 +24               SET RFR=$PIECE(RANGE(RNGE),U,1)

                   SET RTO=$PIECE(RANGE(RNGE),U,2)

 +25               IF ON76

                       IF (RULE=76)

                           Begin DoDot:2

 +26                           IF '((RFR'>FROM)&((RTO'<TO)))

                                   SET FILERR(RULE)=""

                           End DoDot:2

               End DoDot:1

 +27       QUIT

78        ; INACCURATE COMBAT DT/LOC, turned off with DG*5.3*771

 +1        NEW I,T,FROM,TO,RULE,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON78,LOC

 +2       ; This tag checks COMBAT status and verifies that valid FROM & TO dates are found

 +3        SET RULE=78

 +4        IF '$$ON(RULE)

               QUIT

 +5       ; load range table

           SET I=$$RANGE^DGMSCK()

 +6        FOR I=1:1

               SET CONFL=$PIECE($TEXT(COMLIST+I),";;",3)

               if CONFL="QUIT"

                   QUIT

               Begin DoDot:1

 +7                SET NODE=$PIECE(CONFL,U,1)

                   SET PCE=$PIECE(CONFL,U,2)

                   SET PCEFR=$PIECE(CONFL,U,3)

                   SET PCETO=$PIECE(CONFL,U,4)

 +8                SET RNGE=$PIECE(CONFL,U,5)

 +9       ; if we have COMBAT data, get Service Location info, it comes under a different rule

 +10               if $PIECE(DGP("PAT",NODE),U,PCE)'="Y"

                       QUIT

 +11               SET RNGE=$$COMPOW^DGRPMS($PIECE(DGP("PAT",.52),U,12))

                   IF $GET(RNGE)=""

                       SET FILERR(RULE)=""

                       QUIT

 +12               SET FROM=$PIECE(DGP("PAT",NODE),U,PCEFR)

                   SET TO=$PIECE(DGP("PAT",NODE),U,PCETO)

 +13      ; determine whether Pt dates are within conflict range for specified location

 +14               SET RFR=$PIECE(RANGE(RNGE),U,1)

                   SET RTO=$PIECE(RANGE(RNGE),U,2)

 +15               IF '(RFR'>FROM&((FROM'>RTO)&((RTO'<TO)&((TO'<RFR)))))

                       SET FILERR(RULE)=""

               End DoDot:1

 +16       QUIT

81        ; COMBAT DT NOT WITHIN MSE, turned off with DG*5.3*765

 +1       ; this code is copied from DGRP3

 +2       ; MSFROMTO^DGMSCK creates a block for a continual MSE

 +3        NEW MSE,MSECHK,MSESET,ANYMSE,DGP81

 +4        IF '$PIECE($GET(DGP("PAT",.52)),U,12)

               QUIT

 +5       ;

 +6       ; we're calling into DG Legacy code so we have to modify some arrays

 +7        MERGE DGP81=DGP

           KILL DGP

 +8        MERGE DGP=DGP81("PAT")

 +9       ; set up the check

 +10       if '$GET(MSECHK)

               SET MSECHK=$$MSCK^DGMSCK

           if '$GET(MSESET)

               SET MSESET=$$MSFROMTO^DGMSCK

 +11      ; If COMBAT, but no MSE, then Range is NOT within MSE

 +12       IF '$GET(ANYMSE)

               Begin DoDot:1

 +13               SET FILERR(RULE)=""

 +14               KILL DGP

                   MERGE DGP=DGP81

               End DoDot:1

               QUIT

 +15       IF '$$RWITHIN^DGRPDT($PIECE(MSESET,U,1),$PIECE(MSESET,U,2),$PIECE($GET(DGP81("PAT",.52)),U,13),$PIECE($GET(DGP81("PAT",.52)),U,14))

               SET FILERR(RULE)=""

 +16       KILL DGP

           MERGE DGP=DGP81

 +17       QUIT

 +18      ;

83        ; BOS REQUIRES DATE W/IN WWII

 +1       ; this code is copied from DGRP3

 +2        NEW BOS,BOSN,MS,MSE,DGP83,OUT

 +3       ;IVM*2*153 uses mse data from DGPMSE array, if it exists

 +4        IF $DATA(DGPMSE)

               Begin DoDot:1

 +5                SET MS=0

FOR

                       SET MS=$ORDER(DGPMSE(MS))

                       if 'MS!($GET(OUT))

                           QUIT

                       Begin DoDot:2

 +6       ;Don't check MSE if verified by HEC

                           IF $PIECE(DGPMSE(MS),U,7)

                               QUIT

 +7                        SET BOS=$PIECE(DGPMSE(MS),U,3)

                           if 'BOS

                               QUIT

                           SET BOSN=$PIECE(^DIC(23,BOS,0),U)

 +8                        SET MSE=$ORDER(DGPMSE(MS,0))

                           if 'MSE

                               QUIT

                           SET MSE="MSE-"_MSE

 +9                        IF $$BRANCH^DGRPMS(BOS_U_BOSN)

                               IF '$$WWII^DGRPMS(DFN,"",MSE)

                                   SET FILERR(RULE)=""

                                   SET OUT=1

                                   QUIT

                       End DoDot:2

               End DoDot:1

               QUIT

 +10      ;Otherwise, get MSE data from DGP("PAT",.32)

 +11       if '$DATA(DGP("PAT",.32))

               QUIT

 +12      ; we're calling into DG Legacy code so we have to modify some arrays

 +13       MERGE DGP83=DGP

           KILL DGP

 +14       MERGE DGP=DGP83("PAT")

 +15       FOR MS=1:1:3

               Begin DoDot:1

 +16               IF MS=2

                       IF $PIECE(DGP83("PAT",.32),U,19)'="Y"

                           QUIT

 +17               IF MS=3

                       IF $PIECE(DGP83("PAT",.32),U,20)'="Y"

                           QUIT

 +18               SET BOS=$PIECE(DGP83("PAT",.32),U,(5*MS))

                   if 'BOS

                       QUIT

                   SET BOSN=$PIECE($GET(^DIC(23,BOS,0)),U)

 +19               SET MSE=$PIECE("MSL^MSNTL^MSNNTL",U,MS)

 +20               IF $$BRANCH^DGRPMS(BOS_U_BOSN)

                       IF '$$WWII^DGRPMS(DFN,"",MSE)

                           SET FILERR(RULE)=""

               End DoDot:1

 +21      ; fix the arrays before we leave

 +22       KILL DGP

           MERGE DGP=DGP83

 +23       QUIT

85        ; FILIPINO VET SHOULD BE VET='Y'

 +1       ; this code is copied from DGRP3

 +2        NEW MS,BOS,FV,FILV,NOTFV,MSE,RULE2,DGVT,DGP85

 +3       ;IVM*2*153 use mse data from DGPMSE array, if it exists

 +4       ; we're calling into DG Legacy code so we have to modify some arrays

 +5        SET DGVT=$PIECE($GET(DGP("PAT","VET")),U)="Y"

 +6       ; will also check RULE #86 INEL FIL VET SHOULD BE VET='N'

           SET RULE2=86

 +7        IF $DATA(DGPMSE)

               Begin DoDot:1

 +8                SET MS=0

FOR

                       SET MS=$ORDER(DGPMSE(MS))

                       if 'MS

                           QUIT

                       Begin DoDot:2

 +9       ;Don't check MSE if verified by HEC

                           IF $PIECE(DGPMSE(MS),U,7)

                               QUIT

 +10                       SET BOS=$PIECE(DGPMSE(MS),U,3)

                           SET FV=$$FV^DGRPMS(BOS)

                           IF 'FV

                               SET NOTFV=""

                               QUIT

 +11                       SET MSE=$ORDER(DGPMSE(MS,0))

                           if 'MSE

                               QUIT

                           SET MSE="MSE-"_MSE

 +12                       IF '$$WWII^DGRPMS(DFN,"",MSE)

                               SET FILV("I")=""

                               QUIT

 +13                       IF FV=2

                               SET FILV("E")=""

                               QUIT

 +14                       IF $PIECE(DGP("PAT",.321),U,14)=""!($PIECE(DGP("PAT",.321),U,14)="NO")

                               SET FILV("I")=""

                               QUIT

 +15                       SET FILV("E")=""

                       End DoDot:2

               End DoDot:1

 +16      ;Otherwise, get MSE data from DGP(.32)

 +17      IF '$TEST

               IF $DATA(DGP("PAT",.32))

                   Begin DoDot:1

 +18      ; we're calling into DG Legacy code so we have to modify some arrays

 +19                   MERGE DGP85=DGP

                       KILL DGP

 +20                   MERGE DGP=DGP85("PAT")

 +21                   FOR MS=1:1:3

                           Begin DoDot:2

 +22                           IF MS=2

                                   IF $PIECE(DGP85("PAT",.32),U,19)'="Y"

                                       QUIT

 +23                           IF MS=3

                                   IF $PIECE(DGP85("PAT",.32),U,20)'="Y"

                                       QUIT

 +24                           SET BOS=$PIECE(DGP85("PAT",.32),U,(5*MS))

                               SET FV=$$FV^DGRPMS(BOS)

                               IF 'FV

                                   SET NOTFV=""

                                   QUIT

 +25                           SET MSE=$PIECE("MSL^MSNTL^MSNNTL",U,MS)

 +26                           IF '$$WWII^DGRPMS(DFN,"",MSE)

                                   SET FILV("I")=""

                                   QUIT

 +27                           IF FV=2

                                   SET FILV("E")=""

                                   QUIT

 +28                           IF $PIECE(DGP85("PAT",.321),U,14)=""!($PIECE(DGP85("PAT",.321),U,14)="NO")

                                   SET FILV("I")=""

                                   QUIT

 +29                           SET FILV("E")=""

                           End DoDot:2

 +30      ; fix the arrays

 +31                   KILL DGP

                       MERGE DGP=DGP85

                   End DoDot:1

 +32       IF $DATA(FILV)

               Begin DoDot:1

 +33               IF DGVT'=1

                       IF $DATA(FILV("E"))

                           SET FILERR(RULE)=""

 +34               IF DGVT=1

                       IF '$DATA(NOTFV)

                           IF '$DATA(FILV("E"))

                               IF $DATA(FILV("I"))

                                   SET FILERR(RULE2)=""

               End DoDot:1

 +35       QUIT

86        ; INEL FIL VET SHOULD BE VET='N'

 +1       ; This rule is satisfied in #85 above

 +2        QUIT

ON(RULE)  ;verify RULE is turned on

 +1        NEW ON,Y

 +2        SET ON=0

 +3        SET Y=^DGIN(38.6,RULE,0)

 +4        IF $PIECE(Y,U,6)

               SET ON=1

 +5        QUIT ON

CONLIST   ;;CONFLICT;;NODE^PIECE^FROM^TO^RANGE  -- offset list, do not add comments

 +1       ;;VIETNAM;;.321^1^4^5^VIET

 +2       ;;LEBANON;;.322^1^2^3^LEB

 +3       ;;GRENADA;;.322^4^5^6^GREN

 +4       ;;PANAMA;;.322^7^8^9^PAN

 +5       ;;PERSIAN GULF;;.322^10^11^12^GULF

 +6       ;;SOMALIA;;.322^16^17^18^SOM

 +7       ;;YUGOSLAVIA;;.322^19^20^21^YUG

 +8       ;;QUIT;;QUIT

COMLIST   ;;COMBAT;;NODE^PIECE^FROM^TO^RANGE  -- offset list, do not add comments

 +1       ;;WWI;;.52^11^13^14^WWI

 +2       ;;WWIIE;;.52^11^13^14^WWIIE

 +3       ;;WWIIP;;.52^11^13^14^WWIIP

 +4       ;;KOREA;;.52^11^13^14^KOR

 +5       ;;OTHER;;.52^11^13^14^OTHER

 +6       ;;VIETNAM;;.52^11^13^14^VIET

 +7       ;;LEBANON;;.52^11^13^14^LEB

 +8       ;;GRENADA;;.52^11^13^14^GREN

 +9       ;;PANAMA;;.52^11^13^14^PAN

 +10      ;;PERSIAN GULF;;.52^11^13^14^GULF

 +11      ;;SOMALIA;;.52^11^13^14^SOM

 +12      ;;YUGOSLAVIA;;.52^11^13^14^YUG

 +13      ;;QUIT;;QUIT

IVMZ7CR.m