DGDEP3 ;ALB/CAW,BAJ,ERC,PWC - Dependents display ;11/22/2005
;;5.3;Registration;**45,624,653,688,867,890**;Aug 13, 1993;Build 40
;
SELF(INCPER,NAME,RELATE,ACT,DGMTI,CNT) ; Display information concerning veteran
;
S DGX="",DGX=$$SETSTR^VALM1(CNT,DGX,3,3)
I $G(DGMTI),INCPER,($P($G(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI) S DGX=$$SETSTR^VALM1("*",DGX,5,1)
S DGX=$$SETSTR^VALM1(NAME,DGX,9,22)
S DGX=$$SETSTR^VALM1($P($G(^DG(408.11,RELATE,0)),U),DGX,32,30)
S DGX=$$SETSTR^VALM1($S($P(ACT,U,2)=1:"*",1:""),DGX,65,1)
S:RELATE=2 DGX=$$SETSTR^VALM1($S(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1)
D SET^DGDEP(DGX)
;
; Display spouse SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
I RELATE=2 D
. S DGX="",DGX=$$SETSTR^VALM1($P(DGDEP,"^",5),DGX,9,14)
. S DGX=$$SETSTR^VALM1($P(DGDEP,"^",9),DGX,23,10)
. ;if a Pseudo SSN need Pseudo SSN Reason - DG*5.3*653, ERC
. I $P(DGDEP,U,5)["P" D
. . S DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15)
. . S DGX=$$SETSTR^VALM1($P(DGDEP,U,10),DGX,45,30)
. . ;D SET^DGDEP(DGX)
. D SET^DGDEP(DGX)
;
Q:RELATE=2
D NEWB
DISPLAY ;
; MARRIED LAST YEAR = PIECE 5
; LIVED WITH SPOUSE = PIECE 6
; AMOUNT CONTRIBUTED = PIECE 7
; CONTRIBUTED TO SPOUSE = PIECE 20
; DG*5.3*890 Amount Contributed Decommissioned. Display only historical information
S INCPER=^DGMT(408.22,INCPER,0)
S DGX="",DGX=$$SETSTR^VALM1("Married Last Year: ",DGX,18,19)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,5):"Yes",$P(INCPER,U,5)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
;
Q:'$G(DGMTI)
I $P(INCPER,U,5)=1 D
. S DGX="",DGX=$$SETSTR^VALM1("Lived with Spouse: ",DGX,18,19)
. S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6):"Yes",$P(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10)
. D SET^DGDEP(DGX)
Q:$P(INCPER,U,5)=1&($P(INCPER,U,6)=1) ;quit if Lived with Spouse and Married Last Year both equal YES
;
I $P(INCPER,U,20)'="" D ; new contributed to spouse question was answered
. S DGX="",DGX=$$SETSTR^VALM1("Contributed to Spouse: ",DGX,14,22)
. S DGX=$$SETSTR^VALM1($S($P(INCPER,U,20):"Yes",$P(INCPER,U,20)="":"Unanswered",1:"No"),DGX,38,10)
. D SET^DGDEP(DGX)
;
Q:$P(INCPER,U,20)'="" ;no need for old code because new question was answered
Q:$P(INCPER,U,6)="" ;Lived with Spouse is Unanswered, no need to go further
;
I $P(INCPER,U,7)'="" D Q ;new question has not been answered yet, but amount has value, historical information will display
. S DGX="",DGX=$$SETSTR^VALM1("Amount Contributed: ",DGX,17,19)
. S DGX=$$SETSTR^VALM1($S($P(INCPER,U,7)]"":$P(INCPER,U,7),1:"Unanswered"),DGX,38,10)
. D SET^DGDEP(DGX)
;
Q:$P(INCPER,U,6)=1 ;Lived with Spouse is YES, so no need to go further
;
I $P(INCPER,U,7)="" D ;new question not answered yet but no value is entered
. S DGX="",DGX=$$SETSTR^VALM1("Contributed to Spouse: ",DGX,14,22)
. S DGX=$$SETSTR^VALM1($S($P(INCPER,U,20):"Yes",$P(INCPER,U,20)="":"Unanswered",1:"No"),DGX,38,10)
. D SET^DGDEP(DGX)
Q
;
CHILD(INCPER,NAME,RELATE,ACT,DGMTI,DGMTACT,CNT) ; Display information concerning dependents
;
;** DG*5.3*688 - GTS Get MT Version
;** DG*5.3*890 - Amount Contributed Decommissioned. Display only historical information
N MTVER
S:(+$G(DGMTI)>0) MTVER=$P($G(^DGMT(408.31,DGMTI,2)),"^",11)
I (+$G(DGMTI)'>0) DO
. N DGINC,DGREL,DGINR,DGDEP
. D ALL^DGMTU21(DFN,"VSD",DT,"I")
. S MTVER=$$VER^DGMTUTL3(.DGINC)
S DGX="",DGX=$$SETSTR^VALM1(CNT,DGX,3,3)
I $G(DGMTI),INCPER,($P($G(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI) S DGX=$$SETSTR^VALM1("*",DGX,5,1)
S DGX=$$SETSTR^VALM1(NAME,DGX,9,22)
S DGX=$$SETSTR^VALM1($P($G(^DG(408.11,RELATE,0)),U),DGX,32,30)
S DGX=$$SETSTR^VALM1($S($P(ACT,U,2)=1:"*",1:""),DGX,65,1)
S DGX=$$SETSTR^VALM1($S(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1)
D SET^DGDEP(DGX)
;
;display dependent SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
S DGX="",DGX=$$SETSTR^VALM1($P(DGDEP,"^",5),DGX,9,14)
S DGX=$$SETSTR^VALM1($P(DGDEP,"^",9),DGX,23,10)
I $P(DGDEP,U,5)["P" D
. S DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15)
. S DGX=$$SETSTR^VALM1($P(DGDEP,U,10),DGX,45,30)
D SET^DGDEP(DGX)
;
Q:'$G(DGMTI)!('$P($G(^DG(408.11,RELATE,0)),U,4))
S INCPER=^DGMT(408.22,INCPER,0)
S DGX="",DGX=$$SETSTR^VALM1("Incapable of Self-support: ",DGX,10,27)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,9):"Yes",$P(INCPER,U,9)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
;
;* DG*5.3*624
S DGX="",DGX=$$SETSTR^VALM1("Child 18 to 23. Attended School: ",DGX,4,33)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,18):"Yes",$P(INCPER,U,18)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
;
S DGX="",DGX=$$SETSTR^VALM1("Child lived with you: ",DGX,15,22)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6):"Yes",$P(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
;
S DGX="",DGX=$$SETSTR^VALM1("Child Support: ",DGX,22,15)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,6)=1:"N/A",$P(INCPER,U,10)=1:"Yes",$P(INCPER,U,10)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
;
;* DG*5.3*624
;* DG*5.3*890 only display amount contributed if value already exists in field
I $P(INCPER,U,19)'="" D
. S DGX="",DGX=$$SETSTR^VALM1("Amount contributed: ",DGX,17,20)
. S DGX=$$SETSTR^VALM1($S($P(INCPER,U,10)'=1:"N/A",($P(INCPER,U,19)'="0")&($P(INCPER,U,19)'=""):$P(INCPER,U,19),$P(INCPER,U,19)="":"Unanswered",1:"0"),DGX,38,10)
. D SET^DGDEP(DGX)
;
;** DG*5.3*688 - GTS Chk MT Version and output correct data
S DGX=""
S:(+MTVER<1) DGX=$$SETSTR^VALM1("Child Has Income: ",DGX,19,18)
S:(+MTVER=1) DGX=$$SETSTR^VALM1("Child Has Income/Net Worth: ",DGX,9,28)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,11)=1:"Yes",$P(INCPER,U,11)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
;
;** DG*5.3*688 - GTS Chk MT Version and output correct data
S DGX=""
S:(+MTVER<1) DGX=$$SETSTR^VALM1("Income Available: ",DGX,19,18)
S:(+MTVER=1) DGX=$$SETSTR^VALM1("Income/Net Worth Available: ",DGX,9,28)
S DGX=$$SETSTR^VALM1($S($P(INCPER,U,11)=0:"N/A",$P(INCPER,U,12)=1:"Yes",$P(INCPER,U,12)="":"Unanswered",1:"No"),DGX,38,10)
D SET^DGDEP(DGX)
CHILDQ Q
;
ADDCHK(INCPER) ; Indicates existence of any dependent address
; Input:
; INCPER - Pointer to dep. entry in Income Relation file (408.22)
;
; Output:
; both address and phone^address^phone
; KEY:
; 0 - No data exists for the dependent in 408.13
; 1 - Data exists for the dependent in 408.13
;
; 1^1^1 - Address and Phone data exist for dependent
; 0^1^0 - Address only exists for dependent
; 0^0^1 - Phone only exists for dependent
; 0^0^0 - Neither Phone nor Address data exists for dependent
;
N ADDCKVAL,INDAIIEN,PRIEN,IPIEN
S ADDCKVAL="0^0^0"
S INDAIIEN=$P($G(^DGMT(408.22,INCPER,0)),"^",2)
S PRIEN=$P($G(^DGMT(408.21,INDAIIEN,0)),"^",2)
S IPIEN=$P($G(^DGPR(408.12,PRIEN,0)),"^",3)
I IPIEN["DGPR(408.13" DO
. S IPIEN=$P(IPIEN,";",1)
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",2)]"" S $P(ADDCKVAL,U,1,2)="1^1"
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",3)]"" S $P(ADDCKVAL,U,1,2)="1^1"
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",4)]"" S $P(ADDCKVAL,U,1,2)="1^1"
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",5)]"" S $P(ADDCKVAL,U,1,2)="1^1"
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",6)]"" S $P(ADDCKVAL,U,1,2)="1^1"
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",7)]"" S $P(ADDCKVAL,U,1,2)="1^1"
. I $P($G(^DGPR(408.13,IPIEN,1)),"^",8)]"" S $P(ADDCKVAL,U,3)="1"
Q ADDCKVAL
;
NEWB ; check dob and if newborn, default "married last year" to be no
N DOB,NOW
S XY=""
S DOB=$P(^DPT(DFN,0),"^",3)
D NOW^%DTC S NOW=X
I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;patient not a newborn
S XY=$O(^DGMT(408.22,"B",DFN,XY))
S $P(^DGMT(408.22,XY,0),"^",5)=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGDEP3 7727 printed Sep 23, 2025@20:17:48 Page 2
DGDEP3 ;ALB/CAW,BAJ,ERC,PWC - Dependents display ;11/22/2005
+1 ;;5.3;Registration;**45,624,653,688,867,890**;Aug 13, 1993;Build 40
+2 ;
SELF(INCPER,NAME,RELATE,ACT,DGMTI,CNT) ; Display information concerning veteran
+1 ;
+2 SET DGX=""
SET DGX=$$SETSTR^VALM1(CNT,DGX,3,3)
+3 IF $GET(DGMTI)
IF INCPER
IF ($PIECE($GET(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI)
SET DGX=$$SETSTR^VALM1("*",DGX,5,1)
+4 SET DGX=$$SETSTR^VALM1(NAME,DGX,9,22)
+5 SET DGX=$$SETSTR^VALM1($PIECE($GET(^DG(408.11,RELATE,0)),U),DGX,32,30)
+6 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(ACT,U,2)=1:"*",1:""),DGX,65,1)
+7 if RELATE=2
SET DGX=$$SETSTR^VALM1($SELECT(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1)
+8 DO SET^DGDEP(DGX)
+9 ;
+10 ; Display spouse SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
+11 IF RELATE=2
Begin DoDot:1
+12 SET DGX=""
SET DGX=$$SETSTR^VALM1($PIECE(DGDEP,"^",5),DGX,9,14)
+13 SET DGX=$$SETSTR^VALM1($PIECE(DGDEP,"^",9),DGX,23,10)
+14 ;if a Pseudo SSN need Pseudo SSN Reason - DG*5.3*653, ERC
+15 IF $PIECE(DGDEP,U,5)["P"
Begin DoDot:2
+16 SET DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15)
+17 SET DGX=$$SETSTR^VALM1($PIECE(DGDEP,U,10),DGX,45,30)
+18 ;D SET^DGDEP(DGX)
End DoDot:2
+19 DO SET^DGDEP(DGX)
End DoDot:1
+20 ;
+21 if RELATE=2
QUIT
+22 DO NEWB
DISPLAY ;
+1 ; MARRIED LAST YEAR = PIECE 5
+2 ; LIVED WITH SPOUSE = PIECE 6
+3 ; AMOUNT CONTRIBUTED = PIECE 7
+4 ; CONTRIBUTED TO SPOUSE = PIECE 20
+5 ; DG*5.3*890 Amount Contributed Decommissioned. Display only historical information
+6 SET INCPER=^DGMT(408.22,INCPER,0)
+7 SET DGX=""
SET DGX=$$SETSTR^VALM1("Married Last Year: ",DGX,18,19)
+8 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,5):"Yes",$PIECE(INCPER,U,5)="":"Unanswered",1:"No"),DGX,38,10)
+9 DO SET^DGDEP(DGX)
+10 ;
+11 if '$GET(DGMTI)
QUIT
+12 IF $PIECE(INCPER,U,5)=1
Begin DoDot:1
+13 SET DGX=""
SET DGX=$$SETSTR^VALM1("Lived with Spouse: ",DGX,18,19)
+14 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,6):"Yes",$PIECE(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10)
+15 DO SET^DGDEP(DGX)
End DoDot:1
+16 ;quit if Lived with Spouse and Married Last Year both equal YES
if $PIECE(INCPER,U,5)=1&($PIECE(INCPER,U,6)=1)
QUIT
+17 ;
+18 ; new contributed to spouse question was answered
IF $PIECE(INCPER,U,20)'=""
Begin DoDot:1
+19 SET DGX=""
SET DGX=$$SETSTR^VALM1("Contributed to Spouse: ",DGX,14,22)
+20 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,20):"Yes",$PIECE(INCPER,U,20)="":"Unanswered",1:"No"),DGX,38,10)
+21 DO SET^DGDEP(DGX)
End DoDot:1
+22 ;
+23 ;no need for old code because new question was answered
if $PIECE(INCPER,U,20)'=""
QUIT
+24 ;Lived with Spouse is Unanswered, no need to go further
if $PIECE(INCPER,U,6)=""
QUIT
+25 ;
+26 ;new question has not been answered yet, but amount has value, historical information will display
IF $PIECE(INCPER,U,7)'=""
Begin DoDot:1
+27 SET DGX=""
SET DGX=$$SETSTR^VALM1("Amount Contributed: ",DGX,17,19)
+28 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,7)]"":$PIECE(INCPER,U,7),1:"Unanswered"),DGX,38,10)
+29 DO SET^DGDEP(DGX)
End DoDot:1
QUIT
+30 ;
+31 ;Lived with Spouse is YES, so no need to go further
if $PIECE(INCPER,U,6)=1
QUIT
+32 ;
+33 ;new question not answered yet but no value is entered
IF $PIECE(INCPER,U,7)=""
Begin DoDot:1
+34 SET DGX=""
SET DGX=$$SETSTR^VALM1("Contributed to Spouse: ",DGX,14,22)
+35 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,20):"Yes",$PIECE(INCPER,U,20)="":"Unanswered",1:"No"),DGX,38,10)
+36 DO SET^DGDEP(DGX)
End DoDot:1
+37 QUIT
+38 ;
CHILD(INCPER,NAME,RELATE,ACT,DGMTI,DGMTACT,CNT) ; Display information concerning dependents
+1 ;
+2 ;** DG*5.3*688 - GTS Get MT Version
+3 ;** DG*5.3*890 - Amount Contributed Decommissioned. Display only historical information
+4 NEW MTVER
+5 if (+$GET(DGMTI)>0)
SET MTVER=$PIECE($GET(^DGMT(408.31,DGMTI,2)),"^",11)
+6 IF (+$GET(DGMTI)'>0)
Begin DoDot:1
+7 NEW DGINC,DGREL,DGINR,DGDEP
+8 DO ALL^DGMTU21(DFN,"VSD",DT,"I")
+9 SET MTVER=$$VER^DGMTUTL3(.DGINC)
End DoDot:1
+10 SET DGX=""
SET DGX=$$SETSTR^VALM1(CNT,DGX,3,3)
+11 IF $GET(DGMTI)
IF INCPER
IF ($PIECE($GET(^DGMT(408.22,+INCPER,"MT")),U)=DGMTI)
SET DGX=$$SETSTR^VALM1("*",DGX,5,1)
+12 SET DGX=$$SETSTR^VALM1(NAME,DGX,9,22)
+13 SET DGX=$$SETSTR^VALM1($PIECE($GET(^DG(408.11,RELATE,0)),U),DGX,32,30)
+14 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(ACT,U,2)=1:"*",1:""),DGX,65,1)
+15 SET DGX=$$SETSTR^VALM1($SELECT(+$$ADDCHK(INCPER)=1:"*",1:""),DGX,73,1)
+16 DO SET^DGDEP(DGX)
+17 ;
+18 ;display dependent SSN and SSN Verification status DG*5.3*688 BAJ 11/22/2005
+19 SET DGX=""
SET DGX=$$SETSTR^VALM1($PIECE(DGDEP,"^",5),DGX,9,14)
+20 SET DGX=$$SETSTR^VALM1($PIECE(DGDEP,"^",9),DGX,23,10)
+21 IF $PIECE(DGDEP,U,5)["P"
Begin DoDot:1
+22 SET DGX=$$SETSTR^VALM1("PSSN Reason: ",DGX,32,15)
+23 SET DGX=$$SETSTR^VALM1($PIECE(DGDEP,U,10),DGX,45,30)
End DoDot:1
+24 DO SET^DGDEP(DGX)
+25 ;
+26 if '$GET(DGMTI)!('$PIECE($GET(^DG(408.11,RELATE,0)),U,4))
QUIT
+27 SET INCPER=^DGMT(408.22,INCPER,0)
+28 SET DGX=""
SET DGX=$$SETSTR^VALM1("Incapable of Self-support: ",DGX,10,27)
+29 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,9):"Yes",$PIECE(INCPER,U,9)="":"Unanswered",1:"No"),DGX,38,10)
+30 DO SET^DGDEP(DGX)
+31 ;
+32 ;* DG*5.3*624
+33 SET DGX=""
SET DGX=$$SETSTR^VALM1("Child 18 to 23. Attended School: ",DGX,4,33)
+34 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,18):"Yes",$PIECE(INCPER,U,18)="":"Unanswered",1:"No"),DGX,38,10)
+35 DO SET^DGDEP(DGX)
+36 ;
+37 SET DGX=""
SET DGX=$$SETSTR^VALM1("Child lived with you: ",DGX,15,22)
+38 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,6):"Yes",$PIECE(INCPER,U,6)="":"Unanswered",1:"No"),DGX,38,10)
+39 DO SET^DGDEP(DGX)
+40 ;
+41 SET DGX=""
SET DGX=$$SETSTR^VALM1("Child Support: ",DGX,22,15)
+42 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,6)=1:"N/A",$PIECE(INCPER,U,10)=1:"Yes",$PIECE(INCPER,U,10)="":"Unanswered",1:"No"),DGX,38,10)
+43 DO SET^DGDEP(DGX)
+44 ;
+45 ;* DG*5.3*624
+46 ;* DG*5.3*890 only display amount contributed if value already exists in field
+47 IF $PIECE(INCPER,U,19)'=""
Begin DoDot:1
+48 SET DGX=""
SET DGX=$$SETSTR^VALM1("Amount contributed: ",DGX,17,20)
+49 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,10)'=1:"N/A",($PIECE(INCPER,U,19)'="0")&($PIECE(INCPER,U,19)'=""):$PIECE(INCPER,U,19),$PIECE(INCPER,U,19)="":"Unanswered",1:"0"),DGX,38,10)
+50 DO SET^DGDEP(DGX)
End DoDot:1
+51 ;
+52 ;** DG*5.3*688 - GTS Chk MT Version and output correct data
+53 SET DGX=""
+54 if (+MTVER<1)
SET DGX=$$SETSTR^VALM1("Child Has Income: ",DGX,19,18)
+55 if (+MTVER=1)
SET DGX=$$SETSTR^VALM1("Child Has Income/Net Worth: ",DGX,9,28)
+56 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,11)=1:"Yes",$PIECE(INCPER,U,11)="":"Unanswered",1:"No"),DGX,38,10)
+57 DO SET^DGDEP(DGX)
+58 ;
+59 ;** DG*5.3*688 - GTS Chk MT Version and output correct data
+60 SET DGX=""
+61 if (+MTVER<1)
SET DGX=$$SETSTR^VALM1("Income Available: ",DGX,19,18)
+62 if (+MTVER=1)
SET DGX=$$SETSTR^VALM1("Income/Net Worth Available: ",DGX,9,28)
+63 SET DGX=$$SETSTR^VALM1($SELECT($PIECE(INCPER,U,11)=0:"N/A",$PIECE(INCPER,U,12)=1:"Yes",$PIECE(INCPER,U,12)="":"Unanswered",1:"No"),DGX,38,10)
+64 DO SET^DGDEP(DGX)
CHILDQ QUIT
+1 ;
ADDCHK(INCPER) ; Indicates existence of any dependent address
+1 ; Input:
+2 ; INCPER - Pointer to dep. entry in Income Relation file (408.22)
+3 ;
+4 ; Output:
+5 ; both address and phone^address^phone
+6 ; KEY:
+7 ; 0 - No data exists for the dependent in 408.13
+8 ; 1 - Data exists for the dependent in 408.13
+9 ;
+10 ; 1^1^1 - Address and Phone data exist for dependent
+11 ; 0^1^0 - Address only exists for dependent
+12 ; 0^0^1 - Phone only exists for dependent
+13 ; 0^0^0 - Neither Phone nor Address data exists for dependent
+14 ;
+15 NEW ADDCKVAL,INDAIIEN,PRIEN,IPIEN
+16 SET ADDCKVAL="0^0^0"
+17 SET INDAIIEN=$PIECE($GET(^DGMT(408.22,INCPER,0)),"^",2)
+18 SET PRIEN=$PIECE($GET(^DGMT(408.21,INDAIIEN,0)),"^",2)
+19 SET IPIEN=$PIECE($GET(^DGPR(408.12,PRIEN,0)),"^",3)
+20 IF IPIEN["DGPR(408.13"
Begin DoDot:1
+21 SET IPIEN=$PIECE(IPIEN,";",1)
+22 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",2)]""
SET $PIECE(ADDCKVAL,U,1,2)="1^1"
+23 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",3)]""
SET $PIECE(ADDCKVAL,U,1,2)="1^1"
+24 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",4)]""
SET $PIECE(ADDCKVAL,U,1,2)="1^1"
+25 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",5)]""
SET $PIECE(ADDCKVAL,U,1,2)="1^1"
+26 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",6)]""
SET $PIECE(ADDCKVAL,U,1,2)="1^1"
+27 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",7)]""
SET $PIECE(ADDCKVAL,U,1,2)="1^1"
+28 IF $PIECE($GET(^DGPR(408.13,IPIEN,1)),"^",8)]""
SET $PIECE(ADDCKVAL,U,3)="1"
End DoDot:1
+29 QUIT ADDCKVAL
+30 ;
NEWB ; check dob and if newborn, default "married last year" to be no
+1 NEW DOB,NOW
+2 SET XY=""
+3 SET DOB=$PIECE(^DPT(DFN,0),"^",3)
+4 DO NOW^%DTC
SET NOW=X
+5 ;patient not a newborn
IF $$FMDIFF^XLFDT(NOW,DOB,1)>365
QUIT
+6 SET XY=$ORDER(^DGMT(408.22,"B",DFN,XY))
+7 SET $PIECE(^DGMT(408.22,XY,0),"^",5)=0
+8 QUIT
