Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGLOCK

DGLOCK.m

Go to the documentation of this file.
  1. 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
  1. FFP ; DGFFP Access key required
  1. I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4") K X
  1. Q
  1. EK ;EKey Rqrd
  1. I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !?4,$C(7),"Eligibility Key required to edit this field." K X
  1. Q
  1. EV ;EK rqrd if Elig Ver
  1. 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
  1. Q
  1. 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
  1. I $D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D
  1. . I $P(^DPT(DFN,.361),U,3)'="H" Q
  1. . D EN^DDIOL("Eligibility verified at the HEC...NO EDITING!","","!?4") K X
  1. Q
  1. SV ;EK Rqrd if Svc Rcrd Ver
  1. I "NU"'[$E(X) D VET Q:'$D(X)
  1. 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
  1. Q
  1. MV ;EK Rqrd if Money Ver
  1. I "NU"'[$E(X) D VET Q:'$D(X)
  1. 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
  1. Q
  1. VET ;Veteran
  1. S DGVV=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:""),DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"")
  1. I $D(^DPT(DFN,"VET")),^("VET")'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X
  1. K DGVV Q
  1. VAGE ;Vet Age
  1. 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))
  1. 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
  1. S X=DGDATA K X1,X2,DGDATA Q
  1. AO ;Agent Orange
  1. 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
  1. Q
  1. EC ;SW Asia Contaminants - name change from Env. Contam. DG*5.3*688
  1. 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
  1. I $D(X) I X<2900802 K X W !?4,$C(7),"Date must be on or after 8/2/1990!"
  1. Q
  1. COM ;Combat
  1. 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
  1. Q
  1. INE ;Ineligible
  1. 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
  1. Q
  1. IR ;ION Rad
  1. 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
  1. Q
  1. POW ;Prisoner of War
  1. 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
  1. Q
  1. SER1 ;NTL Svc
  1. 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
  1. Q
  1. SER2 ;NNTL
  1. 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
  1. Q
  1. TAD ;Temp Add Edit
  1. 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
  1. Q
  1. TADD ;Temp Address Delete?
  1. Q:'$D(^DPT(DFN,.121)) I $P(^(.121),"^",9)="N"!($P(^(.121),"^",1,6)="^^^^^") Q
  1. 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
  1. ; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable
  1. I $G(DTOUT) S DGTMOT=1
  1. Q:%'=1 D EN^DGCLEAR(DFN,"TEMP") Q
  1. VN ;Viet Svc
  1. 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
  1. Q
  1. ;
  1. OEIF ;OIF/ OEF/ UNKNOWN OEF/OIF Svc
  1. D SV
  1. Q
  1. SVED ;Lebanon, Grenada, Panama, Persian Gulf & Yugoslavia svc edit
  1. ; (from and to dates)
  1. ;DGX = piece position of corresponding service indicated? field
  1. ; for multiple serv indicated dgx=sv1^sv2^...
  1. ;DGSV= service (sv1, sv2 from above)
  1. ;DGOK= 1=YES,at least one of the required sv indicated is yes,0=NO
  1. D SV I '$D(X) K DGX Q
  1. N DGSV,DGOK,DGPC,PC
  1. S DGOK=0
  1. F PC=1:1 S DGSV=$P(DGX,U,PC) Q:DGSV']"" S:$P($G(^DPT(DFN,.322)),U,DGSV)="Y" DGOK=1
  1. S PC=PC-1
  1. I DGOK=0 D
  1. .I "UN"'[$E(X) D
  1. ..W !?4,$C(7),"Service in "
  1. ..F DGPC=1:1:PC D
  1. ...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:"")
  1. ...W:(DGPC<PC) " or "
  1. ..W " not indicated...NO EDITING!" K X
  1. K DGX
  1. Q
  1. 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
  1. 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
  1. N DGFLD
  1. S DGFLD=$P(^DD(2,.3013,0),U)
  1. I $G(X)<$P(^DPT(DFN,0),U,3) D Q
  1. . D DOBDOD(DGFLD,1)
  1. I $P($G(^DPT(DFN,.35)),U)]"" D
  1. . I $G(X)>$P(^DPT(DFN,.35),U) D
  1. . . D DOBDOD(DGFLD,2)
  1. Q
  1. POWV ;POW Status cannot be edited once it has been verified by the HEC
  1. ;DG*5.3*688
  1. I $P($G(^DPT(DFN,.52)),U,9)'="" D EN^DDIOL("POW Status verified at the HEC...NO EDITING!!","","!?4") K X
  1. Q
  1. INEL ;check ineligible date - cannot be before DOB
  1. ;DG*5.3*754
  1. N DGFLD
  1. I $G(X)<$P(^DPT(DFN,0),U,3) D
  1. . S DGFLD=$P(^DD(2,.152,0),U)
  1. . D DOBDOD(DGFLD,1)
  1. Q
  1. INCOM ;check date ruled incompetent (VA) - cannot be before DOB
  1. ;or after DOD - DG*5.3*754)
  1. N DGFLD
  1. S DGFLD=$P(^DD(2,.291,0),U)
  1. I $G(X)<$P(^DPT(DFN,0),U,3) D Q
  1. . D DOBDOD(DGFLD,1)
  1. I $P($G(^DPT(DFN,.35)),U)]"" D
  1. . I $G(X)>$P(^DPT(DFN,.35),U) D
  1. . . D DOBDOD(DGFLD,2)
  1. Q
  1. INCOM2 ;check date ruled incompetent (civil - cannot be before DOB
  1. ;or after DOD - DG*5.3*754)
  1. N DGFLD
  1. S DGFLD=$P(^DD(2,.292,0),U)
  1. I $G(X)<$P(^DPT(DFN,0),U,3) D Q
  1. . D DOBDOD(DGFLD,1)
  1. I $P($G(^DPT(DFN,.35)),U)]"" D
  1. . I $G(X)>$P(^DPT(DFN,.35),U) D
  1. . . D DOBDOD(DGFLD,2)
  1. Q
  1. DOBDOD(DGFLD,DGX) ;called from subroutines to check if
  1. ;date is before DOB or after DOD. The subroutines
  1. ;are called from the field input transforms. DG*5.3*754
  1. I $G(DGFLD)']"" Q
  1. I "12"'[$G(DGX) Q
  1. D EN^DDIOL(DGFLD_" cannot be "_$S(DGX=1:"prior to",1:"after")_" Date of "_$S(DGX=1:"Birth.",1:"Death."),"","!?4")
  1. K X
  1. Q
  1. DEATH ;new date constraints added with ESR 3.1 - DG*5.3*754
  1. Q:$G(X)'>0
  1. N DGFLD
  1. S DGFLD=$P(^DD(2,.351,0),U)
  1. ;check for DOD before DOB
  1. I X<$P(^DPT(DFN,0),U,3) D DOBDOD(DGFLD,1) Q
  1. ;check for DOD before P&T Effective Date
  1. I X<$P($G(^DPT(DFN,.3)),U,13) D Q
  1. . D EN^DDIOL(DGFLD_" cannot be prior to the P&T Effective Date","","!?4")
  1. . K X
  1. ;check for DOD before Date Ruled Incompetent (VA)
  1. I X<$P($G(^DPT(DFN,.29)),U) D Q
  1. . D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (VA)","","!?4")
  1. . K X
  1. ;check for DOD before Date Ruled Incompetent (Civil)
  1. I X<$P($G(^DPT(DFN,.29)),U,2) D Q
  1. . D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (Civil)","","!?4")
  1. . K X
  1. ;check for DOD before Enrollment Application Date
  1. ;I $P($G(^DPT(DFN,"ENR")),U)>0 D
  1. ;. N DGENR
  1. ;. S DGENR=$P(^DPT(DFN,"ENR"),U)
  1. ;. Q:$G(DGENR)']""
  1. ;. Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
  1. ;. I X<$P(^DGEN(27.11,DGENR,0),U) D
  1. ;. . D EN^DDIOL(DGFLD_" cannot be prior to the Enrollment Application Date","","!?4")
  1. ;. . K X
  1. Q
  1. BIRTH ;checks for DOB added with DG*5.3*754
  1. I (($G(EASAPP)'="")&($G(DGADDF)=1)) Q ;Ignore New 1010EZ patients
  1. Q:$G(X)'>0
  1. Q:'$D(DA)
  1. N DFN
  1. S DFN=DA
  1. N DGFLD
  1. S DGFLD=$P(^DD(2,.03,0),U)
  1. ;check for DOB after Ineligible Date
  1. I $P($G(^DPT(DFN,.15)),U,2)]"" D Q:'$G(X)
  1. . I X>$P(^DPT(DFN,.15),U,2) D
  1. . . D EN^DDIOL(DGFLD_" cannot be after the Ineligible Date","","!?4") K X
  1. ;check for DOB after Enrollment Application Date
  1. I $P($G(^DPT(DFN,"ENR")),U)>0 D
  1. . N DGENR
  1. . S DGENR=$P(^DPT(DFN,"ENR"),U)
  1. . Q:$G(DGENR)']""
  1. . Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN
  1. . I X>$P(^DGEN(27.11,DGENR,0),U) D
  1. . . D EN^DDIOL(DGFLD_" cannot be after the Enrollment Application Date","","!?4")
  1. . . K X
  1. Q
  1. MSE ;Military Service Episode data cannot be edited once it has been
  1. ;verified by the HEC
  1. ;DG*5.3*797
  1. I "NU"'[$E(X) D VET Q:'$D(X)
  1. 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
  1. Q