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
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>$$NOW^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,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
Q
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)=""
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,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
