- 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**;Aug 13, 1993;Build 13
- 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 $$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 8321 printed Feb 19, 2025@00:10:06 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**;Aug 13, 1993;Build 13
- 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 IF $$NATCODE^DGENELA(DGEC)=29
- IF '$$WW2ELIG(DFN)
- QUIT 0
- +19 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