DGLOCK1 ;ALB/MRL,JAM,ARF,JAM,ARF,JAM - PATIENT FILE DATA EDIT CHECK ; 28 JUL 86
;;5.3;Registration;**121,314,1014,1061,1075,1081,1082,1098,1109,1144**;Aug 13, 1993;Build 3
AOD ;AO Delete
I $D(^DPT(DFN,.321)),$P(^(.321),U,2)="Y" W !?4,*7,"Can't delete as long as Agent Orange exposure is indicated." K X
Q
COMD ;Combat Delete
I $D(^DPT(DFN,.52)),$P(^(.52),U,11)="Y" W !?4,*7,"Can't delete as long as Combat Service is indicated." K X
Q
INED ;Ineligible Delete
I $D(^DPT(DFN,.15)),$P(^(.15),U,2)]"" W !?4,*7,"Can't delete this field as long as 'INELIGIBLE DATE' is on file." K X
Q
IRD ;ION Rad Delete
I $D(^DPT(DFN,.321)),$P(^(.321),U,3)="Y" W !?4,*7,"Can't delete as long as Ionizing Radiation exposure is indicated." K X
Q
POWD ;POW Delete
I $D(^DPT(DFN,.52)),$P(^(.52),U,5)="Y" W !?4,*7,"Still identified as former POW...Change status to delete." K X
Q
TADD ;Temp Add Delete
I $D(^DPT(DFN,.121)),$P(^(.121),U,9)="Y" W !?4,*7,"Answer NO to the 'WANT TO ENTER TEMPORARY ADDRESS' prompt, then delete." K X
Q
VND ;Viet Svc Delete
I $D(^DPT(DFN,.321)),$P(^(.321),U,1)="Y" W !?4,*7,"Can't delete as long as Vietnam Service is still indicated." K X
Q
SVDEL ;Panama, Grenada, Lebanon, Persian Gulf Svc Delete
;DGX = piece position of corresponding service indicated? field
I $D(^DPT(DFN,.322)),$P(^(.322),U,DGX)="Y" W !?4,*7,"Can't delete as long as ",$S(DGX=1:"Lebanon",DGX=4:"Grenada",DGX=7:"Panama",1:"Persian Gulf")," is still indicated." K X
K DGX
Q
EC S DGEC=$S('$D(^DPT(DFN,.36)):"",$D(^DIC(8,+$P(^DPT(DFN,.36),U,1),0)):$P(^(0),U,9),1:"") I DGEC=5 W !?4,*7,"Eligibility Code is 'NSC'...Can't be YES." K X,DGEC Q
K DGEC Q
HUDCK(DGEC) ; DG*5.3*1075; Check for when HUD-VASH eligibility code can be used
; Called by the Input Transform and SCREEN of ELIGIBILITY field (#.01) of the PATIENT ELIGIBILITIES subfile of PATIENT file (#2)
; Input:
; DGEC - (required) Eligibility Code
;
; Output:
; Function Value - Returns 1 if Eligibility Code can be used, 0 if Eligibility Code cannot be used
;
; HUD-VASH (MAS number 26) allowed after the date/time stored in parameter "DG PATCH*5.3*1075 ACTIVE"
; WORLD WAR II (MAS number 29) allowed only for Veterans that served during WW II (DG*5.3*1098)
;
N DGACTIVE
Q:$G(DGEC)="" 0
I ($$NATCODE^DGENELA(DGEC))'=26,($$NATCODE^DGENELA(DGEC))'=29 Q 1
; Get the timestamp stored in the parameter
I ($$NATCODE^DGENELA(DGEC))=26 D I $$NOW^XLFDT()<DGACTIVE Q 0
. S DGACTIVE=$$GET^XPAR("PKG","DG PATCH DG*5.3*1075 ACTIVE",1)
; DG*5.3*1098 - Check if patient can have WORLD WAR II eligibility
I '$G(DFN) N DFN S DFN=D0 ;DG*5.3*1144 ensuring DFN is set incase editing through FileMan ENTER/EDIT option
I $$NATCODE^DGENELA(DGEC)=29 I '$$WW2ELIG(DFN) Q 0
Q 1
WW2ELIG(DFN) ;DG*5.3*1098 - Determine if patient can have WORLD WAR II as a PATIENT ELIGIBILITIES
;
; INPUT: DFN = Patient IEN
; OUTPUT: 1 - Veteran is eligible for WW II eligibility
; 0 - Veteran is not eligible for WW II eligibility
;
; Selection criteria:
; a) patient is a Veteran
; b) patient has a Military Service Episode that includes any period from
; December 07, 1941 through December 31, 1946
; c) patient's birthdate is prior to January 01, 1933
;
I '$$VET1^DGENPTA(DFN) Q 0 ;if a VETERAN continue else quit
;
N DGBEGDT,DGENDDT,DGEPNUM,DGDATA,DGWWII
;check for an in range Military Service Episode (MSE) any period between
;December 07, 1941 and December 31, 1946, inclusive of these dates
S (DGBEGDT,DGENDDT,DGDATA)="",(DGEPNUM,DGWWII)=0
F S DGEPNUM=$O(^DPT(DFN,.3216,DGEPNUM)) Q:DGEPNUM="" D Q:DGWWII
. S DGDATA=$G(^DPT(DFN,.3216,DGEPNUM,0))
. S DGBEGDT=$P(DGDATA,U,1) ;set the begin date of the Veteran's MSE
. S DGENDDT=$P(DGDATA,U,2) ;set the end date of the Veteran's MSE
. I (DGBEGDT'>2461231),(DGENDDT'<2411207) S DGWWII=1 Q ;check the MSE for duration during World War II
Q:'DGWWII 0 ;quit if no MSE match is found
;check if the Veteran's birthdate is prior to January 01, 1933
I $$GET1^DIQ(2,DFN_",",.03,"I")'>2330101 Q 1 ;if Veteran's age is within range return a 1
Q 0
POS ;Screen
K DGEC D SV1^DGLOCK I $D(X) S DIC("S")="I '$P(^(0),""^"",8),$D(^DPT(DA,.36)),$D(^DIC(21,+Y,""E"",+$P(^(.36),U,1)))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X D:'$D(X) POSH I $D(X),$D(^DIC(21,X,0)),$P(^(0),U,7)]"" D POS1 Q
Q
POS1 S XX=$P(^DIC(21,X,0),U,7) I $P(^DPT(DA,0),U,3)]"" I $P(^(0),U,3)'>XX!($D(^XUSEC("DG ELIGIBILITY",DUZ))) K XX Q
W !?5,*7,"Applicant is too young to have served in that period of service.",!?5,"See your supervisor if you require assistance." K X,XX Q
POSH S DGEC=$S('$D(^DPT(DFN,.36)):"",$D(^DIC(8,+$P(^(.36),U,1),0)):$P(^(0),U,1),1:"") W !?5,"Current Eligibility Code" W:DGEC]"" ": ",DGEC I DGEC']"" W " is not defined. Must be defined in order",!?5,"to enter a POS."
K DGEC Q
SC S DGSCON=$S('$D(^DPT(DFN,.3)):0,$P(^(.3),U,1)="Y":1,1:0) I 'DGSCON W !?4,*7,"Not possible, applicant is not service-connected." K X,DGSCON Q
K DGSCON Q
;
ECD ;primary eligibility code input transform
;
N DGNODE,DGPC,DGSER,DGVT,DGXX,DGCOV
S DGVT=$G(^DPT(DFN,"VET")),DGSER=$S('$D(^DPT(DFN,.3)):0,$P(^(.3),U,1)="Y":1,1:0)
I DGVT']"" K X W !?4,*7,"'VETERAN (Y/N)' prompt must be answered to select an Eligibility Code'" Q
; DG*5.3*1014 - Capture if COLLATERAL OF VET is the current Primary Eligibility
S DGCOV=0 I $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET." S DGCOV=1
; DG*5.3*1061 Add eligibilities 24 and 25 to the screening logic
; DG*5.3*1075 Add the HUD-VASH eligibility code 26 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
S DIC("S")="I $P(^DIC(8,+Y,0),U,5)=DGVT,'$P(^(0),U,7),$$NATCODE^DGENELA(+Y)'=24&($$NATCODE^DGENELA(+Y)'=25)&($$NATCODE^DGENELA(+Y)'=26)"
; DG*5.3*1081 - EXPANDED MH CARE NON-ENROLLEE cannot be Primary Elig Code if INELIGIBLE DATE (field .152) is set
I $$GET1^DIQ(2,DFN,.152)'="" S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=23"
; DG*5.3*1082 Add the PRESUMPTIVE PSYCHOSIS ELIGIBLE eligibility code 28 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=28"
; DG*5.3*1098 Add the WORLD WAR II eligibility code 29 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=29"
; DG*5.3*1109 Add the SERVICE ACT eligibility code 30 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=30"
I DGVT="N" G ECDS
I DGSER S DGPC=$S(+$P(^DPT(DFN,.3),U,2)>49:1,1:0),DGXX=$S(DGPC:1,1:3),DIC("S")=DIC("S")_",($P(^(0),U,9)="_DGXX_")" G ECDS ;sc only
I $P($G(^DPT(DFN,.52)),"^",5)="Y" S DIC("S")=DIC("S")_",($P(^(0),U,9)=18)" G ECDS ;pow only
S DGXX="^1^3^18^" ; no sc<50, sc 50-100, pow
I $P($G(^DPT(DFN,.53)),U)="Y" S DIC("S")=DIC("S")_",($P(^(0),U,9)=22)" G ECDS ;checks for PH Indicator
S DGXX=DGXX_"22^" ;adds PH to DGXX string
S DGNODE=$G(^DPT(DFN,.362))
I $P(DGNODE,"^",12)'="Y" S DGXX=DGXX_"2^"
I $P(DGNODE,"^",14)'="Y" S DGXX=DGXX_"4^"
I $P(DGNODE,"^",13)'="Y" S DGXX=DGXX_"15^"
F I=12:1:14 I $P(DGNODE,"^",I)="Y" S DGXX=DGXX_"5^"_$S(I'=14:"4^",1:"")
I $P($G(^DPT(DFN,0)),"^",3)>2200101 S DGXX=DGXX_"16^17^" ; WWI or mexican border only
S DIC("S")=DIC("S")_",("""_DGXX_"""'[(U_$P(^(0),U,9)_U))"
ECDS D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
;
;catastrophic disability can not be primary
I $G(X),$$NATNAME^DGENELA(X)="CATASTROPHICALLY DISABLED" K X Q
; DG*5.3*1061 Prevent eligibilities 24 and 25 from being primary eligibilities
I $G(X),$$NATCODE^DGENELA(X)=24 K X Q
I $G(X),$$NATCODE^DGENELA(X)=25 K X Q
; DG*5.3*1075 Prevent HUD-VASH eligibility code 26 from being a primary eligibility
I $G(X),$$NATCODE^DGENELA(X)=26 K X Q
; DG*5.3*1082 Prevent PRESUMPTIVE PSYCHOSIS ELIGIBLE eligibility code 28 from being entered as a primary eligibility
I $G(X),$$NATCODE^DGENELA(X)=28 K X Q
; DG*5.3*1098 Prevent WORLD WAR II eligibility code 29 from being entered as a primary eligibility
I $G(X),$$NATCODE^DGENELA(X)=29 K X Q
; DG*5.3*1109 Prevent SERVCE ACT eligibility code 30 from being entered as a primary eligibility
I $G(X),$$NATCODE^DGENELA(X)=30 K X Q
;
; DG*5.3*1014 - if editing Primary Eligibility "COLLATERAL OF VET", save off any CCPs
I $G(X),DGCOV D REMOVE^DGRP1152U(DFN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGLOCK1 8435 printed Sep 23, 2025@20:19:55 Page 2
DGLOCK1 ;ALB/MRL,JAM,ARF,JAM,ARF,JAM - PATIENT FILE DATA EDIT CHECK ; 28 JUL 86
+1 ;;5.3;Registration;**121,314,1014,1061,1075,1081,1082,1098,1109,1144**;Aug 13, 1993;Build 3
AOD ;AO Delete
+1 IF $DATA(^DPT(DFN,.321))
IF $PIECE(^(.321),U,2)="Y"
WRITE !?4,*7,"Can't delete as long as Agent Orange exposure is indicated."
KILL X
+2 QUIT
COMD ;Combat Delete
+1 IF $DATA(^DPT(DFN,.52))
IF $PIECE(^(.52),U,11)="Y"
WRITE !?4,*7,"Can't delete as long as Combat Service is indicated."
KILL X
+2 QUIT
INED ;Ineligible Delete
+1 IF $DATA(^DPT(DFN,.15))
IF $PIECE(^(.15),U,2)]""
WRITE !?4,*7,"Can't delete this field as long as 'INELIGIBLE DATE' is on file."
KILL X
+2 QUIT
IRD ;ION Rad Delete
+1 IF $DATA(^DPT(DFN,.321))
IF $PIECE(^(.321),U,3)="Y"
WRITE !?4,*7,"Can't delete as long as Ionizing Radiation exposure is indicated."
KILL X
+2 QUIT
POWD ;POW Delete
+1 IF $DATA(^DPT(DFN,.52))
IF $PIECE(^(.52),U,5)="Y"
WRITE !?4,*7,"Still identified as former POW...Change status to delete."
KILL X
+2 QUIT
TADD ;Temp Add Delete
+1 IF $DATA(^DPT(DFN,.121))
IF $PIECE(^(.121),U,9)="Y"
WRITE !?4,*7,"Answer NO to the 'WANT TO ENTER TEMPORARY ADDRESS' prompt, then delete."
KILL X
+2 QUIT
VND ;Viet Svc Delete
+1 IF $DATA(^DPT(DFN,.321))
IF $PIECE(^(.321),U,1)="Y"
WRITE !?4,*7,"Can't delete as long as Vietnam Service is still indicated."
KILL X
+2 QUIT
SVDEL ;Panama, Grenada, Lebanon, Persian Gulf Svc Delete
+1 ;DGX = piece position of corresponding service indicated? field
+2 IF $DATA(^DPT(DFN,.322))
IF $PIECE(^(.322),U,DGX)="Y"
WRITE !?4,*7,"Can't delete as long as ",$SELECT(DGX=1:"Lebanon",DGX=4:"Grenada",DGX=7:"Panama",1:"Persian Gulf")," is still indicated."
KILL X
+3 KILL DGX
+4 QUIT
EC SET DGEC=$SELECT('$DATA(^DPT(DFN,.36)):"",$DATA(^DIC(8,+$PIECE(^DPT(DFN,.36),U,1),0)):$PIECE(^(0),U,9),1:"")
IF DGEC=5
WRITE !?4,*7,"Eligibility Code is 'NSC'...Can't be YES."
KILL X,DGEC
QUIT
+1 KILL DGEC
QUIT
HUDCK(DGEC) ; DG*5.3*1075; Check for when HUD-VASH eligibility code can be used
+1 ; Called by the Input Transform and SCREEN of ELIGIBILITY field (#.01) of the PATIENT ELIGIBILITIES subfile of PATIENT file (#2)
+2 ; Input:
+3 ; DGEC - (required) Eligibility Code
+4 ;
+5 ; Output:
+6 ; Function Value - Returns 1 if Eligibility Code can be used, 0 if Eligibility Code cannot be used
+7 ;
+8 ; HUD-VASH (MAS number 26) allowed after the date/time stored in parameter "DG PATCH*5.3*1075 ACTIVE"
+9 ; WORLD WAR II (MAS number 29) allowed only for Veterans that served during WW II (DG*5.3*1098)
+10 ;
+11 NEW DGACTIVE
+12 if $GET(DGEC)=""
QUIT 0
+13 IF ($$NATCODE^DGENELA(DGEC))'=26
IF ($$NATCODE^DGENELA(DGEC))'=29
QUIT 1
+14 ; Get the timestamp stored in the parameter
+15 IF ($$NATCODE^DGENELA(DGEC))=26
Begin DoDot:1
+16 SET DGACTIVE=$$GET^XPAR("PKG","DG PATCH DG*5.3*1075 ACTIVE",1)
End DoDot:1
IF $$NOW^XLFDT()<DGACTIVE
QUIT 0
+17 ; DG*5.3*1098 - Check if patient can have WORLD WAR II eligibility
+18 ;DG*5.3*1144 ensuring DFN is set incase editing through FileMan ENTER/EDIT option
IF '$GET(DFN)
NEW DFN
SET DFN=D0
+19 IF $$NATCODE^DGENELA(DGEC)=29
IF '$$WW2ELIG(DFN)
QUIT 0
+20 QUIT 1
WW2ELIG(DFN) ;DG*5.3*1098 - Determine if patient can have WORLD WAR II as a PATIENT ELIGIBILITIES
+1 ;
+2 ; INPUT: DFN = Patient IEN
+3 ; OUTPUT: 1 - Veteran is eligible for WW II eligibility
+4 ; 0 - Veteran is not eligible for WW II eligibility
+5 ;
+6 ; Selection criteria:
+7 ; a) patient is a Veteran
+8 ; b) patient has a Military Service Episode that includes any period from
+9 ; December 07, 1941 through December 31, 1946
+10 ; c) patient's birthdate is prior to January 01, 1933
+11 ;
+12 ;if a VETERAN continue else quit
IF '$$VET1^DGENPTA(DFN)
QUIT 0
+13 ;
+14 NEW DGBEGDT,DGENDDT,DGEPNUM,DGDATA,DGWWII
+15 ;check for an in range Military Service Episode (MSE) any period between
+16 ;December 07, 1941 and December 31, 1946, inclusive of these dates
+17 SET (DGBEGDT,DGENDDT,DGDATA)=""
SET (DGEPNUM,DGWWII)=0
+18 FOR
SET DGEPNUM=$ORDER(^DPT(DFN,.3216,DGEPNUM))
if DGEPNUM=""
QUIT
Begin DoDot:1
+19 SET DGDATA=$GET(^DPT(DFN,.3216,DGEPNUM,0))
+20 ;set the begin date of the Veteran's MSE
SET DGBEGDT=$PIECE(DGDATA,U,1)
+21 ;set the end date of the Veteran's MSE
SET DGENDDT=$PIECE(DGDATA,U,2)
+22 ;check the MSE for duration during World War II
IF (DGBEGDT'>2461231)
IF (DGENDDT'<2411207)
SET DGWWII=1
QUIT
End DoDot:1
if DGWWII
QUIT
+23 ;quit if no MSE match is found
if 'DGWWII
QUIT 0
+24 ;check if the Veteran's birthdate is prior to January 01, 1933
+25 ;if Veteran's age is within range return a 1
IF $$GET1^DIQ(2,DFN_",",.03,"I")'>2330101
QUIT 1
+26 QUIT 0
POS ;Screen
+1 KILL DGEC
DO SV1^DGLOCK
IF $DATA(X)
SET DIC("S")="I '$P(^(0),""^"",8),$D(^DPT(DA,.36)),$D(^DIC(21,+Y,""E"",+$P(^(.36),U,1)))"
DO ^DIC
KILL DIC
SET DIC=DIE
SET X=+Y
if Y<0
KILL X
if '$DATA(X)
DO POSH
IF $DATA(X)
IF $DATA(^DIC(21,X,0))
IF $PIECE(^(0),U,7)]""
DO POS1
QUIT
+2 QUIT
POS1 SET XX=$PIECE(^DIC(21,X,0),U,7)
IF $PIECE(^DPT(DA,0),U,3)]""
IF $PIECE(^(0),U,3)'>XX!($DATA(^XUSEC("DG ELIGIBILITY",DUZ)))
KILL XX
QUIT
+1 WRITE !?5,*7,"Applicant is too young to have served in that period of service.",!?5,"See your supervisor if you require assistance."
KILL X,XX
QUIT
POSH SET DGEC=$SELECT('$DATA(^DPT(DFN,.36)):"",$DATA(^DIC(8,+$PIECE(^(.36),U,1),0)):$PIECE(^(0),U,1),1:"")
WRITE !?5,"Current Eligibility Code"
if DGEC]""
WRITE ": ",DGEC
IF DGEC']""
WRITE " is not defined. Must be defined in order",!?5,"to enter a POS."
+1 KILL DGEC
QUIT
SC SET DGSCON=$SELECT('$DATA(^DPT(DFN,.3)):0,$PIECE(^(.3),U,1)="Y":1,1:0)
IF 'DGSCON
WRITE !?4,*7,"Not possible, applicant is not service-connected."
KILL X,DGSCON
QUIT
+1 KILL DGSCON
QUIT
+2 ;
ECD ;primary eligibility code input transform
+1 ;
+2 NEW DGNODE,DGPC,DGSER,DGVT,DGXX,DGCOV
+3 SET DGVT=$GET(^DPT(DFN,"VET"))
SET DGSER=$SELECT('$DATA(^DPT(DFN,.3)):0,$PIECE(^(.3),U,1)="Y":1,1:0)
+4 IF DGVT']""
KILL X
WRITE !?4,*7,"'VETERAN (Y/N)' prompt must be answered to select an Eligibility Code'"
QUIT
+5 ; DG*5.3*1014 - Capture if COLLATERAL OF VET is the current Primary Eligibility
+6 SET DGCOV=0
IF $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET."
SET DGCOV=1
+7 ; DG*5.3*1061 Add eligibilities 24 and 25 to the screening logic
+8 ; DG*5.3*1075 Add the HUD-VASH eligibility code 26 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
+9 SET DIC("S")="I $P(^DIC(8,+Y,0),U,5)=DGVT,'$P(^(0),U,7),$$NATCODE^DGENELA(+Y)'=24&($$NATCODE^DGENELA(+Y)'=25)&($$NATCODE^DGENELA(+Y)'=26)"
+10 ; DG*5.3*1081 - EXPANDED MH CARE NON-ENROLLEE cannot be Primary Elig Code if INELIGIBLE DATE (field .152) is set
+11 IF $$GET1^DIQ(2,DFN,.152)'=""
SET DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=23"
+12 ; DG*5.3*1082 Add the PRESUMPTIVE PSYCHOSIS ELIGIBLE eligibility code 28 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
+13 SET DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=28"
+14 ; DG*5.3*1098 Add the WORLD WAR II eligibility code 29 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
+15 SET DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=29"
+16 ; DG*5.3*1109 Add the SERVICE ACT eligibility code 30 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
+17 SET DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=30"
+18 IF DGVT="N"
GOTO ECDS
+19 ;sc only
IF DGSER
SET DGPC=$SELECT(+$PIECE(^DPT(DFN,.3),U,2)>49:1,1:0)
SET DGXX=$SELECT(DGPC:1,1:3)
SET DIC("S")=DIC("S")_",($P(^(0),U,9)="_DGXX_")"
GOTO ECDS
+20 ;pow only
IF $PIECE($GET(^DPT(DFN,.52)),"^",5)="Y"
SET DIC("S")=DIC("S")_",($P(^(0),U,9)=18)"
GOTO ECDS
+21 ; no sc<50, sc 50-100, pow
SET DGXX="^1^3^18^"
+22 ;checks for PH Indicator
IF $PIECE($GET(^DPT(DFN,.53)),U)="Y"
SET DIC("S")=DIC("S")_",($P(^(0),U,9)=22)"
GOTO ECDS
+23 ;adds PH to DGXX string
SET DGXX=DGXX_"22^"
+24 SET DGNODE=$GET(^DPT(DFN,.362))
+25 IF $PIECE(DGNODE,"^",12)'="Y"
SET DGXX=DGXX_"2^"
+26 IF $PIECE(DGNODE,"^",14)'="Y"
SET DGXX=DGXX_"4^"
+27 IF $PIECE(DGNODE,"^",13)'="Y"
SET DGXX=DGXX_"15^"
+28 FOR I=12:1:14
IF $PIECE(DGNODE,"^",I)="Y"
SET DGXX=DGXX_"5^"_$SELECT(I'=14:"4^",1:"")
+29 ; WWI or mexican border only
IF $PIECE($GET(^DPT(DFN,0)),"^",3)>2200101
SET DGXX=DGXX_"16^17^"
+30 SET DIC("S")=DIC("S")_",("""_DGXX_"""'[(U_$P(^(0),U,9)_U))"
ECDS DO ^DIC
KILL DIC
SET DIC=DIE
SET X=+Y
if Y<0
KILL X
+1 ;
+2 ;catastrophic disability can not be primary
+3 IF $GET(X)
IF $$NATNAME^DGENELA(X)="CATASTROPHICALLY DISABLED"
KILL X
QUIT
+4 ; DG*5.3*1061 Prevent eligibilities 24 and 25 from being primary eligibilities
+5 IF $GET(X)
IF $$NATCODE^DGENELA(X)=24
KILL X
QUIT
+6 IF $GET(X)
IF $$NATCODE^DGENELA(X)=25
KILL X
QUIT
+7 ; DG*5.3*1075 Prevent HUD-VASH eligibility code 26 from being a primary eligibility
+8 IF $GET(X)
IF $$NATCODE^DGENELA(X)=26
KILL X
QUIT
+9 ; DG*5.3*1082 Prevent PRESUMPTIVE PSYCHOSIS ELIGIBLE eligibility code 28 from being entered as a primary eligibility
+10 IF $GET(X)
IF $$NATCODE^DGENELA(X)=28
KILL X
QUIT
+11 ; DG*5.3*1098 Prevent WORLD WAR II eligibility code 29 from being entered as a primary eligibility
+12 IF $GET(X)
IF $$NATCODE^DGENELA(X)=29
KILL X
QUIT
+13 ; DG*5.3*1109 Prevent SERVCE ACT eligibility code 30 from being entered as a primary eligibility
+14 IF $GET(X)
IF $$NATCODE^DGENELA(X)=30
KILL X
QUIT
+15 ;
+16 ; DG*5.3*1014 - if editing Primary Eligibility "COLLATERAL OF VET", save off any CCPs
+17 IF $GET(X)
IF DGCOV
DO REMOVE^DGRP1152U(DFN)
+18 QUIT
