- DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/14/11 4:36pm
- ;;5.3;Registration;**108,161,247,485,672,673,688,754,797,1040**;Aug 13, 1993;Build 15
- 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
- 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
- ; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable
- I $G(DTOUT) S DGTMOT=1
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGLOCK 8830 printed Feb 19, 2025@00:10:05 Page 2
- DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/14/11 4:36pm
- +1 ;;5.3;Registration;**108,161,247,485,672,673,688,754,797,1040**;Aug 13, 1993;Build 15
- 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 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
- +2 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 ; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable
- +2 IF $GET(DTOUT)
- SET DGTMOT=1
- +3 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