source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLOCK.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.6 KB
Line 
1DGLOCK ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28-SEP-05
2 ;;5.3;Registration;**108,161,247,485,672,673**;Aug 13, 1993
3FFP ; DGFFP Access key required
4 I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4") K X
5 Q
6EK ;EKey Rqrd
7 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !?4,$C(7),"Eligibility Key required to edit this field." K X
8 Q
9EV ;EK rqrd if Elig Ver
10 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
11 Q
12EV2 ;if elig is ver Discharged Due to Disability can't be edited - DG 672
13 I $D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D
14 . I $P(^DPT(DFN,.361),U,3)'="H" Q
15 . D EN^DDIOL("Eligibility verified at the HEC...NO EDITING!","","!?4") K X
16 Q
17SV ;EK Rqrd if Svc Rcrd Ver
18 I "NU"'[$E(X) D VET Q:'$D(X)
19SV1 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
20 Q
21MV ;EK Rqrd if Money Ver
22 I "NU"'[$E(X) D VET Q:'$D(X)
23 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
24 Q
25VET ;Veteran
26 S DGVV=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:""),DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"")
27 I $D(^DPT(DFN,"VET")),^("VET")'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X
28 K DGVV Q
29VAGE ;Vet Age
30 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))
31 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
32 S X=DGDATA K X1,X2,DGDATA Q
33AO ;Agent Orange
34 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
35 Q
36EC ;Environmental Contaminants
37 D SV I $D(X),$S('$D(^DPT(DFN,.322)):1,$P(^(.322),U,13)'="Y":1,1:0) W !?4,$C(7),"Exposure to Environmental Contaminants not indicated...NO EDITING!" K X
38 I $D(X) I X<2900802 K X W !?4,$C(7),"Date must be on or after 8/2/1992!"
39 Q
40COM ;Combat
41 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
42 Q
43INE ;Ineligible
44 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
45 Q
46IR ;ION Rad
47 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
48 Q
49POW ;Prisoner of War
50 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
51 Q
52SER1 ;NTL Svc
53 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
54 Q
55SER2 ;NNTL
56 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
57 Q
58TAD ;Temp Add Edit
59 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
60 Q
61TADD ;Temp Address Delete?
62 Q:'$D(^DPT(DFN,.121)) I $P(^(.121),"^",9)="N"!($P(^(.121),"^",1,6)="^^^^^") Q
63ASK 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
64 Q:%'=1 S DGTEMPH=$P(^DPT(DFN,.121),"^",7,8),^(.121)="^^^^^^"_DGTEMPH_"^N^^" K DGTEMPH Q
65VN ;Viet Svc
66 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
67 Q
68 ;
69OEIF ;OIF/ OEF/ UNKNOWN OEF/OIF Svc
70 D SV
71 Q
72SVED ;Lebanon, Grenada, Panama, Persian Gulf & Yugoslavia svc edit
73 ; (from and to dates)
74 ;DGX = piece position of corresponding service indicated? field
75 ; for multiple serv indicated dgx=sv1^sv2^...
76 ;DGSV= service (sv1, sv2 from above)
77 ;DGOK= 1=YES,at least one of the required sv indicated is yes,0=NO
78 D SV I '$D(X) K DGX Q
79 N DGSV,DGOK,DGPC,PC
80 S DGOK=0
81 F PC=1:1 S DGSV=$P(DGX,U,PC) Q:DGSV']"" S:$P($G(^DPT(DFN,.322)),U,DGSV)="Y" DGOK=1
82 S PC=PC-1
83 I DGOK=0 D
84 .I "UN"'[$E(X) D
85 ..W !?4,$C(7),"Service in "
86 ..F DGPC=1:1:PC D
87 ...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:"")
88 ...W:(DGPC<PC) " or "
89 ..W " not indicated...NO EDITING!" K X
90 K DGX
91 Q
Note: See TracBrowser for help on using the repository browser.