IVMCM4 ;ALB/SEK,ERC - ADD DCD NEW INDIVIDUAL ANNUAL INCOME FILE ENTRIES ; 6/12/09 12:50pm
;;2.0;INCOME VERIFICATION MATCH;**17,115,139**;21-OCT-94;Build 3
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; this routine will add entries to INDIVIDUAL ANNUAL INCOME file
; (408.21)
;
; DFN Patient file IEN
; DGPRI Patient Relation IEN
; DGLY Last Year
; DGINI New Individual Annual Income IEN
; IVMSEG ZIC record for veteran or spouse or dependent
; IVMMTIEN Means Test IEN (#408.31)
; IVM0 408.21 0 node pieces 8-20
; IVM1 1 node pieces 1-3
; IVM2 2 node pieces 1-5
;
N IVM0,IVM1,IVM2,IVMC
S DGINI=$$ADDIN^DGMTU2(DFN,DGPRI,DGLY)
;
; if can't create stub notify site & IVM Center
I DGINI'>0 D Q
.S (IVMTEXT(6),HLERR)="Can't create stub for file 408.21"
.D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
.S IVMFERR=""
;
; if can't lock stub notify site & IVM Center
L +^DGMT(408.21,DGINI):10 E D Q
.S (IVMTEXT(6),HLERR)="Can't update stub for file 408.21"
.D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
.S IVMFERR=""
;
EN1 ; add 1 node for vet & child
; add 2 node for vet, spouse & (when VR 1) child
;
; - zero node:pieces 8-20
F IVMC=3:1:12 S:$P(IVMSEG,"^",IVMC)=HLQ $P(IVMSEG,"^",IVMC)=""
S IVM0=$P(IVMSEG,"^",3,12)
;
I IVMSPCHV'="S" F IVMC=13:1:15 S:$P(IVMSEG,"^",IVMC)=HLQ $P(IVMSEG,"^",IVMC)=""
I IVMSPCHV'="S" S IVM1=$P(IVMSEG,"^",13,15)
;IVM*2.0*115
S $P(^DGMT(408.21,DGINI,0),"^",8,20)=IVM0,DA=DGINI S:IVMSPCHV'="S" ^(1)=IVM1
N MTVERS
S MTVERS=$S(+$G(DGMTI):+$P($G(^DGMT(408.31,$G(DGMTI),2)),"^",11),1:0)
I +$G(MTVERS)=0 D
. I IVMSPCHV'="C" F IVMC=16:1:20 S:$P(IVMSEG,"^",IVMC)=HLQ $P(IVMSEG,"^",IVMC)=""
. I IVMSPCHV'="C" S IVM2=$P(IVMSEG,"^",16,20)
. S:IVMSPCHV'="C" ^DGMT(408.21,DGINI,2)=IVM2
E D
. F IVMC=16,18,19 S:$P(IVMSEG,"^",IVMC)=HLQ $P(IVMSEG,"^",IVMC)=""
. S IVM2=$P(IVMSEG,"^",16)_"^^"_$P(IVMSEG,"^",18,19)
. S ^DGMT(408.21,DGINI,2)=IVM2
S DIK="^DGMT(408.21,"
D IX1^DIK L -^DGMT(408.21,DGINI)
K DA,DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCM4 2140 printed Dec 13, 2024@02:01:16 Page 2
IVMCM4 ;ALB/SEK,ERC - ADD DCD NEW INDIVIDUAL ANNUAL INCOME FILE ENTRIES ; 6/12/09 12:50pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**17,115,139**;21-OCT-94;Build 3
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; this routine will add entries to INDIVIDUAL ANNUAL INCOME file
+1 ; (408.21)
+2 ;
+3 ; DFN Patient file IEN
+4 ; DGPRI Patient Relation IEN
+5 ; DGLY Last Year
+6 ; DGINI New Individual Annual Income IEN
+7 ; IVMSEG ZIC record for veteran or spouse or dependent
+8 ; IVMMTIEN Means Test IEN (#408.31)
+9 ; IVM0 408.21 0 node pieces 8-20
+10 ; IVM1 1 node pieces 1-3
+11 ; IVM2 2 node pieces 1-5
+12 ;
+13 NEW IVM0,IVM1,IVM2,IVMC
+14 SET DGINI=$$ADDIN^DGMTU2(DFN,DGPRI,DGLY)
+15 ;
+16 ; if can't create stub notify site & IVM Center
+17 IF DGINI'>0
Begin DoDot:1
+18 SET (IVMTEXT(6),HLERR)="Can't create stub for file 408.21"
+19 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
+20 SET IVMFERR=""
End DoDot:1
QUIT
+21 ;
+22 ; if can't lock stub notify site & IVM Center
+23 LOCK +^DGMT(408.21,DGINI):10
IF '$TEST
Begin DoDot:1
+24 SET (IVMTEXT(6),HLERR)="Can't update stub for file 408.21"
+25 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
+26 SET IVMFERR=""
End DoDot:1
QUIT
+27 ;
EN1 ; add 1 node for vet & child
+1 ; add 2 node for vet, spouse & (when VR 1) child
+2 ;
+3 ; - zero node:pieces 8-20
+4 FOR IVMC=3:1:12
if $PIECE(IVMSEG,"^",IVMC)=HLQ
SET $PIECE(IVMSEG,"^",IVMC)=""
+5 SET IVM0=$PIECE(IVMSEG,"^",3,12)
+6 ;
+7 IF IVMSPCHV'="S"
FOR IVMC=13:1:15
if $PIECE(IVMSEG,"^",IVMC)=HLQ
SET $PIECE(IVMSEG,"^",IVMC)=""
+8 IF IVMSPCHV'="S"
SET IVM1=$PIECE(IVMSEG,"^",13,15)
+9 ;IVM*2.0*115
+10 SET $PIECE(^DGMT(408.21,DGINI,0),"^",8,20)=IVM0
SET DA=DGINI
if IVMSPCHV'="S"
SET ^(1)=IVM1
+11 NEW MTVERS
+12 SET MTVERS=$SELECT(+$GET(DGMTI):+$PIECE($GET(^DGMT(408.31,$GET(DGMTI),2)),"^",11),1:0)
+13 IF +$GET(MTVERS)=0
Begin DoDot:1
+14 IF IVMSPCHV'="C"
FOR IVMC=16:1:20
if $PIECE(IVMSEG,"^",IVMC)=HLQ
SET $PIECE(IVMSEG,"^",IVMC)=""
+15 IF IVMSPCHV'="C"
SET IVM2=$PIECE(IVMSEG,"^",16,20)
+16 if IVMSPCHV'="C"
SET ^DGMT(408.21,DGINI,2)=IVM2
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 FOR IVMC=16,18,19
if $PIECE(IVMSEG,"^",IVMC)=HLQ
SET $PIECE(IVMSEG,"^",IVMC)=""
+19 SET IVM2=$PIECE(IVMSEG,"^",16)_"^^"_$PIECE(IVMSEG,"^",18,19)
+20 SET ^DGMT(408.21,DGINI,2)=IVM2
End DoDot:1
+21 SET DIK="^DGMT(408.21,"
+22 DO IX1^DIK
LOCK -^DGMT(408.21,DGINI)
+23 KILL DA,DIK
+24 QUIT
