- 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 Feb 19, 2025@00:10:07 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