DGLOCK2 ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 Jan 2002 2:37 PM
;;5.3;Registration;**18,244,624**;Aug 13, 1993
K1 ;NOK Add
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $S('$D(^DPT(DFN,.21)):1,$P(^(.21),U,1)']"":1,1:0) W !?4,*7,"'NEXT OF KIN' name must be specified to enter/edit this field" K X
Q
K1D ;NOK Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.21)),$P(^(.21),U,1)]"" W !?4,*7,"Can't be deleted as long as 'NEXT OF KIN' is specified" K X
Q
K2 ;NOK2 Add
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
D K1 I $D(X),$S('$D(^DPT(DFN,.211)):1,$P(^(.211),U,1)']"":1,1:0) W !?4,*7,"'NEXT OF KIN-2' name must be specified to enter/edit this field" K X
Q
K2D ;NOK2 Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.211)),$P(^(.211),U,1)]"" W !?4,*7,"Can't be deleted as long as 'NEXT OF KIN-2' is specified" K X
Q
E1 ;Emer Add
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $S('$D(^DPT(DFN,.33)):1,$P(^(.33),U,1)']"":1,1:0) W !?4,*7,"'EMERGENCY CONTACT' name must be specified to enter/edit this field" K X
Q
E1D ;Emer Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.33)),$P(^(.33),U,1)]"" W !?4,*7,"Can't be deleted as long as 'EMERGENCY CONTACT' is specified" K X
Q
E2 ;Emer2 Add
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
D E1 I $D(X),$S('$D(^DPT(DFN,.331)):1,$P(^(.331),U,1)']"":1,1:0) W !?4,*7,"'EMERGENCY CONTACT-2' name must be specified to enter/edit this field" K X
Q
E2D ;Emer2 Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.331)),$P(^(.331),U,1)]"" W !?4,*7,"Can't be deleted as long as 'EMERGENCY CONTACT-2' is specified" K X
Q
D ;Desig Add
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $S('$D(^DPT(DFN,.34)):1,$P(^(.34),U,1)']"":1,1:0) W !?4,*7,"'DESIGNEE' name must be specified to enter/edit this field" K X
Q
DD ;Desig Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.34)),$P(^(.34),U,1)]"" W !?4,*7,"Can't be deleted as long as 'DESIGNEE' is specified" K X
Q
SDD ;Spouse/Dependent Delete
Q:'DA
I $D(^DGPR(408.13,DA,0)),$P(^(0),U,1)]"" D EN^DDIOL(" Can't be deleted as long as Spouse/Dependent Income Person is specified.") K X
Q
EM ;Emp Add
I $S('$D(^DPT(DA,.311)):1,"^3^9^"[$P(^(.311),U,15):1,1:0) G EMW
Q
EMW W !?4,*7,"'EMPLOYMENT STATUS' must be specified to enter/edit this field" K X Q
EM1 I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $S('$D(^DPT(DFN,.311)):1,"^3^9^"[$P(^(.311),U,15):1,1:0) G EMW
I $P(^DPT(DFN,.311),U)']"" W !?4,*7,"'EMPLOYER NAME' must be specified to enter/edit this field" K X
Q
EMD ;Emp Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.311)),$P(^(.311),U,1)]"" W !?4,*7,"Can't be deleted as long as 'EMPLOYER NAME' is specified" K X
Q
SE ;Sp Emp Add
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
D MAR I $D(X),$S('$D(^DPT(DFN,.25)):1,$P(^(.25),U,1)']"":1,1:0) W !?4,*7,"'SPOUSES EMPLOYER' name must be specified to enter/edit this field" K X
Q
SED ;Sp Emp Delete
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $D(^DPT(DFN,.25)),$P(^(.25),U,1)]"" W !?4,*7,"Can't be deleted as long as 'SPOUSES EMPLOYER' is specified" K X
Q
MAR ;Married or Separated
I '$G(DFN) N DFN S DFN=$G(DA) Q:'DFN
I $S('$D(^DIC(11,+$P(^DPT(DFN,0),U,5),0)):1,$P(^(0),U,1)="MARRIED":0,$P(^(0),U,1)="SEPARATED":0,1:1) W !?4,*7,"NOT POSSIBLE...Applicant is not Married." K X Q
Q
AAC1 ;Agency/Country Screen
S DGAAC=$S($D(^DPT(DFN,.36)):$S($D(^DIC(8,+$P(^DPT(DFN,.36),U,1),0)):+$P(^(0),U,4),1:""),1:""),DGAAC(1)=$S('$D(^DPT(DFN,"VET")):"",^("VET")'="N":"",DGAAC=4:"A",DGAAC=5:"C",1:"")
Q
AAC D AAC1 S DIC("S")="I $P(^(0),U,4)=DGAAC(1)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q
;
DOL I $S(X']"":1,X'["*":1,1:0) S:X["$" X=+$P(X,"$",2) G DOL2
DOL1 I $L(X),"$*"[$E(X) S X=$E(X,2,999) G DOL1
Q:'+X S X=+X,X=X*12
DOL2 S:X["." X=+$P(X,".",1)_"."_$E($P(X,".",2)_"00",1,2) W " ($",X,")" Q
TOTCHK(DFN) ;Returns 1 if Any of 4 'Received' YES/NO amounts =YES
;For A&A, HB, Pension, Disability
S:'$D(DFN) DFN=DA
Q ($P($G(^DPT(DFN,.362)),U,12,14)_$P($G(^DPT(DFN,.3)),U,11))["Y"
TOTCKMSG ;ERROR MESSAGE FOR ABOVE
W !,?4,*7,"Must Receive A&A, HB, Pension, or Disability Benefits."
Q
TOTCKDEL ;ERROR MESSAGE IF DELETE .36295
S DFN=DA I $$TOTCHK(DFN) W !,?4,*7,"Delete by indicating receipt of A&A, HB, Pension, & Disability as 'NO'." K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGLOCK2 4298 printed Sep 23, 2025@20:19:56 Page 2
DGLOCK2 ;ALB/MRL - PATIENT FILE DATA EDIT CHECKS ; 28 Jan 2002 2:37 PM
+1 ;;5.3;Registration;**18,244,624**;Aug 13, 1993
K1 ;NOK Add
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $SELECT('$DATA(^DPT(DFN,.21)):1,$PIECE(^(.21),U,1)']"":1,1:0)
WRITE !?4,*7,"'NEXT OF KIN' name must be specified to enter/edit this field"
KILL X
+3 QUIT
K1D ;NOK Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.21))
IF $PIECE(^(.21),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'NEXT OF KIN' is specified"
KILL X
+3 QUIT
K2 ;NOK2 Add
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 DO K1
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.211)):1,$PIECE(^(.211),U,1)']"":1,1:0)
WRITE !?4,*7,"'NEXT OF KIN-2' name must be specified to enter/edit this field"
KILL X
+3 QUIT
K2D ;NOK2 Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.211))
IF $PIECE(^(.211),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'NEXT OF KIN-2' is specified"
KILL X
+3 QUIT
E1 ;Emer Add
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $SELECT('$DATA(^DPT(DFN,.33)):1,$PIECE(^(.33),U,1)']"":1,1:0)
WRITE !?4,*7,"'EMERGENCY CONTACT' name must be specified to enter/edit this field"
KILL X
+3 QUIT
E1D ;Emer Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.33))
IF $PIECE(^(.33),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'EMERGENCY CONTACT' is specified"
KILL X
+3 QUIT
E2 ;Emer2 Add
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 DO E1
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.331)):1,$PIECE(^(.331),U,1)']"":1,1:0)
WRITE !?4,*7,"'EMERGENCY CONTACT-2' name must be specified to enter/edit this field"
KILL X
+3 QUIT
E2D ;Emer2 Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.331))
IF $PIECE(^(.331),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'EMERGENCY CONTACT-2' is specified"
KILL X
+3 QUIT
D ;Desig Add
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $SELECT('$DATA(^DPT(DFN,.34)):1,$PIECE(^(.34),U,1)']"":1,1:0)
WRITE !?4,*7,"'DESIGNEE' name must be specified to enter/edit this field"
KILL X
+3 QUIT
DD ;Desig Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.34))
IF $PIECE(^(.34),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'DESIGNEE' is specified"
KILL X
+3 QUIT
SDD ;Spouse/Dependent Delete
+1 if 'DA
QUIT
+2 IF $DATA(^DGPR(408.13,DA,0))
IF $PIECE(^(0),U,1)]""
DO EN^DDIOL(" Can't be deleted as long as Spouse/Dependent Income Person is specified.")
KILL X
+3 QUIT
EM ;Emp Add
+1 IF $SELECT('$DATA(^DPT(DA,.311)):1,"^3^9^"[$PIECE(^(.311),U,15):1,1:0)
GOTO EMW
+2 QUIT
EMW WRITE !?4,*7,"'EMPLOYMENT STATUS' must be specified to enter/edit this field"
KILL X
QUIT
EM1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+1 IF $SELECT('$DATA(^DPT(DFN,.311)):1,"^3^9^"[$PIECE(^(.311),U,15):1,1:0)
GOTO EMW
+2 IF $PIECE(^DPT(DFN,.311),U)']""
WRITE !?4,*7,"'EMPLOYER NAME' must be specified to enter/edit this field"
KILL X
+3 QUIT
EMD ;Emp Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.311))
IF $PIECE(^(.311),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'EMPLOYER NAME' is specified"
KILL X
+3 QUIT
SE ;Sp Emp Add
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 DO MAR
IF $DATA(X)
IF $SELECT('$DATA(^DPT(DFN,.25)):1,$PIECE(^(.25),U,1)']"":1,1:0)
WRITE !?4,*7,"'SPOUSES EMPLOYER' name must be specified to enter/edit this field"
KILL X
+3 QUIT
SED ;Sp Emp Delete
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $DATA(^DPT(DFN,.25))
IF $PIECE(^(.25),U,1)]""
WRITE !?4,*7,"Can't be deleted as long as 'SPOUSES EMPLOYER' is specified"
KILL X
+3 QUIT
MAR ;Married or Separated
+1 IF '$GET(DFN)
NEW DFN
SET DFN=$GET(DA)
if 'DFN
QUIT
+2 IF $SELECT('$DATA(^DIC(11,+$PIECE(^DPT(DFN,0),U,5),0)):1,$PIECE(^(0),U,1)="MARRIED":0,$PIECE(^(0),U,1)="SEPARATED":0,1:1)
WRITE !?4,*7,"NOT POSSIBLE...Applicant is not Married."
KILL X
QUIT
+3 QUIT
AAC1 ;Agency/Country Screen
+1 SET DGAAC=$SELECT($DATA(^DPT(DFN,.36)):$SELECT($DATA(^DIC(8,+$PIECE(^DPT(DFN,.36),U,1),0)):+$PIECE(^(0),U,4),1:""),1:"")
SET DGAAC(1)=$SELECT('$DATA(^DPT(DFN,"VET")):"",^("VET")'="N":"",DGAAC=4:"A",DGAAC=5:"C",1:"")
+2 QUIT
AAC DO AAC1
SET DIC("S")="I $P(^(0),U,4)=DGAAC(1)"
DO ^DIC
KILL DIC
SET DIC=DIE
SET X=+Y
if Y<0
KILL X
QUIT
+1 ;
DOL IF $SELECT(X']"":1,X'["*":1,1:0)
if X["$"
SET X=+$PIECE(X,"$",2)
GOTO DOL2
DOL1 IF $LENGTH(X)
IF "$*"[$EXTRACT(X)
SET X=$EXTRACT(X,2,999)
GOTO DOL1
+1 if '+X
QUIT
SET X=+X
SET X=X*12
DOL2 if X["."
SET X=+$PIECE(X,".",1)_"."_$EXTRACT($PIECE(X,".",2)_"00",1,2)
WRITE " ($",X,")"
QUIT
TOTCHK(DFN) ;Returns 1 if Any of 4 'Received' YES/NO amounts =YES
+1 ;For A&A, HB, Pension, Disability
+2 if '$DATA(DFN)
SET DFN=DA
+3 QUIT ($PIECE($GET(^DPT(DFN,.362)),U,12,14)_$PIECE($GET(^DPT(DFN,.3)),U,11))["Y"
TOTCKMSG ;ERROR MESSAGE FOR ABOVE
+1 WRITE !,?4,*7,"Must Receive A&A, HB, Pension, or Disability Benefits."
+2 QUIT
TOTCKDEL ;ERROR MESSAGE IF DELETE .36295
+1 SET DFN=DA
IF $$TOTCHK(DFN)
WRITE !,?4,*7,"Delete by indicating receipt of A&A, HB, Pension, & Disability as 'NO'."
KILL X
+2 QUIT
