IVMCM3 ;ALB/SEK - ADD NEW DCD DEPENDENT TO PATIENT RELATION FILE ; Jun 24, 2020@16:57
;;2.0;INCOME VERIFICATION MATCH;**17,101,195**;21-OCT-94;Build 1
;Per VA Directive 6402, this routine should not be modified
;
EN ; this routine will add entries for new dependents to PATIENT
; RELATION file-408.12 (including 408.1275) or will add new entries
; to effective date multiple (408.1275) for all DCD spouses and
; dependents. if only adding to 408.1275 and DCD relationship is
; different then VAMC relationship, change in 408.12 and add to
; MEANS TEST CHANGES file (408.41).
;
; input dfn ien of file #2
; dgipi 408.13 ien
; dgmti 408.31 ien
; dgpri 408.12 ien
; ivmeffdt effective (dependent) date of spouse/dependent
; ivmreln DCD relationship
; ivmrelo VAMC relationship
; ivmseg ZDP segment of spouse/dependent
;
;
I IVMFLG2 G NEWPR
;
; add new entry to 408.1275
;
N X,Y
K DINUM
S DA(1)=DGPRI
S (DIK,DIC)="^DGPR(408.12,DA(1),""E"",",DIC(0)="L",DLAYGO=408.1275,X=IVMEFFDT K DD,DO D FILE^DICN S DA=+Y K DLAYGO
;
; if can't create stub notify site & IVM Center
I DA'>0 D Q
.S (IVMTEXT(6))="Can't create stub for file 408.1275"
.D PROB^IVMCMC(IVMTEXT(6))
.D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
.S IVMFERR=""
;
;Set value of FILED BY IVM field : GTS - IVM*2*101
;DGFIVM is YES when source of Means Test is DCD or IVM
N DGFIVM ;IVM*2*101
S DGFIVM=$$SRCOFMT(DGMTI) ;IVM*2*101
;
L +^DGPR(408.12,+DGPRI):$G(DILOCKTM,3) S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=1_"^"_DGFIVM_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
K IVMEFFDT,DA,DIC,DIK
;
; replace relationship in 408.12 with DCD relationship if different
; and add both values to 408.41
;
Q:IVMRELN=IVMRELO
S DA=DGPRI,DIE="^DGPR(408.12,",DR=".02////^S X=IVMRELN" D ^DIE K DA,DIE,DR
S DGMTYPT=$S(IVMTYPE=3:"",1:IVMTYPE),DGMTACT="REL",DGMTSOLD=IVMRELO,DGMTSNEW=IVMRELN,DGDEPI=DGIPI
I IVMMTIEN S DGMTA=$G(^DGMT(408.31,IVMMTIEN,0))
S $P(DGMTA,"^",2)=DFN
D SET^DGMTAUD
K DGDEPI,DGMTA,DGMTACT,DGMTSNEW,DGMTSOLD
Q
;
NEWPR ;Add entry to file #408.12
;In - dgrp0nd 0 node of 408.12
; ivmeffdt effective date of dependent
; ivmreln DCD relationship
;Out - dgpri ien of new 408.12 entry
;
S DGRP0ND=DFN_"^"_IVMRELN_"^"_+DGIPI_";DGPR(408.13,"
;
N DGFIVM ;IVM*2*101
N X,Y
K DINUM
S (DIK,DIC)="^DGPR(408.12,",DIC(0)="L",DLAYGO=408.12,X=+DGRP0ND K DD,DO D FILE^DICN S (DGPRI,DA)=+Y K DLAYGO
;
; if can't create stub notify site & IVM Center
I DGPRI'>0 D Q
.S (IVMTEXT(6))="Can't create stub for file 408.12"
.D PROB^IVMCMC(IVMTEXT(6))
.D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
.S IVMFERR=""
;
;Set value of FILED BY IVM field : GTS - IVM*2*101
;DGFIVM is YES when source of Means Test is DCD or IVM
S DGFIVM=$$SRCOFMT(DGMTI)
;
;Create Patient Relation record : GTS - IVM*2*101 (DGFIVM replaces default of 1)
L +^DGPR(408.12,+DGPRI):$G(DILOCKTM,3) S ^DGPR(408.12,+DGPRI,0)=DGRP0ND,^DGPR(408.12,+DGPRI,"E",0)="^408.1275D^1^1",^(1,0)=IVMEFFDT_"^1^"_DGFIVM_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
K IVMEFFDT,DA,DIC,DIK
;
; to prevent the logic in IVMCM2 from matching a dependent sent from
; the IVM Center (with no 408.12 ien) with this dependent, an entry
; is made in array IVMAR. subscripts of this array is ien of 408.12
; transmitted by the IVM Center or created or found by upload.
S IVMAR(DGPRI)=""
Q
;
NEWVET ; if no entry in file #408.12 for vet add
N DGRPDOB,DA,DIC,DIK,X,Y
S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0))
I '$D(^DGPR(408.12,+DGPRI,0)) S DGRP0ND=DFN_"^"_1_"^"_DFN_";DPT(",DGRPDOB=$P($G(^DPT(+DFN,0)),"^",3) D
.K DINUM
.S (DIK,DIC)="^DGPR(408.12,",DIC(0)="L",DLAYGO=408.12,X=+DGRP0ND K DD,DO D FILE^DICN S (DGPRI,DA)=+Y K DLAYGO
.;
.; if can't create stub notify site & IVM Center
.I DGPRI'>0 D Q
..S (IVMTEXT(6))="Can't create stub for file 408.12"
..D PROB^IVMCMC(IVMTEXT(6))
..D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
..S IVMFERR=""
.L +^DGPR(408.12,+DGPRI):$G(DILOCKTM,3) S ^DGPR(408.12,+DGPRI,0)=DGRP0ND,^DGPR(408.12,+DGPRI,"E",0)="^408.1275D^1^1",^(1,0)=DGRPDOB_"^1^1"_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
;
Q
;
SRCOFMT(DGMTI) ;Define value of FILED BY IVM field : GTS - IVM*2*101
;
; Input: DGMTI - IEN for related Annual Means Test record (408.31)
; Output: DGFIVM - Null when Source of Means Test is Other Facility or VAMC
; - 1 when source of Means Test is all Non VA Facility sources
N DGFIVM
S:(+$G(DGMTI)'>0) DGFIVM=""
I +$G(DGMTI)>0 DO
. N DGSOURCE
. S DGSOURCE=$P($G(^DGMT(408.31,DGMTI,0)),"^",23)
. ;IVM*2.0*195 - Comment out original sets
. ;I (DGSOURCE=1)!(DGSOURCE=4) S DGFIVM=""
. ;I (DGSOURCE=2)!(DGSOURCE=3) S DGFIVM=1
. S DGFIVM=$S((DGSOURCE=1)!(DGSOURCE=4):"",1:1) ;IVM*2.0*195 - Set DGFIVM to null for VAMC or Other Facility, 1 for all other sources
Q DGFIVM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCM3 5130 printed Dec 13, 2024@02:01:15 Page 2
IVMCM3 ;ALB/SEK - ADD NEW DCD DEPENDENT TO PATIENT RELATION FILE ; Jun 24, 2020@16:57
+1 ;;2.0;INCOME VERIFICATION MATCH;**17,101,195**;21-OCT-94;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified
+3 ;
EN ; this routine will add entries for new dependents to PATIENT
+1 ; RELATION file-408.12 (including 408.1275) or will add new entries
+2 ; to effective date multiple (408.1275) for all DCD spouses and
+3 ; dependents. if only adding to 408.1275 and DCD relationship is
+4 ; different then VAMC relationship, change in 408.12 and add to
+5 ; MEANS TEST CHANGES file (408.41).
+6 ;
+7 ; input dfn ien of file #2
+8 ; dgipi 408.13 ien
+9 ; dgmti 408.31 ien
+10 ; dgpri 408.12 ien
+11 ; ivmeffdt effective (dependent) date of spouse/dependent
+12 ; ivmreln DCD relationship
+13 ; ivmrelo VAMC relationship
+14 ; ivmseg ZDP segment of spouse/dependent
+15 ;
+16 ;
+17 IF IVMFLG2
GOTO NEWPR
+18 ;
+19 ; add new entry to 408.1275
+20 ;
+21 NEW X,Y
+22 KILL DINUM
+23 SET DA(1)=DGPRI
+24 SET (DIK,DIC)="^DGPR(408.12,DA(1),""E"","
SET DIC(0)="L"
SET DLAYGO=408.1275
SET X=IVMEFFDT
KILL DD,DO
DO FILE^DICN
SET DA=+Y
KILL DLAYGO
+25 ;
+26 ; if can't create stub notify site & IVM Center
+27 IF DA'>0
Begin DoDot:1
+28 SET (IVMTEXT(6))="Can't create stub for file 408.1275"
+29 DO PROB^IVMCMC(IVMTEXT(6))
+30 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
+31 SET IVMFERR=""
End DoDot:1
QUIT
+32 ;
+33 ;Set value of FILED BY IVM field : GTS - IVM*2*101
+34 ;DGFIVM is YES when source of Means Test is DCD or IVM
+35 ;IVM*2*101
NEW DGFIVM
+36 ;IVM*2*101
SET DGFIVM=$$SRCOFMT(DGMTI)
+37 ;
+38 LOCK +^DGPR(408.12,+DGPRI):$GET(DILOCKTM,3)
SET $PIECE(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=1_"^"_DGFIVM_$SELECT(IVMTYPE=3:"",1:"^"_DGMTI)
DO IX1^DIK
LOCK -^DGPR(408.12,+DGPRI)
+39 KILL IVMEFFDT,DA,DIC,DIK
+40 ;
+41 ; replace relationship in 408.12 with DCD relationship if different
+42 ; and add both values to 408.41
+43 ;
+44 if IVMRELN=IVMRELO
QUIT
+45 SET DA=DGPRI
SET DIE="^DGPR(408.12,"
SET DR=".02////^S X=IVMRELN"
DO ^DIE
KILL DA,DIE,DR
+46 SET DGMTYPT=$SELECT(IVMTYPE=3:"",1:IVMTYPE)
SET DGMTACT="REL"
SET DGMTSOLD=IVMRELO
SET DGMTSNEW=IVMRELN
SET DGDEPI=DGIPI
+47 IF IVMMTIEN
SET DGMTA=$GET(^DGMT(408.31,IVMMTIEN,0))
+48 SET $PIECE(DGMTA,"^",2)=DFN
+49 DO SET^DGMTAUD
+50 KILL DGDEPI,DGMTA,DGMTACT,DGMTSNEW,DGMTSOLD
+51 QUIT
+52 ;
NEWPR ;Add entry to file #408.12
+1 ;In - dgrp0nd 0 node of 408.12
+2 ; ivmeffdt effective date of dependent
+3 ; ivmreln DCD relationship
+4 ;Out - dgpri ien of new 408.12 entry
+5 ;
+6 SET DGRP0ND=DFN_"^"_IVMRELN_"^"_+DGIPI_";DGPR(408.13,"
+7 ;
+8 ;IVM*2*101
NEW DGFIVM
+9 NEW X,Y
+10 KILL DINUM
+11 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,DA)=+Y
KILL DLAYGO
+12 ;
+13 ; if can't create stub notify site & IVM Center
+14 IF DGPRI'>0
Begin DoDot:1
+15 SET (IVMTEXT(6))="Can't create stub for file 408.12"
+16 DO PROB^IVMCMC(IVMTEXT(6))
+17 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
+18 SET IVMFERR=""
End DoDot:1
QUIT
+19 ;
+20 ;Set value of FILED BY IVM field : GTS - IVM*2*101
+21 ;DGFIVM is YES when source of Means Test is DCD or IVM
+22 SET DGFIVM=$$SRCOFMT(DGMTI)
+23 ;
+24 ;Create Patient Relation record : GTS - IVM*2*101 (DGFIVM replaces default of 1)
+25 LOCK +^DGPR(408.12,+DGPRI):$GET(DILOCKTM,3)
SET ^DGPR(408.12,+DGPRI,0)=DGRP0ND
SET ^DGPR(408.12,+DGPRI,"E",0)="^408.1275D^1^1"
SET ^(1,0)=IVMEFFDT_"^1^"_DGFIVM_$SELECT(IVMTYPE=3:"",1:"^"_DGMTI)
DO IX1^DIK
LOCK -^DGPR(408.12,+DGPRI)
+26 KILL IVMEFFDT,DA,DIC,DIK
+27 ;
+28 ; to prevent the logic in IVMCM2 from matching a dependent sent from
+29 ; the IVM Center (with no 408.12 ien) with this dependent, an entry
+30 ; is made in array IVMAR. subscripts of this array is ien of 408.12
+31 ; transmitted by the IVM Center or created or found by upload.
+32 SET IVMAR(DGPRI)=""
+33 QUIT
+34 ;
NEWVET ; if no entry in file #408.12 for vet add
+1 NEW DGRPDOB,DA,DIC,DIK,X,Y
+2 SET DGPRI=$ORDER(^DGPR(408.12,"C",DFN_";DPT(",0))
+3 IF '$DATA(^DGPR(408.12,+DGPRI,0))
SET DGRP0ND=DFN_"^"_1_"^"_DFN_";DPT("
SET DGRPDOB=$PIECE($GET(^DPT(+DFN,0)),"^",3)
Begin DoDot:1
+4 KILL DINUM
+5 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,DA)=+Y
KILL DLAYGO
+6 ;
+7 ; if can't create stub notify site & IVM Center
+8 IF DGPRI'>0
Begin DoDot:2
+9 SET (IVMTEXT(6))="Can't create stub for file 408.12"
+10 DO PROB^IVMCMC(IVMTEXT(6))
+11 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
+12 SET IVMFERR=""
End DoDot:2
QUIT
+13 LOCK +^DGPR(408.12,+DGPRI):$GET(DILOCKTM,3)
SET ^DGPR(408.12,+DGPRI,0)=DGRP0ND
SET ^DGPR(408.12,+DGPRI,"E",0)="^408.1275D^1^1"
SET ^(1,0)=DGRPDOB_"^1^1"_$SELECT(IVMTYPE=3:"",1:"^"_DGMTI)
DO IX1^DIK
LOCK -^DGPR(408.12,+DGPRI)
End DoDot:1
+14 ;
+15 QUIT
+16 ;
SRCOFMT(DGMTI) ;Define value of FILED BY IVM field : GTS - IVM*2*101
+1 ;
+2 ; Input: DGMTI - IEN for related Annual Means Test record (408.31)
+3 ; Output: DGFIVM - Null when Source of Means Test is Other Facility or VAMC
+4 ; - 1 when source of Means Test is all Non VA Facility sources
+5 NEW DGFIVM
+6 if (+$GET(DGMTI)'>0)
SET DGFIVM=""
+7 IF +$GET(DGMTI)>0
Begin DoDot:1
+8 NEW DGSOURCE
+9 SET DGSOURCE=$PIECE($GET(^DGMT(408.31,DGMTI,0)),"^",23)
+10 ;IVM*2.0*195 - Comment out original sets
+11 ;I (DGSOURCE=1)!(DGSOURCE=4) S DGFIVM=""
+12 ;I (DGSOURCE=2)!(DGSOURCE=3) S DGFIVM=1
+13 ;IVM*2.0*195 - Set DGFIVM to null for VAMC or Other Facility, 1 for all other sources
SET DGFIVM=$SELECT((DGSOURCE=1)!(DGSOURCE=4):"",1:1)
End DoDot:1
+14 QUIT DGFIVM
