DGRPEIS2 ;ALB/MIR,ERC - EDIT INCOME SCREENING DATA (SCREEN 9) ; 4/20/06 10:37am
;;5.3;Registration;**10,45,122,653,688**;Aug 13, 1993;Build 29
; -Called from DGRPE to edit Scr #9 (Income Screening)
EDIT9 ; Allow edit of income screening amounts (called from DGRPE)
; In: DFN
; DGRPANN as string of selected items
; DGRPSEL as allowable groups for edit (V, S, and/or D)
; DGRPSELT (maybe) as type of dependent selected (V=vet,
; S=spouse, and D=dependent). If not defined, it is set
; to DGRPSEL.
N MTVER,DGMTI,DGTY,DGIAIYR,DGTYEXT
I 'DGRPANN Q ; if no string passed in (nothing selected)
S DGRPSELT=$G(DGRPSELT) I DGRPSELT']"" S DGRPSELT=DGRPSEL ; if no V, S, or D preface, edit all
D ALL^DGMTU21(DFN,"VSD",DT,"IP")
S DGIAIYR=$P($G(^DGMT(408.21,+$G(DGINC("V")),0)),"^",1)
S DGIAIYR=$E(DGIAIYR,1,3)+1700
S DGMTI=+$$LST^DGMTU(DFN,DT)
I (+DGMTI>0),(+DGIAIYR>0) DO
. S DGTY=$E($P(^DGMT(408.31,+DGMTI,0),"^",1),1,3)
. S DGTYEXT=DGTY+1700
. S:(DGTYEXT=DGIAIYR+1) MTVER=$P($G(^DGMT(408.31,+DGMTI,2)),"^",11)
. S:(DGTYEXT'=(DGIAIYR+1)) MTVER=$$VER^DGMTUTL3(.DGINC)
I (+DGMTI'>0)!(+DGIAIYR'>0) S MTVER=$$VER^DGMTUTL3(.DGINC)
I '$G(DGREL("V")) D HELP^DGRPEIS3 G EDIT9Q
I DGRPSELT["V" S DGPRI=+DGREL("V"),DGMTED=$D(DGMTED("V")) D EDT
I '$G(DGRPOUT)&(DGRPSELT["S") S DGPRI=+DGREL("S"),DGMTED=$D(DGMTED("S")) D EDT
I '$G(DGRPOUT)&(DGRPSELT["D") F DGCNT=0:0 S DGCNT=$O(DGREL("D",DGCNT)) Q:'DGCNT!($G(DGRPOUT)) S DGPRI=+DGREL("D",DGCNT),DGMTED=$D(DGMTED("D",DGCNT)) D EDT
S DGFL=$G(DGFL)
K DGCNT
EDIT9Q Q
;
EDT ;Edit inc and nt worth
N DA,DGERR,DGFIN,DGINI,DGIRI,DIE,DR,OK
I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT)
D GETIENS^DGMTU2(DFN,+DGPRI,DGTSTDT) G EDTQ:DGERR
I DGRPSELT]"" W !!,"NAME: ",$$NAME^DGMTU1(DGPRI)
I DGMTED W " [Must edit through means test!!]" Q
S DA=DGINI,DIE="^DGMT(408.21,"
S:(+MTVER<1) DR="[DGRP ENTER/EDIT ANNUAL INCOME]"
S:(+MTVER=1) DR="[DGRP V1 ENTER/EDIT ANNUAL INC]"
D ^DIE S:'$D(DGFIN) DGRPOUT=1
I $D(DTOUT) S DGFL=-2,DGRPOUT=1 Q
I 'DGRPOUT S DR="103////^S X=DUZ;104///^S X=""NOW""" D ^DIE
I 'DGRPOUT&'$D(DGINC("V")) D GETIENS^DGMTU2(DFN,+DGREL("V"),DT) S DGINC("V")=DGINI G:DGERR EDTQ
I 'DGRPOUT&($G(DA)'=$G(DGINC("V"))) S DA=DGINC("V") D ^DIE
;
;log patient for transmission to HEC if DCD criteria are met
D LOGDCD^IVMCUC($G(DFN))
;
EDTQ Q
;
SPOUSE ; make sure marital status, spouse is up-to-date
; input -- DFN
; DGREL("V") as returned from GETREL for veteran
; used -- DGSPFL as VETS marital status
N DGMS
D GETIENS^DGMTU2(DFN,+DGREL("V"),DT)
S DGMS=$P($G(^DIC(11,+$P($G(^DPT(DFN,0)),"^",5),0)),"^",3),DGMS=$S("^M^S^"[("^"_DGMS_"^"):"YES",DGMS']"":"",1:"NO")
D GETREL^DGMTU11(DFN,"S",DT,$G(DGMTI)) I $D(DGREL("S")) S DGMS="YES"
;
SPOUSE1 S DIE="^DGMT(408.22,",DA=DGIRI,DR=".05"_$S($G(DGMTI):"///",1:"//")_"^S X=DGMS" D ^DIE K DIE,DA,DR
S DGSPFL=$P($G(^DGMT(408.22,DGIRI,0)),"^",5)
Q
;
ACT ; ask date active as of (use dob if KIDS)
; In: DOB
; DGRP0ND as 0 node of PATIENT RELATION file (relation=piece 2)
;Out: DGACT as date patient should be activated as of
; DGFL as -1 if '^' or -2 if time-out
N RELATION,X,Y
S DGFL=$G(DGFL),RELATION=$P(DGRP0ND,"^",2)
I RELATION=1 S DGACT=DOB Q ;use DOB is self
I "^3^4^"[("^"_RELATION_"^") S Y=DOB X ^DD("DD") S DIR("B")=Y ;if son or daughter, use DOB as default
;
READ ; get active as of date
; DIR("B") set before entry
; DOB passed in as input
N DGDT,DGISDT,DGDTSPEC,VDOB
I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT)
S DGDT=$E(DGTSTDT,1,3)-1_"1231",DGISDT=$E(DGDT,1,3)+1700,DGACT=DOB
S DGDTSPEC=$S($G(DGEDDEP):":EPX",1:":EP")
;S DIR(0)="D^"_DOB_":"_DGDT_DGDTSPEC,DIR("A")="EFFECTIVE DATE"
S DIR(0)="D^"_DOB
I RELATION=2 S VDOB=$P($G(^DPT(DFN,0)),"^",3) S:(VDOB>DOB) $P(DIR(0),"^",2)=VDOB
S DIR(0)=DIR(0)_":"_DGDT_DGDTSPEC,DIR("A")="EFFECTIVE DATE"
S DIR("?")="^D HELP1^DGRPEIS3(DGISDT)"
D ^DIR K DIR I Y'>0 S DGFL=$S($D(DTOUT):-2,$D(DUOUT)!$D(DIRUT):-1,1:0) G ACTQ:DGFL,READ
S DGACT=Y
ACTQ K DIRUT,DTOUT,DUOUT
Q
RELTYPE(RELIEN,TYPE) ;* Return type of relationship
;
;* INPUT
; RELIEN - IEN from Income Person file (408.13)
; TYPE - 0: Pull specific relationship from Relationship file
; - 1: Just return "spouse", "child", "dependent"
;
;* OUTPUT
; DGPATREL - Relationship value
;
N DGPTRLIN,DGRELIEN,DGPATREL
S TYPE=+$G(TYPE)
I +$G(RELIEN)>0 DO
.S DGPTRLIN=""
.S DGPTRLIN=$O(^DGPR(408.12,"C",RELIEN_";DGPR(408.13,",DGPTRLIN))
.S DGRELIEN=$P($G(^DGPR(408.12,DGPTRLIN,0)),"^",2)
.S DGPATREL=$P($G(^DG(408.11,DGRELIEN,0)),"^",1)
.S:DGPATREL']"" DGPATREL="dependent"
.I +TYPE=1 S DGPATREL=$S(DGPATREL["SPOUSE":"spouse",($G(DGRPS)=8):"relative",$G(DGSCR8):"relative",1:"child")
I +$G(RELIEN)'>0 DO
.S:$G(DGANS)="S" DGPATREL="spouse"
.S:$G(DGANS)="C" DGPATREL="child"
.S:$G(DGANS)="D" DGPATREL="relative"
S:DGPATREL="" DGPATREL="relative"
Q DGPATREL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPEIS2 5037 printed Apr 09, 2024@21:37:57 Page 2
DGRPEIS2 ;ALB/MIR,ERC - EDIT INCOME SCREENING DATA (SCREEN 9) ; 4/20/06 10:37am
+1 ;;5.3;Registration;**10,45,122,653,688**;Aug 13, 1993;Build 29
+2 ; -Called from DGRPE to edit Scr #9 (Income Screening)
EDIT9 ; Allow edit of income screening amounts (called from DGRPE)
+1 ; In: DFN
+2 ; DGRPANN as string of selected items
+3 ; DGRPSEL as allowable groups for edit (V, S, and/or D)
+4 ; DGRPSELT (maybe) as type of dependent selected (V=vet,
+5 ; S=spouse, and D=dependent). If not defined, it is set
+6 ; to DGRPSEL.
+7 NEW MTVER,DGMTI,DGTY,DGIAIYR,DGTYEXT
+8 ; if no string passed in (nothing selected)
IF 'DGRPANN
QUIT
+9 ; if no V, S, or D preface, edit all
SET DGRPSELT=$GET(DGRPSELT)
IF DGRPSELT']""
SET DGRPSELT=DGRPSEL
+10 DO ALL^DGMTU21(DFN,"VSD",DT,"IP")
+11 SET DGIAIYR=$PIECE($GET(^DGMT(408.21,+$GET(DGINC("V")),0)),"^",1)
+12 SET DGIAIYR=$EXTRACT(DGIAIYR,1,3)+1700
+13 SET DGMTI=+$$LST^DGMTU(DFN,DT)
+14 IF (+DGMTI>0)
IF (+DGIAIYR>0)
Begin DoDot:1
+15 SET DGTY=$EXTRACT($PIECE(^DGMT(408.31,+DGMTI,0),"^",1),1,3)
+16 SET DGTYEXT=DGTY+1700
+17 if (DGTYEXT=DGIAIYR+1)
SET MTVER=$PIECE($GET(^DGMT(408.31,+DGMTI,2)),"^",11)
+18 if (DGTYEXT'=(DGIAIYR+1))
SET MTVER=$$VER^DGMTUTL3(.DGINC)
End DoDot:1
+19 IF (+DGMTI'>0)!(+DGIAIYR'>0)
SET MTVER=$$VER^DGMTUTL3(.DGINC)
+20 IF '$GET(DGREL("V"))
DO HELP^DGRPEIS3
GOTO EDIT9Q
+21 IF DGRPSELT["V"
SET DGPRI=+DGREL("V")
SET DGMTED=$DATA(DGMTED("V"))
DO EDT
+22 IF '$GET(DGRPOUT)&(DGRPSELT["S")
SET DGPRI=+DGREL("S")
SET DGMTED=$DATA(DGMTED("S"))
DO EDT
+23 IF '$GET(DGRPOUT)&(DGRPSELT["D")
FOR DGCNT=0:0
SET DGCNT=$ORDER(DGREL("D",DGCNT))
if 'DGCNT!($GET(DGRPOUT))
QUIT
SET DGPRI=+DGREL("D",DGCNT)
SET DGMTED=$DATA(DGMTED("D",DGCNT))
DO EDT
+24 SET DGFL=$GET(DGFL)
+25 KILL DGCNT
EDIT9Q QUIT
+1 ;
EDT ;Edit inc and nt worth
+1 NEW DA,DGERR,DGFIN,DGINI,DGIRI,DIE,DR,OK
+2 IF '$DATA(DGTSTDT)
NEW DGTSTDT
SET DGTSTDT=$SELECT($DATA(DGMTDT):DGMTDT,1:DT)
+3 DO GETIENS^DGMTU2(DFN,+DGPRI,DGTSTDT)
if DGERR
GOTO EDTQ
+4 IF DGRPSELT]""
WRITE !!,"NAME: ",$$NAME^DGMTU1(DGPRI)
+5 IF DGMTED
WRITE " [Must edit through means test!!]"
QUIT
+6 SET DA=DGINI
SET DIE="^DGMT(408.21,"
+7 if (+MTVER<1)
SET DR="[DGRP ENTER/EDIT ANNUAL INCOME]"
+8 if (+MTVER=1)
SET DR="[DGRP V1 ENTER/EDIT ANNUAL INC]"
+9 DO ^DIE
if '$DATA(DGFIN)
SET DGRPOUT=1
+10 IF $DATA(DTOUT)
SET DGFL=-2
SET DGRPOUT=1
QUIT
+11 IF 'DGRPOUT
SET DR="103////^S X=DUZ;104///^S X=""NOW"""
DO ^DIE
+12 IF 'DGRPOUT&'$DATA(DGINC("V"))
DO GETIENS^DGMTU2(DFN,+DGREL("V"),DT)
SET DGINC("V")=DGINI
if DGERR
GOTO EDTQ
+13 IF 'DGRPOUT&($GET(DA)'=$GET(DGINC("V")))
SET DA=DGINC("V")
DO ^DIE
+14 ;
+15 ;log patient for transmission to HEC if DCD criteria are met
+16 DO LOGDCD^IVMCUC($GET(DFN))
+17 ;
EDTQ QUIT
+1 ;
SPOUSE ; make sure marital status, spouse is up-to-date
+1 ; input -- DFN
+2 ; DGREL("V") as returned from GETREL for veteran
+3 ; used -- DGSPFL as VETS marital status
+4 NEW DGMS
+5 DO GETIENS^DGMTU2(DFN,+DGREL("V"),DT)
+6 SET DGMS=$PIECE($GET(^DIC(11,+$PIECE($GET(^DPT(DFN,0)),"^",5),0)),"^",3)
SET DGMS=$SELECT("^M^S^"[("^"_DGMS_"^"):"YES",DGMS']"":"",1:"NO")
+7 DO GETREL^DGMTU11(DFN,"S",DT,$GET(DGMTI))
IF $DATA(DGREL("S"))
SET DGMS="YES"
+8 ;
SPOUSE1 SET DIE="^DGMT(408.22,"
SET DA=DGIRI
SET DR=".05"_$SELECT($GET(DGMTI):"///",1:"//")_"^S X=DGMS"
DO ^DIE
KILL DIE,DA,DR
+1 SET DGSPFL=$PIECE($GET(^DGMT(408.22,DGIRI,0)),"^",5)
+2 QUIT
+3 ;
ACT ; ask date active as of (use dob if KIDS)
+1 ; In: DOB
+2 ; DGRP0ND as 0 node of PATIENT RELATION file (relation=piece 2)
+3 ;Out: DGACT as date patient should be activated as of
+4 ; DGFL as -1 if '^' or -2 if time-out
+5 NEW RELATION,X,Y
+6 SET DGFL=$GET(DGFL)
SET RELATION=$PIECE(DGRP0ND,"^",2)
+7 ;use DOB is self
IF RELATION=1
SET DGACT=DOB
QUIT
+8 ;if son or daughter, use DOB as default
IF "^3^4^"[("^"_RELATION_"^")
SET Y=DOB
XECUTE ^DD("DD")
SET DIR("B")=Y
+9 ;
READ ; get active as of date
+1 ; DIR("B") set before entry
+2 ; DOB passed in as input
+3 NEW DGDT,DGISDT,DGDTSPEC,VDOB
+4 IF '$DATA(DGTSTDT)
NEW DGTSTDT
SET DGTSTDT=$SELECT($DATA(DGMTDT):DGMTDT,1:DT)
+5 SET DGDT=$EXTRACT(DGTSTDT,1,3)-1_"1231"
SET DGISDT=$EXTRACT(DGDT,1,3)+1700
SET DGACT=DOB
+6 SET DGDTSPEC=$SELECT($GET(DGEDDEP):":EPX",1:":EP")
+7 ;S DIR(0)="D^"_DOB_":"_DGDT_DGDTSPEC,DIR("A")="EFFECTIVE DATE"
+8 SET DIR(0)="D^"_DOB
+9 IF RELATION=2
SET VDOB=$PIECE($GET(^DPT(DFN,0)),"^",3)
if (VDOB>DOB)
SET $PIECE(DIR(0),"^",2)=VDOB
+10 SET DIR(0)=DIR(0)_":"_DGDT_DGDTSPEC
SET DIR("A")="EFFECTIVE DATE"
+11 SET DIR("?")="^D HELP1^DGRPEIS3(DGISDT)"
+12 DO ^DIR
KILL DIR
IF Y'>0
SET DGFL=$SELECT($DATA(DTOUT):-2,$DATA(DUOUT)!$DATA(DIRUT):-1,1:0)
if DGFL
GOTO ACTQ
GOTO READ
+13 SET DGACT=Y
ACTQ KILL DIRUT,DTOUT,DUOUT
+1 QUIT
RELTYPE(RELIEN,TYPE) ;* Return type of relationship
+1 ;
+2 ;* INPUT
+3 ; RELIEN - IEN from Income Person file (408.13)
+4 ; TYPE - 0: Pull specific relationship from Relationship file
+5 ; - 1: Just return "spouse", "child", "dependent"
+6 ;
+7 ;* OUTPUT
+8 ; DGPATREL - Relationship value
+9 ;
+10 NEW DGPTRLIN,DGRELIEN,DGPATREL
+11 SET TYPE=+$GET(TYPE)
+12 IF +$GET(RELIEN)>0
Begin DoDot:1
+13 SET DGPTRLIN=""
+14 SET DGPTRLIN=$ORDER(^DGPR(408.12,"C",RELIEN_";DGPR(408.13,",DGPTRLIN))
+15 SET DGRELIEN=$PIECE($GET(^DGPR(408.12,DGPTRLIN,0)),"^",2)
+16 SET DGPATREL=$PIECE($GET(^DG(408.11,DGRELIEN,0)),"^",1)
+17 if DGPATREL']""
SET DGPATREL="dependent"
+18 IF +TYPE=1
SET DGPATREL=$SELECT(DGPATREL["SPOUSE":"spouse",($GET(DGRPS)=8):"relative",$GET(DGSCR8):"relative",1:"child")
End DoDot:1
+19 IF +$GET(RELIEN)'>0
Begin DoDot:1
+20 if $GET(DGANS)="S"
SET DGPATREL="spouse"
+21 if $GET(DGANS)="C"
SET DGPATREL="child"
+22 if $GET(DGANS)="D"
SET DGPATREL="relative"
End DoDot:1
+23 if DGPATREL=""
SET DGPATREL="relative"
+24 QUIT DGPATREL
