DGRPEIS1 ;ALB/MIR - CALLS TO ADD NEW PATIENT RELATIONS AND INCOME PERSONS ; 6/19/09 11:33am
;;5.3;Registration;**10,45,108,624,688,805,834**;Aug 13, 1993;Build 4
;Adds entries to FILES #408.12 & 408.13
;
NEW ;check if data in FILE #408.12
;out - DGPRI=IFN of #408.12
; DGFL [-1='^'/-2=time-out]
N DGRPDOB,DGRP0ND
I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT)
S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)),DGFL=$G(DGFL)
I '$D(^DGPR(408.12,+DGPRI,0)) S DGRP0ND=DFN_"^"_1_"^"_DFN_";DPT(",DGRPDOB=$P($G(^DPT(+DFN,0)),"^",3) D NEWPR
S DGIRI=$O(^DGMT(408.22,"B",DFN,0))
I '$D(^DGMT(408.22,+DGIRI,0)) D GETIENS^DGMTU2(DFN,+DGPRI,DGTSTDT)
Q
NEWIP ;Add relation to #408.13 file
; In - DFN=IEN of File #2
; DGRP0ND=0 node of 408.13
; DGDEP=Optional count of children dependents associated with patient
;Out - DGIPI=408.13 IEN
K DINUM N DGRPDOB,DGSEX,I,X
S:('$D(DGDEP)) DGDEP=""
S DGRPDOB=$P(DGRP0ND,"^",3),DGSEX=$P(DGRP0ND,"^",2)
N CNT,I S CNT=0
F I=2,3,9 D
.S CNT=CNT+1,$P(DIC("DR"),";",CNT)=".0"_I_"////"_$P(DGRP0ND,U,I)
F I=10,11 D
.S CNT=CNT+1,$P(DIC("DR"),";",CNT)="."_I_"////"_$P(DGRP0ND,U,I)
F I=1:1:8 S DIC("DR")=DIC("DR")_";1."_I_"////"_$P(DGRP1ND,U,I)
S (DIK,DIC)="^DGPR(408.13,",DIC(0)="L",DLAYGO=408.13,X=$P(DGRP0ND,"^",1) K DD,DO D FILE^DICN S (DGIPI,DA)=+Y K DLAYGO
S Y=DGIPI,DGRP0ND=DFN_"^"_$S(SPOUSE:2,1:"")_"^"_+Y_";DGPR(408.13,"
;FALLS THRU!
NEWPR ;Add entry to file #408.12
;In - DGRP0ND=0 node of 408.12
; DGRPDOB=DOB of relation
;Out - DGPRI=IFN of new 408.12 entry
K DINUM N DOB,X
I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT)
S DOB=$G(DGRPDOB) I 'DOB S DOB=$E(DGTSTDT,1,3)-1_"0101" ; use dob for effective date...default = Jan 1 of prior year
DIC ;* GTS - DG*6.3*688 restructured the IF code and DIC("S") that follows
N DGDEPCNT
S DGDEPCNT=$$CNTDEPS^DGMTU11(DFN)
I $P(DGRP0ND,"^",2)']"" DO
.S DIC="^DG(408.11,"
.S DIC(0)="AEQMZ"
.S DIC("A")="RELATIONSHIP: "
.S DIC("S")="I Y>2,""E""_DGSEX[$P(^(0),""^"",3),$S((DGTYPE=""D"")&(+DGDEPCNT<19):1,(DGTYPE=""D"")&(+DGDEPCNT>18)&(Y>6):1,(DGTYPE=""C"")&(Y<7):1,1:0)"
I $P(DGRP0ND,"^",2)']"" D ^DIC I '$D(DTOUT),(Y'>0) W *7," Required!!" G DIC
I $D(DTOUT) K DTOUT S DGFL=-2 G NEWPRQ
I $P(DGRP0ND,"^",2)']"" S $P(DGRP0ND,"^",2)=+Y
D ACT^DGRPEIS2 I DGFL<0 D G NEWPRQ
.W !?3,*7,"Entry incomplete...deleted",!
.Q:'$G(DA)!($G(DIK)'="^DGPR(408.13,") ;defined for deps in newip
.D ^DIK
; ADDED FOR 834
I $G(DFN),$$GET1^DIQ(2,DFN,.03,"I")>DGACT D G NEWPRQ
. W !?3,*7,"Effective date is prior to veteran's DOB (",$$GET1^DIQ(2,DFN,.03),")...deleted",!
. Q:'$G(DA)!($G(DIK)'="^DGPR(408.13,")
. D ^DIK
. N DIR S DIR(0)="FAO",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
S DIC("DR")=".02////"_$P(DGRP0ND,U,2)
N VAR S VAR=$P(DGRP0ND,U,3)
S DIC("DR")=DIC("DR")_";.03////^S X=VAR"
S (DIK,DIC)="^DGPR(408.12,",DIC(0)="L",DLAYGO=408.12,X=+DGRP0ND K DD,DO D FILE^DICN S DGPRI=+Y K DLAYGO D
.N DD,D0,DA,DLAYGO,DIC,X
.S DA(1)=DGPRI,DIC(0)="L",DIC="^DGPR(408.12,"_DA(1)_",""E"","
.S DLAYGO=408.1275,DIC("DR")=".02////1",X=DGACT
.D FILE^DICN
D RESET^DGMTU11(DFN)
S Y=DGPRI
NEWPRQ K DGACT,DGSEX,DGRPDOB,DA,DIC,DIK,DIRUT,DTOUT,DUOUT,X,Y
Q
SETUP ; called from SPINACT / sets vars for ASOF tag
N FNAME S FNAME=$P($$NAME^DGMTU1(+X),",",2)
S ACT=$O(^DGPR(408.12,+X,"E","AID","")),ACT=$O(^(+ACT,0)),ACT=$G(^DGPR(408.12,+X,"E",+ACT,0))
I $P(ACT,"^",2)']"" Q ; never active
I '$P(ACT,U,2) D Q
.W !,"Dependent has been inactivated as of "
.S Y=+ACT
.D DD^%DT W Y H 3
S IEN=+X
ASOF ;ask as of date
N LYR,SPOUSE,DGXDT
I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT)
S SPOUSE=$S($P($G(^DGPR(408.12,+IEN,0)),"^",2)=2:1,1:0)
S LYR=$E($$LYR^DGMTSCU1(DGTSTDT),1,3)_1231
;I 'SPOUSE S LYR=$E($$LYR^DGMTSCU1(LYR),1,3)_1231
K DIR S DIR(0)="D^"_+ACT_":"_LYR_":AEP",DIR("A")="Date "_FNAME_" no longer a dependent"
S DIR("?",1)="Enter the date this person was no longer a dependent of the veteran.",DIR("?",2)="This could include a date of death or the date a child turned 18 for"
S DIR("?",3)="children. For a spouse, this would be the date of divorce or date ",DIR("?",4)="of death of the spouse. Date must be after the person became a"
S DIR("?",5)="dependent, but prior to 12/31/"_($E(LYR,1,3)+1700)_"."
I 'SPOUSE S DIR("?",6)=" ",DIR("?",7)="A person should only be inactivated if the individual was not a",DIR("?",8)="dependent at any time during the prior calendar year."
S DIR("?")=" "
I SPOUSE S DIR("?",6)=" ",DIR("?",7)="A spouse should be inactivated if the spouse and veteran were not",DIR("?",8)="married as of 12/31/"_($E(LYR,1,3)+1700)_"."
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) S DGFL=$S($D(DTOUT):-2,1:-1) Q
S DGXDT=Y
I $E(Y,1,3)=$E(LYR,1,3) D Q:'$G(Y)
.N DIR,DIRUT,DIROUT,DTOUT,DUOUT
.W !!,"Warning: Data will be used if dependent was active at least one day in a"
.W !,"year. Data will not be used if inactivation is prior to 1/1/"_($E(LYR,1,3)+1700)_" or it"
.W !,"is equal to the activation date."
.S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to inactivate this dependent on the selected date?"
.D ^DIR
S DA(1)=IEN,DIC="^DGPR(408.12,"_DA(1)_",""E"",",X=DGXDT,DIC(0)="L",DLAYGO=408.1275 D ^DIC S DIE=DIC,DA=+Y,DR=".02////0" D ^DIE
D RESET^DGMTU11(DFN)
ASOFQ K DA,DIC,DIE,DIR,DIRUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPEIS1 5420 printed Nov 22, 2024@18:06:21 Page 2
DGRPEIS1 ;ALB/MIR - CALLS TO ADD NEW PATIENT RELATIONS AND INCOME PERSONS ; 6/19/09 11:33am
+1 ;;5.3;Registration;**10,45,108,624,688,805,834**;Aug 13, 1993;Build 4
+2 ;Adds entries to FILES #408.12 & 408.13
+3 ;
NEW ;check if data in FILE #408.12
+1 ;out - DGPRI=IFN of #408.12
+2 ; DGFL [-1='^'/-2=time-out]
+3 NEW DGRPDOB,DGRP0ND
+4 IF '$DATA(DGTSTDT)
NEW DGTSTDT
SET DGTSTDT=$SELECT($DATA(DGMTDT):DGMTDT,1:DT)
+5 SET DGPRI=$ORDER(^DGPR(408.12,"C",DFN_";DPT(",0))
SET DGFL=$GET(DGFL)
+6 IF '$DATA(^DGPR(408.12,+DGPRI,0))
SET DGRP0ND=DFN_"^"_1_"^"_DFN_";DPT("
SET DGRPDOB=$PIECE($GET(^DPT(+DFN,0)),"^",3)
DO NEWPR
+7 SET DGIRI=$ORDER(^DGMT(408.22,"B",DFN,0))
+8 IF '$DATA(^DGMT(408.22,+DGIRI,0))
DO GETIENS^DGMTU2(DFN,+DGPRI,DGTSTDT)
+9 QUIT
NEWIP ;Add relation to #408.13 file
+1 ; In - DFN=IEN of File #2
+2 ; DGRP0ND=0 node of 408.13
+3 ; DGDEP=Optional count of children dependents associated with patient
+4 ;Out - DGIPI=408.13 IEN
+5 KILL DINUM
NEW DGRPDOB,DGSEX,I,X
+6 if ('$DATA(DGDEP))
SET DGDEP=""
+7 SET DGRPDOB=$PIECE(DGRP0ND,"^",3)
SET DGSEX=$PIECE(DGRP0ND,"^",2)
+8 NEW CNT,I
SET CNT=0
+9 FOR I=2,3,9
Begin DoDot:1
+10 SET CNT=CNT+1
SET $PIECE(DIC("DR"),";",CNT)=".0"_I_"////"_$PIECE(DGRP0ND,U,I)
End DoDot:1
+11 FOR I=10,11
Begin DoDot:1
+12 SET CNT=CNT+1
SET $PIECE(DIC("DR"),";",CNT)="."_I_"////"_$PIECE(DGRP0ND,U,I)
End DoDot:1
+13 FOR I=1:1:8
SET DIC("DR")=DIC("DR")_";1."_I_"////"_$PIECE(DGRP1ND,U,I)
+14 SET (DIK,DIC)="^DGPR(408.13,"
SET DIC(0)="L"
SET DLAYGO=408.13
SET X=$PIECE(DGRP0ND,"^",1)
KILL DD,DO
DO FILE^DICN
SET (DGIPI,DA)=+Y
KILL DLAYGO
+15 SET Y=DGIPI
SET DGRP0ND=DFN_"^"_$SELECT(SPOUSE:2,1:"")_"^"_+Y_";DGPR(408.13,"
+16 ;FALLS THRU!
NEWPR ;Add entry to file #408.12
+1 ;In - DGRP0ND=0 node of 408.12
+2 ; DGRPDOB=DOB of relation
+3 ;Out - DGPRI=IFN of new 408.12 entry
+4 KILL DINUM
NEW DOB,X
+5 IF '$DATA(DGTSTDT)
NEW DGTSTDT
SET DGTSTDT=$SELECT($DATA(DGMTDT):DGMTDT,1:DT)
+6 ; use dob for effective date...default = Jan 1 of prior year
SET DOB=$GET(DGRPDOB)
IF 'DOB
SET DOB=$EXTRACT(DGTSTDT,1,3)-1_"0101"
DIC ;* GTS - DG*6.3*688 restructured the IF code and DIC("S") that follows
+1 NEW DGDEPCNT
+2 SET DGDEPCNT=$$CNTDEPS^DGMTU11(DFN)
+3 IF $PIECE(DGRP0ND,"^",2)']""
Begin DoDot:1
+4 SET DIC="^DG(408.11,"
+5 SET DIC(0)="AEQMZ"
+6 SET DIC("A")="RELATIONSHIP: "
+7 SET DIC("S")="I Y>2,""E""_DGSEX[$P(^(0),""^"",3),$S((DGTYPE=""D"")&(+DGDEPCNT<19):1,(DGTYPE=""D"")&(+DGDEPCNT>18)&(Y>6):1,(DGTYPE=""C"")&(Y<7):1,1:0)"
End DoDot:1
+8 IF $PIECE(DGRP0ND,"^",2)']""
DO ^DIC
IF '$DATA(DTOUT)
IF (Y'>0)
WRITE *7," Required!!"
GOTO DIC
+9 IF $DATA(DTOUT)
KILL DTOUT
SET DGFL=-2
GOTO NEWPRQ
+10 IF $PIECE(DGRP0ND,"^",2)']""
SET $PIECE(DGRP0ND,"^",2)=+Y
+11 DO ACT^DGRPEIS2
IF DGFL<0
Begin DoDot:1
+12 WRITE !?3,*7,"Entry incomplete...deleted",!
+13 ;defined for deps in newip
if '$GET(DA)!($GET(DIK)'="^DGPR(408.13,")
QUIT
+14 DO ^DIK
End DoDot:1
GOTO NEWPRQ
+15 ; ADDED FOR 834
+16 IF $GET(DFN)
IF $$GET1^DIQ(2,DFN,.03,"I")>DGACT
Begin DoDot:1
+17 WRITE !?3,*7,"Effective date is prior to veteran's DOB (",$$GET1^DIQ(2,DFN,.03),")...deleted",!
+18 if '$GET(DA)!($GET(DIK)'="^DGPR(408.13,")
QUIT
+19 DO ^DIK
+20 NEW DIR
SET DIR(0)="FAO"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:1
GOTO NEWPRQ
+21 SET DIC("DR")=".02////"_$PIECE(DGRP0ND,U,2)
+22 NEW VAR
SET VAR=$PIECE(DGRP0ND,U,3)
+23 SET DIC("DR")=DIC("DR")_";.03////^S X=VAR"
+24 SET (DIK,DIC)="^DGPR(408.12,"
SET DIC(0)="L"
SET DLAYGO=408.12
SET X=+DGRP0ND
KILL DD,DO
DO FILE^DICN
SET DGPRI=+Y
KILL DLAYGO
Begin DoDot:1
+25 NEW DD,D0,DA,DLAYGO,DIC,X
+26 SET DA(1)=DGPRI
SET DIC(0)="L"
SET DIC="^DGPR(408.12,"_DA(1)_",""E"","
+27 SET DLAYGO=408.1275
SET DIC("DR")=".02////1"
SET X=DGACT
+28 DO FILE^DICN
End DoDot:1
+29 DO RESET^DGMTU11(DFN)
+30 SET Y=DGPRI
NEWPRQ KILL DGACT,DGSEX,DGRPDOB,DA,DIC,DIK,DIRUT,DTOUT,DUOUT,X,Y
+1 QUIT
SETUP ; called from SPINACT / sets vars for ASOF tag
+1 NEW FNAME
SET FNAME=$PIECE($$NAME^DGMTU1(+X),",",2)
+2 SET ACT=$ORDER(^DGPR(408.12,+X,"E","AID",""))
SET ACT=$ORDER(^(+ACT,0))
SET ACT=$GET(^DGPR(408.12,+X,"E",+ACT,0))
+3 ; never active
IF $PIECE(ACT,"^",2)']""
QUIT
+4 IF '$PIECE(ACT,U,2)
Begin DoDot:1
+5 WRITE !,"Dependent has been inactivated as of "
+6 SET Y=+ACT
+7 DO DD^%DT
WRITE Y
HANG 3
End DoDot:1
QUIT
+8 SET IEN=+X
ASOF ;ask as of date
+1 NEW LYR,SPOUSE,DGXDT
+2 IF '$DATA(DGTSTDT)
NEW DGTSTDT
SET DGTSTDT=$SELECT($DATA(DGMTDT):DGMTDT,1:DT)
+3 SET SPOUSE=$SELECT($PIECE($GET(^DGPR(408.12,+IEN,0)),"^",2)=2:1,1:0)
+4 SET LYR=$EXTRACT($$LYR^DGMTSCU1(DGTSTDT),1,3)_1231
+5 ;I 'SPOUSE S LYR=$E($$LYR^DGMTSCU1(LYR),1,3)_1231
+6 KILL DIR
SET DIR(0)="D^"_+ACT_":"_LYR_":AEP"
SET DIR("A")="Date "_FNAME_" no longer a dependent"
+7 SET DIR("?",1)="Enter the date this person was no longer a dependent of the veteran."
SET DIR("?",2)="This could include a date of death or the date a child turned 18 for"
+8 SET DIR("?",3)="children. For a spouse, this would be the date of divorce or date "
SET DIR("?",4)="of death of the spouse. Date must be after the person became a"
+9 SET DIR("?",5)="dependent, but prior to 12/31/"_($EXTRACT(LYR,1,3)+1700)_"."
+10 IF 'SPOUSE
SET DIR("?",6)=" "
SET DIR("?",7)="A person should only be inactivated if the individual was not a"
SET DIR("?",8)="dependent at any time during the prior calendar year."
+11 SET DIR("?")=" "
+12 IF SPOUSE
SET DIR("?",6)=" "
SET DIR("?",7)="A spouse should be inactivated if the spouse and veteran were not"
SET DIR("?",8)="married as of 12/31/"_($EXTRACT(LYR,1,3)+1700)_"."
+13 DO ^DIR
KILL DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
SET DGFL=$SELECT($DATA(DTOUT):-2,1:-1)
QUIT
+15 SET DGXDT=Y
+16 IF $EXTRACT(Y,1,3)=$EXTRACT(LYR,1,3)
Begin DoDot:1
+17 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT
+18 WRITE !!,"Warning: Data will be used if dependent was active at least one day in a"
+19 WRITE !,"year. Data will not be used if inactivation is prior to 1/1/"_($EXTRACT(LYR,1,3)+1700)_" or it"
+20 WRITE !,"is equal to the activation date."
+21 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to inactivate this dependent on the selected date?"
+22 DO ^DIR
End DoDot:1
if '$GET(Y)
QUIT
+23 SET DA(1)=IEN
SET DIC="^DGPR(408.12,"_DA(1)_",""E"","
SET X=DGXDT
SET DIC(0)="L"
SET DLAYGO=408.1275
DO ^DIC
SET DIE=DIC
SET DA=+Y
SET DR=".02////0"
DO ^DIE
+24 DO RESET^DGMTU11(DFN)
ASOFQ KILL DA,DIC,DIE,DIR,DIRUT,DLAYGO,DR,DTOUT,DUOUT,X,Y
+1 QUIT
