DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/14/11 4:36pm
;;5.3;PIMS;**108,161,247,485,672,673,688,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 7/13/2001 added Quit to TAD subroutine
FFP ; DGFFP Access key required
I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4") K X
Q
EK ;EKey Rqrd
I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !?4,$C(7),"Eligibility Key required to edit this field." K X
Q
EV ;EK rqrd if Elig Ver
I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D EN^DDIOL("Eligibility verified...Eligibility Key required to edit this field.","","!?4") K X
Q
EV2 ;if elig is ver Discharged Due to Disability can't be edited - DG 672
;if elig is ver P&T and P&T Eff Date can't be edited - DG*5.3*688
I $D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D
. I $P(^DPT(DFN,.361),U,3)'="H" Q
. D EN^DDIOL("Eligibility verified at the HEC...NO EDITING!","","!?4") K X
Q
SV ;EK Rqrd if Svc Rcrd Ver
I "NU"'[$E(X) D VET Q:'$D(X)
SV1 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.32)) I $P(^(.32),U,2)]"" D EN^DDIOL("Service Record verfied...Eligibility Key required to edit this field.","","!?4") K X
Q
MV ;EK Rqrd if Money Ver
I "NU"'[$E(X) D VET Q:'$D(X)
I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.3)) I $P(^(.3),U,6)]"" W !?4,$C(7),"Monetary Benefits verified...Eligibility Key required to edit this field." K X
Q
VET ;Veteran
S DGVV=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:""),DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"")
I $D(^DPT(DFN,"VET")),^("VET")'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X
K DGVV Q
VAGE ;Vet Age
S DGDATA=X,X1=DT,X2=$S($D(DFN):$P(^DPT(DFN,0),U,3),1:DPTIDS(.03)) S X=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
I X<17 W !?4,$C(7),"Applicant is TOO YOUNG to be a veteran...ONLY ",X," YEARS OLD!!",!?4,"See your supervisor if you require assistance." K X,X1,X2,DGDATA Q
S X=DGDATA K X1,X2,DGDATA Q
AO ;Agent Orange
D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,2)'="Y":1,1:0) W !?4,$C(7),"Exposure to Agent Orange not indicated...NO EDITING!" K X
Q
EC ;SW Asia Contaminants - name change from Env. Contam. DG*5.3*688
D SV I $D(X),$S('$D(^DPT(DFN,.322)):1,$P(^(.322),U,13)'="Y":1,1:0) W !?4,$C(7),"Southwest Asia Conditions not indicated...NO EDITING!" K X
I $D(X) I X<2900802 K X W !?4,$C(7),"Date must be on or after 8/2/1990!"
Q
COM ;Combat
D SV I $D(X),$S('$D(^DPT(DFN,.52)):1,$P(^(.52),U,11)'="Y":1,1:0) W !?4,$C(7),"Service in Combat Zone not indicated...NO EDITING!" K X
Q
INE ;Ineligible
D EK I $D(X),$S('$D(^DPT(DFN,.15)):1,$P(^(.15),U,2)']"":1,1:0) W !?4,$C(7),"Requirement for 'Ineligible patient' data not indicated...NO EDITING!" K X
Q
IR ;ION Rad
D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,3)'="Y":1,1:0) W !?4,$C(7),"Exposure to Ionizing Radiation is not indicated...NO EDITING!" K X
Q
POW ;Prisoner of War
D SV I $D(X),$S('$D(^DPT(DFN,.52)):1,$P(^(.52),U,5)'="Y":1,1:0) W !?5,$C(7),"Not identified as a former Prisoner of War...NO EDITING!" K X
Q
SER1 ;NTL Svc
D SV I $D(X),$S('$D(^DPT(DFN,.32)):1,$P(^(.32),U,19)'="Y":1,X="N":0,1:0) W !?4,$C(7),"Other Periods of Service are not indicated...NO EDITING!" K X
Q
SER2 ;NNTL
D SV I $D(X),$S('$D(^DPT(DFN,.32)):1,$P(^(.32),U,20)'="Y":1,X="N":0,1:0) W !?4,$C(7),"Third Period of Service is not indicated...NO EDITING!" K X
Q
TAD ;Temp Add Edit
Q ;IHS/ANMC/LJF 7/13/2001 IHS needs to access temp phone number
I $S('$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) W !?4,$C(7),"Requirement for Temporary Address data not indicated...NO EDITING!" K X
Q
TADD ;Temp Address Delete?
Q:'$D(^DPT(DFN,.121)) I $P(^(.121),"^",9)="N"!($P(^(.121),"^",1,6)="^^^^^") Q
ASK W !,"Do you want to delete all temporary address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove temporary address information, 'N'o to leave data in file" G ASK
Q:%'=1 D EN^DGCLEAR(DFN,"TEMP") Q
VN ;Viet Svc
D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,1)'="Y":1,1:0) I "UN"'[$E(X) W !?4,$C(7),"Service in Republic of Vietnam not indicated...NO EDITING!" K X
Q
;
OEIF ;OIF/ OEF/ UNKNOWN OEF/OIF Svc
D SV
Q
SVED ;Lebanon, Grenada, Panama, Persian Gulf & Yugoslavia svc edit
; (from and to dates)
;DGX = piece position of corresponding service indicated? field
; for multiple serv indicated dgx=sv1^sv2^...
;DGSV= service (sv1, sv2 from above)
;DGOK= 1=YES,at least one of the required sv indicated is yes,0=NO
D SV I '$D(X) K DGX Q
N DGSV,DGOK,DGPC,PC
S DGOK=0
F PC=1:1 S DGSV=$P(DGX,U,PC) Q:DGSV']"" S:$P($G(^DPT(DFN,.322)),U,DGSV)="Y" DGOK=1
S PC=PC-1
I DGOK=0 D
.I "UN"'[$E(X) D
..W !?4,$C(7),"Service in "
..F DGPC=1:1:PC D
...S DGSV=$P(DGX,U,DGPC) W $S(DGSV=1:"Lebanon",DGSV=4:"Grenada",DGSV=7:"Panama",DGSV=10:"Persian Gulf",DGSV=16:"Somalia",DGSV=19:"Yugoslavia",1:"")
...W:(DGPC<PC) " or "
..W " not indicated...NO EDITING!" K X
K DGX
Q
PTDT ;P&T Effective Date cannot be edited unless P&T is 'YES' - DG*5.3*688
;P&T Effective Date cannot be earlier than the DOB or after DOD - DG*5.3*754
I $S('$D(^DPT(DFN,.3)):1,$P(^(.3),U,4)'="Y":1,1:0) D EN^DDIOL("P&T not indicated...no editing","","!?4") K X Q
N DGFLD
S DGFLD=$P(^DD(2,.3013,0),U)
I $G(X)<$P(^DPT(DFN,0),U,3) D Q
. D DOBDOD(DGFLD,1)
I $P($G(^DPT(DFN,.35)),U)]"" D
. I $G(X)>$P(^DPT(DFN,.35),U) D
. . D DOBDOD(DGFLD,2)
Q
POWV ;POW Status cannot be edited once it has been verified by the HEC
;DG*5.3*688
I $P($G(^DPT(DFN,.52)),U,9)'="" D EN^DDIOL("POW Status verified at the HEC...NO EDITING!!","","!?4") K X
Q
INEL ;check ineligible date - cannot be before DOB
;DG*5.3*754
N DGFLD
I $G(X)<$P(^DPT(DFN,0),U,3) D
. S DGFLD=$P(^DD(2,.152,0),U)
. D DOBDOD(DGFLD,1)
Q
INCOM ;check date ruled incompetent (VA) - cannot be before DOB
;or after DOD - DG*5.3*754)
N DGFLD
S DGFLD=$P(^DD(2,.291,0),U)
I $G(X)<$P(^DPT(DFN,0),U,3) D Q
. D DOBDOD(DGFLD,1)
I $P($G(^DPT(DFN,.35)),U)]"" D
. I $G(X)>$P(^DPT(DFN,.35),U) D
. . D DOBDOD(DGFLD,2)
Q
INCOM2 ;check date ruled incompetent (civil - cannot be before DOB
;or after DOD - DG*5.3*754)
N DGFLD
S DGFLD=$P(^DD(2,.292,0),U)
I $G(X)<$P(^DPT(DFN,0),U,3) D Q
. D DOBDOD(DGFLD,1)
I $P($G(^DPT(DFN,.35)),U)]"" D
. I $G(X)>$P(^DPT(DFN,.35),U) D
. . D DOBDOD(DGFLD,2)
Q
DOBDOD(DGFLD,DGX) ;called from subroutines to check if
;date is before DOB or after DOD. The subroutines
;are called from the field input transforms. DG*5.3*754
I $G(DGFLD)']"" Q
I "12"'[$G(DGX) Q
D EN^DDIOL(DGFLD_" cannot be "_$S(DGX=1:"prior to",1:"after")_" Date of "_$S(DGX=1:"Birth.",1:"Death."),"","!?4")
K X
Q
DEATH ;new date constraints added with ESR 3.1 - DG*5.3*754
Q:$G(X)'>0
N DGFLD
S DGFLD=$P(^DD(2,.351,0),U)
;check for DOD before DOB
I X<$P(^DPT(DFN,0),U,3) D DOBDOD(DGFLD,1) Q
;check for DOD before P&T Effective Date
I X<$P($G(^DPT(DFN,.3)),U,13) D Q
. D EN^DDIOL(DGFLD_" cannot be prior to the P&T Effective Date","","!?4")
. K X
;check for DOD before Date Ruled Incompetent (VA)
I X<$P($G(^DPT(DFN,.29)),U) D Q
. D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (VA)","","!?4")
. K X
;check for DOD before Date Ruled Incompetent (Civil)
I X<$P($G(^DPT(DFN,.29)),U,2) D Q
. D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (Civil)","","!?4")
. K X
;check for DOD before Enrollment Application Date
;I $P($G(^DPT(DFN,"ENR")),U)>0 D
;. N DGENR
;. S DGENR=$P(^DPT(DFN,"ENR"),U)
;. Q:$G(DGENR)']""
;. Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
;. I X<$P(^DGEN(27.11,DGENR,0),U) D
;. . D EN^DDIOL(DGFLD_" cannot be prior to the Enrollment Application Date","","!?4")
;. . K X
Q
BIRTH ;checks for DOB added with DG*5.3*754
I (($G(EASAPP)'="")&($G(DGADDF)=1)) Q ;Ignore New 1010EZ patients
Q:$G(X)'>0
Q:'$D(DA)
N DFN
S DFN=DA
N DGFLD
S DGFLD=$P(^DD(2,.03,0),U)
;check for DOB after Ineligible Date
I $P($G(^DPT(DFN,.15)),U,2)]"" D Q:'$G(X)
. I X>$P(^DPT(DFN,.15),U,2) D
. . D EN^DDIOL(DGFLD_" cannot be after the Ineligible Date","","!?4") K X
;check for DOB after Enrollment Application Date
I $P($G(^DPT(DFN,"ENR")),U)>0 D
. N DGENR
. S DGENR=$P(^DPT(DFN,"ENR"),U)
. Q:$G(DGENR)']""
. Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
. I X>$P(^DGEN(27.11,DGENR,0),U) D
. . D EN^DDIOL(DGFLD_" cannot be after the Enrollment Application Date","","!?4")
. . K X
Q
MSE ;Military Service Episode data cannot be edited once it has been
;verified by the HEC
;DG*5.3*797
I "NU"'[$E(X) D VET Q:'$D(X)
I $P($G(^DPT(DFN,.3216,DA,0)),U,7)=1 D EN^DDIOL("MSE data verified at the HEC...NO EDITING!!","","!?4") K X
Q
DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/14/11 4:36pm
+1 ;;5.3;PIMS;**108,161,247,485,672,673,688,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 7/13/2001 added Quit to TAD subroutine
FFP ; DGFFP Access key required
+1 IF '$DATA(^XUSEC("DGFFP ACCESS",DUZ))
DO EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4")
KILL X
+2 QUIT
EK ;EKey Rqrd
+1 IF '$DATA(^XUSEC("DG ELIGIBILITY",DUZ))
WRITE !?4,$CHAR(7),"Eligibility Key required to edit this field."
KILL X
+2 QUIT
EV ;EK rqrd if Elig Ver
+1 IF '$DATA(^XUSEC("DG ELIGIBILITY",DUZ))
IF $DATA(^DPT(DFN,.361))
IF $PIECE(^(.361),U,1)="V"
DO EN^DDIOL("Eligibility verified...Eligibility Key required to edit this field.","","!?4")
KILL X
+2 QUIT
EV2 ;if elig is ver Discharged Due to Disability can't be edited - DG 672
+1 ;if elig is ver P&T and P&T Eff Date can't be edited - DG*5.3*688
+2 IF $DATA(^DPT(DFN,.361))
IF $PIECE(^(.361),U,1)="V"
Begin DoDot:1
+3 IF $PIECE(^DPT(DFN,.361),U,3)'="H"
QUIT
+4 DO EN^DDIOL("Eligibility verified at the HEC...NO EDITING!","","!?4")
KILL X
End DoDot:1
+5 QUIT
SV ;EK Rqrd if Svc Rcrd Ver
+1 IF "NU"'[$EXTRACT(X)
DO VET
IF '$DATA(X)
QUIT
SV1 IF '$DATA(^XUSEC("DG ELIGIBILITY",DUZ))
IF $DATA(^DPT(DFN,.32))
IF $PIECE(^(.32),U,2)]""
DO EN^DDIOL("Service Record verfied...Eligibility Key required to edit this field.","","!?4")
KILL X
+1 QUIT
MV ;EK Rqrd if Money Ver
+1 IF "NU"'[$EXTRACT(X)
DO VET
IF '$DATA(X)
QUIT
+2 IF '$DATA(^XUSEC("DG ELIGIBILITY",DUZ))
IF $DATA(^DPT(DFN,.3))
IF $PIECE(^(.3),U,6)]""
WRITE !?4,$CHAR(7),"Monetary Benefits verified...Eligibility Key required to edit this field."
KILL X
+3 QUIT
VET ;Veteran
+1 SET DGVV=$SELECT($DATA(^DPT(DFN,"TYPE")):^("TYPE"),1:"")
SET DGVV=$SELECT($DATA(^DG(391,+DGVV,0)):$PIECE(^(0),"^",2),1:"")
+2 IF $DATA(^DPT(DFN,"VET"))
IF ^("VET")'="Y"
IF 'DGVV
DO EN^DDIOL("Applicant is NOT a veteran!!","","!?4")
KILL X
+3 KILL DGVV
QUIT
VAGE ;Vet Age
+1 SET DGDATA=X
SET X1=DT
SET X2=$SELECT($DATA(DFN):$PIECE(^DPT(DFN,0),U,3),1:DPTIDS(.03))
SET X=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
+2 IF X<17
WRITE !?4,$CHAR(7),"Applicant is TOO YOUNG to be a veteran...ONLY ",X," YEARS OLD!!",!?4,"See your supervisor if you require assistance."
KILL X,X1,X2,DGDATA
QUIT
+3 SET X=DGDATA
KILL X1,X2,DGDATA
QUIT
AO ;Agent Orange
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.321)):1,$PIECE(^(.321),U,2)'="Y":1,1:0)
WRITE !?4,$CHAR(7),"Exposure to Agent Orange not indicated...NO EDITING!"
KILL X
+2 QUIT
EC ;SW Asia Contaminants - name change from Env. Contam. DG*5.3*688
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.322)):1,$PIECE(^(.322),U,13)'="Y":1,1:0)
WRITE !?4,$CHAR(7),"Southwest Asia Conditions not indicated...NO EDITING!"
KILL X
+2 IF $DATA(X)
IF X<2900802
KILL X
WRITE !?4,$CHAR(7),"Date must be on or after 8/2/1990!"
+3 QUIT
COM ;Combat
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.52)):1,$PIECE(^(.52),U,11)'="Y":1,1:0)
WRITE !?4,$CHAR(7),"Service in Combat Zone not indicated...NO EDITING!"
KILL X
+2 QUIT
INE ;Ineligible
+1 DO EK
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.15)):1,$PIECE(^(.15),U,2)']"":1,1:0)
WRITE !?4,$CHAR(7),"Requirement for 'Ineligible patient' data not indicated...NO EDITING!"
KILL X
+2 QUIT
IR ;ION Rad
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.321)):1,$PIECE(^(.321),U,3)'="Y":1,1:0)
WRITE !?4,$CHAR(7),"Exposure to Ionizing Radiation is not indicated...NO EDITING!"
KILL X
+2 QUIT
POW ;Prisoner of War
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.52)):1,$PIECE(^(.52),U,5)'="Y":1,1:0)
WRITE !?5,$CHAR(7),"Not identified as a former Prisoner of War...NO EDITING!"
KILL X
+2 QUIT
SER1 ;NTL Svc
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.32)):1,$PIECE(^(.32),U,19)'="Y":1,X="N":0,1:0)
WRITE !?4,$CHAR(7),"Other Periods of Service are not indicated...NO EDITING!"
KILL X
+2 QUIT
SER2 ;NNTL
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.32)):1,$PIECE(^(.32),U,20)'="Y":1,X="N":0,1:0)
WRITE !?4,$CHAR(7),"Third Period of Service is not indicated...NO EDITING!"
KILL X
+2 QUIT
TAD ;Temp Add Edit
+1 ;IHS/ANMC/LJF 7/13/2001 IHS needs to access temp phone number
QUIT
+2 IF $SELECT('$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),U,9)'="Y":1,1:0)
WRITE !?4,$CHAR(7),"Requirement for Temporary Address data not indicated...NO EDITING!"
KILL X
+3 QUIT
TADD ;Temp Address Delete?
+1 IF '$DATA(^DPT(DFN,.121))
QUIT
IF $PIECE(^(.121),"^",9)="N"!($PIECE(^(.121),"^",1,6)="^^^^^")
QUIT
ASK WRITE !,"Do you want to delete all temporary address data"
SET %=2
DO YN^DICN
IF %Y["?"
WRITE !,"Answer 'Y'es to remove temporary address information, 'N'o to leave data in file"
GOTO ASK
+1 IF %'=1
QUIT
DO EN^DGCLEAR(DFN,"TEMP")
QUIT
VN ;Viet Svc
+1 DO SV
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.321)):1,$PIECE(^(.321),U,1)'="Y":1,1:0)
IF "UN"'[$EXTRACT(X)
WRITE !?4,$CHAR(7),"Service in Republic of Vietnam not indicated...NO EDITING!"
KILL X
+2 QUIT
+3 ;
OEIF ;OIF/ OEF/ UNKNOWN OEF/OIF Svc
+1 DO SV
+2 QUIT
SVED ;Lebanon, Grenada, Panama, Persian Gulf & Yugoslavia svc edit
+1 ; (from and to dates)
+2 ;DGX = piece position of corresponding service indicated? field
+3 ; for multiple serv indicated dgx=sv1^sv2^...
+4 ;DGSV= service (sv1, sv2 from above)
+5 ;DGOK= 1=YES,at least one of the required sv indicated is yes,0=NO
+6 DO SV
IF '$DATA(X)
KILL DGX
QUIT
+7 NEW DGSV,DGOK,DGPC,PC
+8 SET DGOK=0
+9 FOR PC=1:1
SET DGSV=$PIECE(DGX,U,PC)
IF DGSV']""
QUIT
IF $PIECE($GET(^DPT(DFN,.322)),U,DGSV)="Y"
SET DGOK=1
+10 SET PC=PC-1
+11 IF DGOK=0
Begin DoDot:1
+12 IF "UN"'[$EXTRACT(X)
Begin DoDot:2
+13 WRITE !?4,$CHAR(7),"Service in "
+14 FOR DGPC=1:1:PC
Begin DoDot:3
+15 SET DGSV=$PIECE(DGX,U,DGPC)
WRITE $SELECT(DGSV=1:"Lebanon",DGSV=4:"Grenada",DGSV=7:"Panama",DGSV=10:"Persian Gulf",DGSV=16:"Somalia",DGSV=19:"Yugoslavia",1:"")
+16 IF (DGPC<PC)
WRITE " or "
End DoDot:3
+17 WRITE " not indicated...NO EDITING!"
KILL X
End DoDot:2
End DoDot:1
+18 KILL DGX
+19 QUIT
PTDT ;P&T Effective Date cannot be edited unless P&T is 'YES' - DG*5.3*688
+1 ;P&T Effective Date cannot be earlier than the DOB or after DOD - DG*5.3*754
+2 IF $SELECT('$DATA(^DPT(DFN,.3)):1,$PIECE(^(.3),U,4)'="Y":1,1:0)
DO EN^DDIOL("P&T not indicated...no editing","","!?4")
KILL X
QUIT
+3 NEW DGFLD
+4 SET DGFLD=$PIECE(^DD(2,.3013,0),U)
+5 IF $GET(X)<$PIECE(^DPT(DFN,0),U,3)
Begin DoDot:1
+6 DO DOBDOD(DGFLD,1)
End DoDot:1
QUIT
+7 IF $PIECE($GET(^DPT(DFN,.35)),U)]""
Begin DoDot:1
+8 IF $GET(X)>$PIECE(^DPT(DFN,.35),U)
Begin DoDot:2
+9 DO DOBDOD(DGFLD,2)
End DoDot:2
End DoDot:1
+10 QUIT
POWV ;POW Status cannot be edited once it has been verified by the HEC
+1 ;DG*5.3*688
+2 IF $PIECE($GET(^DPT(DFN,.52)),U,9)'=""
DO EN^DDIOL("POW Status verified at the HEC...NO EDITING!!","","!?4")
KILL X
+3 QUIT
INEL ;check ineligible date - cannot be before DOB
+1 ;DG*5.3*754
+2 NEW DGFLD
+3 IF $GET(X)<$PIECE(^DPT(DFN,0),U,3)
Begin DoDot:1
+4 SET DGFLD=$PIECE(^DD(2,.152,0),U)
+5 DO DOBDOD(DGFLD,1)
End DoDot:1
+6 QUIT
INCOM ;check date ruled incompetent (VA) - cannot be before DOB
+1 ;or after DOD - DG*5.3*754)
+2 NEW DGFLD
+3 SET DGFLD=$PIECE(^DD(2,.291,0),U)
+4 IF $GET(X)<$PIECE(^DPT(DFN,0),U,3)
Begin DoDot:1
+5 DO DOBDOD(DGFLD,1)
End DoDot:1
QUIT
+6 IF $PIECE($GET(^DPT(DFN,.35)),U)]""
Begin DoDot:1
+7 IF $GET(X)>$PIECE(^DPT(DFN,.35),U)
Begin DoDot:2
+8 DO DOBDOD(DGFLD,2)
End DoDot:2
End DoDot:1
+9 QUIT
INCOM2 ;check date ruled incompetent (civil - cannot be before DOB
+1 ;or after DOD - DG*5.3*754)
+2 NEW DGFLD
+3 SET DGFLD=$PIECE(^DD(2,.292,0),U)
+4 IF $GET(X)<$PIECE(^DPT(DFN,0),U,3)
Begin DoDot:1
+5 DO DOBDOD(DGFLD,1)
End DoDot:1
QUIT
+6 IF $PIECE($GET(^DPT(DFN,.35)),U)]""
Begin DoDot:1
+7 IF $GET(X)>$PIECE(^DPT(DFN,.35),U)
Begin DoDot:2
+8 DO DOBDOD(DGFLD,2)
End DoDot:2
End DoDot:1
+9 QUIT
DOBDOD(DGFLD,DGX) ;called from subroutines to check if
+1 ;date is before DOB or after DOD. The subroutines
+2 ;are called from the field input transforms. DG*5.3*754
+3 IF $GET(DGFLD)']""
QUIT
+4 IF "12"'[$GET(DGX)
QUIT
+5 DO EN^DDIOL(DGFLD_" cannot be "_$SELECT(DGX=1:"prior to",1:"after")_" Date of "_$SELECT(DGX=1:"Birth.",1:"Death."),"","!?4")
+6 KILL X
+7 QUIT
DEATH ;new date constraints added with ESR 3.1 - DG*5.3*754
+1 IF $GET(X)'>0
QUIT
+2 NEW DGFLD
+3 SET DGFLD=$PIECE(^DD(2,.351,0),U)
+4 ;check for DOD before DOB
+5 IF X<$PIECE(^DPT(DFN,0),U,3)
DO DOBDOD(DGFLD,1)
QUIT
+6 ;check for DOD before P&T Effective Date
+7 IF X<$PIECE($GET(^DPT(DFN,.3)),U,13)
Begin DoDot:1
+8 DO EN^DDIOL(DGFLD_" cannot be prior to the P&T Effective Date","","!?4")
+9 KILL X
End DoDot:1
QUIT
+10 ;check for DOD before Date Ruled Incompetent (VA)
+11 IF X<$PIECE($GET(^DPT(DFN,.29)),U)
Begin DoDot:1
+12 DO EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (VA)","","!?4")
+13 KILL X
End DoDot:1
QUIT
+14 ;check for DOD before Date Ruled Incompetent (Civil)
+15 IF X<$PIECE($GET(^DPT(DFN,.29)),U,2)
Begin DoDot:1
+16 DO EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (Civil)","","!?4")
+17 KILL X
End DoDot:1
QUIT
+18 ;check for DOD before Enrollment Application Date
+19 ;I $P($G(^DPT(DFN,"ENR")),U)>0 D
+20 ;. N DGENR
+21 ;. S DGENR=$P(^DPT(DFN,"ENR"),U)
+22 ;. Q:$G(DGENR)']""
+23 ;. Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
+24 ;. I X<$P(^DGEN(27.11,DGENR,0),U) D
+25 ;. . D EN^DDIOL(DGFLD_" cannot be prior to the Enrollment Application Date","","!?4")
+26 ;. . K X
+27 QUIT
BIRTH ;checks for DOB added with DG*5.3*754
+1 ;Ignore New 1010EZ patients
IF (($GET(EASAPP)'="")&($GET(DGADDF)=1))
QUIT
+2 IF $GET(X)'>0
QUIT
+3 IF '$DATA(DA)
QUIT
+4 NEW DFN
+5 SET DFN=DA
+6 NEW DGFLD
+7 SET DGFLD=$PIECE(^DD(2,.03,0),U)
+8 ;check for DOB after Ineligible Date
+9 IF $PIECE($GET(^DPT(DFN,.15)),U,2)]""
Begin DoDot:1
+10 IF X>$PIECE(^DPT(DFN,.15),U,2)
Begin DoDot:2
+11 DO EN^DDIOL(DGFLD_" cannot be after the Ineligible Date","","!?4")
KILL X
End DoDot:2
End DoDot:1
IF '$GET(X)
QUIT
+12 ;check for DOB after Enrollment Application Date
+13 IF $PIECE($GET(^DPT(DFN,"ENR")),U)>0
Begin DoDot:1
+14 NEW DGENR
+15 SET DGENR=$PIECE(^DPT(DFN,"ENR"),U)
+16 IF $GET(DGENR)']""
QUIT
+17 IF $PIECE($GET(^DGEN(27.11,DGENR,0)),U,2)'=DFN
QUIT
+18 IF X>$PIECE(^DGEN(27.11,DGENR,0),U)
Begin DoDot:2
+19 DO EN^DDIOL(DGFLD_" cannot be after the Enrollment Application Date","","!?4")
+20 KILL X
End DoDot:2
End DoDot:1
+21 QUIT
MSE ;Military Service Episode data cannot be edited once it has been
+1 ;verified by the HEC
+2 ;DG*5.3*797
+3 IF "NU"'[$EXTRACT(X)
DO VET
IF '$DATA(X)
QUIT
+4 IF $PIECE($GET(^DPT(DFN,.3216,DA,0)),U,7)=1
DO EN^DDIOL("MSE data verified at the HEC...NO EDITING!!","","!?4")
KILL X
+5 QUIT
