IVMCM1 ;ALB/SEK,BRM,TDM,HM - DCD INCOME TESTS UPLOAD DRIVER ;1/14/20 6:44pm
;;2.0;INCOME VERIFICATION MATCH;**17,49,71,115,190**;21-OCT-94;Build 47
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; this routine will call routines to upload means/copay/LTC test and
; income screening sent by the IVM Center (DCD). the calling routine
; validated segment sequence. entries will be added/modified in the
; following means test and patient files:
;
; PATIENT RELATION (#408.12)
; INCOME PERSON (#408.13)
; INDIVIDUAL ANNUAL INCOME (#408.21)
; INCOME RELATION (#408.22)
; ANNUAL MEANS TEST (#408.31)
; MEANS TEST CHANGES (#408.41)
; PATIENT (#2)
;
; input:
;
; IVMTYPE test type 1-means 2-copay 3-income screening 4-LTC
; IVMMTIEN IEN of replaced test (408.31)
; IVMFLGC # of dependent children
; IVMMTDT dt of test
; DGLY income year
;
; ^TMP($J,"IVMCM", contains data sent by IVM Center
; 3rd node "PIDV"
; "ZICV"
; "ZIRV"
; "ZDPS"
; "ZICS"
; "ZIRS"
; {"ZDPC",N
; "ZICC",N
; "ZIRC",N
; }
; {"ZDPIS",N} Inactive Spouse Entries
; {"ZDPIC",N} Inactive Child Entries
; "ZMT1"
; "ZMT2"
; "ZMT4"
; "ZBT"
;
S:'$D(DUZ) DUZ=.5
;
; subscript of array IVMAR is 408.12 ien transmitted by IVM Center
; or created by upload. IVMAR2 is the array used to check for dup SSNs
K IVMAR,IVMAR2
;
; New Edit Checks
N IVMERR,OK2UPLD S IVMERR="",OK2UPLD=1
D EN^IVMCMF(.IVMERR),PROB^IVMCMFB(,.IVMERR,0) Q:'OK2UPLD
;
; IVMHADJ indicates means test hardship/adjudication
; 1-adj 2-hardship 3-pending adj 0-not adj/hard
I IVMTYPE=1 D
.S IVMSEG=$G(^TMP($J,"IVMCM","ZMT1"))
.S IVMHADJ=$S($P(IVMSEG,"^",13):2,$P(IVMSEG,"^",6)]"":1,$P(IVMSEG,"^",3)="P":3,1:0)
;
S:IVMTYPE=3 DGMTI=""
;
; add new annual means test file (408.31) stub for Means test,
; RX Copay test, or Long Term Care test
I "^1^2^4^"[("^"_IVMTYPE_"^") D
.;
.; input DGMTDT (.01) dt of test
.; DFN (.02) Patient IEN
.; DGMTYPT (.19) type of test
.; output DGMTI annual means test IEN
.S DGMTDT=IVMMTDT,DGMTYPT=IVMTYPE
.D ADD^DGMTA
.;
.; change primary income test for year?
.S DA=DGMTI,DIE="^DGMT(408.31,",DR="2////0"
.D ^DIE K DA,DIE,DR
;
D NEWVET^IVMCM3 Q:$D(IVMFERR) ; if no entry in patient relation file for vet add
;
; get patient relation ien (#408.12) for vet, spouse, & child
S IVMREQU=$P($G(^DG(408.32,+$P($G(^DGMT(408.31,IVMMTIEN,0)),"^",3),0)),"^",2)
D GETREL^DGMTU11(DFN,"VSC",DGLY,$S($G(IVMMTIEN)&(IVMREQU'="R"):IVMMTIEN,1:0))
;
; add dependent(s) to income person file (408.13)
;
; add spouse if not in 408.13
S IVMSPCHV="S" ; spouse/child/vet indicator
S IVMSEG=$G(^TMP($J,"IVMCM","ZDPS")) ; spouse ZDP segment
D INPIEN^IVMCM2
Q:$D(IVMFERR)
;
I IVMFLG5 G ADDCHILD ; entry not added - goto add children
;
; add entry to patient relation file (408.12)
D EN^IVMCM3
Q:$D(IVMFERR)
;
ADDS21 ; add spouse entry to individual annual income file (408.21)
S IVMSEG=$G(^TMP($J,"IVMCM","ZICS")) ; spouse ZIC segment
D EN^IVMCM4
Q:$D(IVMFERR)
;
; add spouse entry to income relation file (408.22)
S IVMSEG=$G(^TMP($J,"IVMCM","ZIRS")) ; spouse ZIR segment
D EN^IVMCM5
Q:$D(IVMFERR)
;
ADDCHILD ; add children if not in 408.13
S IVMSPCHV="C" ; spouse/child/vet indicator
I 'IVMFLGC G ADDV21 ; no dependent children
F IVMCTR3=1:1:IVMFLGC D Q:$D(IVMFERR)
.S IVMSEG=$G(^TMP($J,"IVMCM","ZDPC",IVMCTR3)) ; child ZDP segment
.D INPIEN^IVMCM2
.Q:$D(IVMFERR)
.;
.; add child entry to patient relation file (408.12)
.D EN^IVMCM3
.Q:$D(IVMFERR)
.;
ADDC21 .; add child entry to individual annual income file (408.21)
.S IVMSEG=$G(^TMP($J,"IVMCM","ZICC",IVMCTR3)) ; child ZIC segment
.D EN^IVMCM4
.Q:$D(IVMFERR)
.;
.; add entry to income relation file (408.22)
.S IVMSEG=$G(^TMP($J,"IVMCM","ZIRC",IVMCTR3)) ; child ZIR segment
.D EN^IVMCM5
.Q:$D(IVMFERR)
.Q
Q:$D(IVMFERR)
;
ADDV21 ; add vet entry to individual annual income file (408.21)
; get vet patient relation ien
S DGPRI=+$G(DGREL("V"))
S IVMSEG=$G(^TMP($J,"IVMCM","ZICV")) ; vet ZIC segment
S IVMSPCHV="V" ; spouse/child/vet indicator
D EN^IVMCM4
Q:$D(IVMFERR)
S DGVINI=DGINI ; vet individual annual income ien
;
; add vet entry to income relation file (408.22)
S IVMSEG=$G(^TMP($J,"IVMCM","ZIRV")) ; vet ZIR segment
D EN^IVMCM5
Q:$D(IVMFERR)
S DGVIRI=DGIRI ; vet income relation ien
;
ADDINACT ; Process inactive ZDP's (ZDPIS & ZDPID entries)
N ISEG,ICTR,IVMIDT,X,DA
F ISEG="ZDPIS","ZDPIC" D Q:$D(IVMFERR)
. S ICTR=0
. F S ICTR=$O(^TMP($J,"IVMCM",ISEG,ICTR)) Q:(ICTR="")!($D(IVMFERR)) D
. . S IVMSEG=$G(^TMP($J,"IVMCM",ISEG,ICTR)) Q:IVMSEG=""
. . S IVMIDT=+$P(IVMSEG,"^",11) ;dep inactivation date
. . I $L(IVMIDT)<8 D Q
. . . S IVMTEXT(6)="Invalid dependent inactivation date"
. . . D PROB^IVMCMC(IVMTEXT(6))
. . . D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
. . . S IVMFERR=""
. . S IVMIDT=$$FMDATE^HLFNC(IVMIDT)
. . D INPIEN^IVMCM2 Q:$D(IVMFERR) ;add if not in 408.13
. . I IVMFLG2 D NEWPR^IVMCM3 Q:$D(IVMFERR) ;add if not in 408.12
. . S X=IVMIDT ;inactivation date
. . S DA(1)=+DGPRI ;dependent 408.12 ien
. . D INACT1^IVMCM5 ;inactivate dependent
;
COMPLETE ; complete means test, copay test, or Long Term Care test
;
D EN^IVMCM6
;
; cleanup
K DGINI,DGIRI,DGMTDT,DGMTI,DGMTYPT,DGPRI,DGREL,DGVINI,DGVIRI
K IVMAR,IVMCEB,IVMCTR3,IVMFERR,IVMFLG1
K IVMFLG2,IVMFLG5,IVMHADJ,IVMMTB,IVMPRN
K IVMRELN,IVMRELO,IVMREQU,IVMSEG,IVMSPCHV,IVMX
Q
;
LTC ; transmission contains a long term care test (type 4)
;
Q:'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2)
I "^1^2^"[("^"_$G(IVMTYPE)_"^") N IVMTYPE
S IVMTYPE=4,IVMFUTR=0
S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2))
S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,25))
S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,22)
S SRCTST=$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,18) ;IVM*2.0*190
S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,4)
S IVMMTIEN=+IVMLAST ;last LTC test
;deletion indicator sent?
I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,3)=HLQ D Q
.Q:('IVMMTIEN)
.S NODE0=$G(^DGMT(408.31,IVMMTIEN,0))
.I $$EN^IVMCMD(IVMMTIEN) D
..S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
..S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"")
..D ADD^IVMCMB(DFN,IVMTYPE,"DELETE LONG TERM CARE TEST",+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE)
;
;check date/time last edited, test date and source - if they match current test then this is a duplicate and does not need to be uploaded
N NODE0,NODE2
S NODE2=$G(^DGMT(408.31,IVMMTIEN,2)),NODE0=$G(^(0))
I TMSTAMP,TMSTAMP=$P(NODE2,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE2,"^",5) Q
;
D DELTYPE^IVMCMD(DFN,IVMMTDT,4)
I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2)!($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2)) D Q
.S DGMTDT=IVMMTDT,DGMTYPT=IVMTYPE
.D ADD^DGMTA
.D COMPLETE^IVMCM1
D EN^IVMCM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMCM1 7359 printed Sep 11, 2024@02:21:15 Page 2
IVMCM1 ;ALB/SEK,BRM,TDM,HM - DCD INCOME TESTS UPLOAD DRIVER ;1/14/20 6:44pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**17,49,71,115,190**;21-OCT-94;Build 47
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; this routine will call routines to upload means/copay/LTC test and
+1 ; income screening sent by the IVM Center (DCD). the calling routine
+2 ; validated segment sequence. entries will be added/modified in the
+3 ; following means test and patient files:
+4 ;
+5 ; PATIENT RELATION (#408.12)
+6 ; INCOME PERSON (#408.13)
+7 ; INDIVIDUAL ANNUAL INCOME (#408.21)
+8 ; INCOME RELATION (#408.22)
+9 ; ANNUAL MEANS TEST (#408.31)
+10 ; MEANS TEST CHANGES (#408.41)
+11 ; PATIENT (#2)
+12 ;
+13 ; input:
+14 ;
+15 ; IVMTYPE test type 1-means 2-copay 3-income screening 4-LTC
+16 ; IVMMTIEN IEN of replaced test (408.31)
+17 ; IVMFLGC # of dependent children
+18 ; IVMMTDT dt of test
+19 ; DGLY income year
+20 ;
+21 ; ^TMP($J,"IVMCM", contains data sent by IVM Center
+22 ; 3rd node "PIDV"
+23 ; "ZICV"
+24 ; "ZIRV"
+25 ; "ZDPS"
+26 ; "ZICS"
+27 ; "ZIRS"
+28 ; {"ZDPC",N
+29 ; "ZICC",N
+30 ; "ZIRC",N
+31 ; }
+32 ; {"ZDPIS",N} Inactive Spouse Entries
+33 ; {"ZDPIC",N} Inactive Child Entries
+34 ; "ZMT1"
+35 ; "ZMT2"
+36 ; "ZMT4"
+37 ; "ZBT"
+38 ;
+39 if '$DATA(DUZ)
SET DUZ=.5
+40 ;
+41 ; subscript of array IVMAR is 408.12 ien transmitted by IVM Center
+42 ; or created by upload. IVMAR2 is the array used to check for dup SSNs
+43 KILL IVMAR,IVMAR2
+44 ;
+45 ; New Edit Checks
+46 NEW IVMERR,OK2UPLD
SET IVMERR=""
SET OK2UPLD=1
+47 DO EN^IVMCMF(.IVMERR)
DO PROB^IVMCMFB(,.IVMERR,0)
if 'OK2UPLD
QUIT
+48 ;
+49 ; IVMHADJ indicates means test hardship/adjudication
+50 ; 1-adj 2-hardship 3-pending adj 0-not adj/hard
+51 IF IVMTYPE=1
Begin DoDot:1
+52 SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZMT1"))
+53 SET IVMHADJ=$SELECT($PIECE(IVMSEG,"^",13):2,$PIECE(IVMSEG,"^",6)]"":1,$PIECE(IVMSEG,"^",3)="P":3,1:0)
End DoDot:1
+54 ;
+55 if IVMTYPE=3
SET DGMTI=""
+56 ;
+57 ; add new annual means test file (408.31) stub for Means test,
+58 ; RX Copay test, or Long Term Care test
+59 IF "^1^2^4^"[("^"_IVMTYPE_"^")
Begin DoDot:1
+60 ;
+61 ; input DGMTDT (.01) dt of test
+62 ; DFN (.02) Patient IEN
+63 ; DGMTYPT (.19) type of test
+64 ; output DGMTI annual means test IEN
+65 SET DGMTDT=IVMMTDT
SET DGMTYPT=IVMTYPE
+66 DO ADD^DGMTA
+67 ;
+68 ; change primary income test for year?
+69 SET DA=DGMTI
SET DIE="^DGMT(408.31,"
SET DR="2////0"
+70 DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+71 ;
+72 ; if no entry in patient relation file for vet add
DO NEWVET^IVMCM3
if $DATA(IVMFERR)
QUIT
+73 ;
+74 ; get patient relation ien (#408.12) for vet, spouse, & child
+75 SET IVMREQU=$PIECE($GET(^DG(408.32,+$PIECE($GET(^DGMT(408.31,IVMMTIEN,0)),"^",3),0)),"^",2)
+76 DO GETREL^DGMTU11(DFN,"VSC",DGLY,$SELECT($GET(IVMMTIEN)&(IVMREQU'="R"):IVMMTIEN,1:0))
+77 ;
+78 ; add dependent(s) to income person file (408.13)
+79 ;
+80 ; add spouse if not in 408.13
+81 ; spouse/child/vet indicator
SET IVMSPCHV="S"
+82 ; spouse ZDP segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZDPS"))
+83 DO INPIEN^IVMCM2
+84 if $DATA(IVMFERR)
QUIT
+85 ;
+86 ; entry not added - goto add children
IF IVMFLG5
GOTO ADDCHILD
+87 ;
+88 ; add entry to patient relation file (408.12)
+89 DO EN^IVMCM3
+90 if $DATA(IVMFERR)
QUIT
+91 ;
ADDS21 ; add spouse entry to individual annual income file (408.21)
+1 ; spouse ZIC segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZICS"))
+2 DO EN^IVMCM4
+3 if $DATA(IVMFERR)
QUIT
+4 ;
+5 ; add spouse entry to income relation file (408.22)
+6 ; spouse ZIR segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZIRS"))
+7 DO EN^IVMCM5
+8 if $DATA(IVMFERR)
QUIT
+9 ;
ADDCHILD ; add children if not in 408.13
+1 ; spouse/child/vet indicator
SET IVMSPCHV="C"
+2 ; no dependent children
IF 'IVMFLGC
GOTO ADDV21
+3 FOR IVMCTR3=1:1:IVMFLGC
Begin DoDot:1
+4 ; child ZDP segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZDPC",IVMCTR3))
+5 DO INPIEN^IVMCM2
+6 if $DATA(IVMFERR)
QUIT
+7 ;
+8 ; add child entry to patient relation file (408.12)
+9 DO EN^IVMCM3
+10 if $DATA(IVMFERR)
QUIT
+11 ;
ADDC21 ; add child entry to individual annual income file (408.21)
+1 ; child ZIC segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZICC",IVMCTR3))
+2 DO EN^IVMCM4
+3 if $DATA(IVMFERR)
QUIT
+4 ;
+5 ; add entry to income relation file (408.22)
+6 ; child ZIR segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZIRC",IVMCTR3))
+7 DO EN^IVMCM5
+8 if $DATA(IVMFERR)
QUIT
+9 QUIT
End DoDot:1
if $DATA(IVMFERR)
QUIT
+10 if $DATA(IVMFERR)
QUIT
+11 ;
ADDV21 ; add vet entry to individual annual income file (408.21)
+1 ; get vet patient relation ien
+2 SET DGPRI=+$GET(DGREL("V"))
+3 ; vet ZIC segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZICV"))
+4 ; spouse/child/vet indicator
SET IVMSPCHV="V"
+5 DO EN^IVMCM4
+6 if $DATA(IVMFERR)
QUIT
+7 ; vet individual annual income ien
SET DGVINI=DGINI
+8 ;
+9 ; add vet entry to income relation file (408.22)
+10 ; vet ZIR segment
SET IVMSEG=$GET(^TMP($JOB,"IVMCM","ZIRV"))
+11 DO EN^IVMCM5
+12 if $DATA(IVMFERR)
QUIT
+13 ; vet income relation ien
SET DGVIRI=DGIRI
+14 ;
ADDINACT ; Process inactive ZDP's (ZDPIS & ZDPID entries)
+1 NEW ISEG,ICTR,IVMIDT,X,DA
+2 FOR ISEG="ZDPIS","ZDPIC"
Begin DoDot:1
+3 SET ICTR=0
+4 FOR
SET ICTR=$ORDER(^TMP($JOB,"IVMCM",ISEG,ICTR))
if (ICTR="")!($DATA(IVMFERR))
QUIT
Begin DoDot:2
+5 SET IVMSEG=$GET(^TMP($JOB,"IVMCM",ISEG,ICTR))
if IVMSEG=""
QUIT
+6 ;dep inactivation date
SET IVMIDT=+$PIECE(IVMSEG,"^",11)
+7 IF $LENGTH(IVMIDT)<8
Begin DoDot:3
+8 SET IVMTEXT(6)="Invalid dependent inactivation date"
+9 DO PROB^IVMCMC(IVMTEXT(6))
+10 DO ERRBULL^IVMPREC7
DO MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
+11 SET IVMFERR=""
End DoDot:3
QUIT
+12 SET IVMIDT=$$FMDATE^HLFNC(IVMIDT)
+13 ;add if not in 408.13
DO INPIEN^IVMCM2
if $DATA(IVMFERR)
QUIT
+14 ;add if not in 408.12
IF IVMFLG2
DO NEWPR^IVMCM3
if $DATA(IVMFERR)
QUIT
+15 ;inactivation date
SET X=IVMIDT
+16 ;dependent 408.12 ien
SET DA(1)=+DGPRI
+17 ;inactivate dependent
DO INACT1^IVMCM5
End DoDot:2
End DoDot:1
if $DATA(IVMFERR)
QUIT
+18 ;
COMPLETE ; complete means test, copay test, or Long Term Care test
+1 ;
+2 DO EN^IVMCM6
+3 ;
+4 ; cleanup
+5 KILL DGINI,DGIRI,DGMTDT,DGMTI,DGMTYPT,DGPRI,DGREL,DGVINI,DGVIRI
+6 KILL IVMAR,IVMCEB,IVMCTR3,IVMFERR,IVMFLG1
+7 KILL IVMFLG2,IVMFLG5,IVMHADJ,IVMMTB,IVMPRN
+8 KILL IVMRELN,IVMRELO,IVMREQU,IVMSEG,IVMSPCHV,IVMX
+9 QUIT
+10 ;
LTC ; transmission contains a long term care test (type 4)
+1 ;
+2 if '$PIECE($GET(^TMP($JOB,"IVMCM","ZMT4")),HLFS,2)
QUIT
+3 IF "^1^2^"[("^"_$GET(IVMTYPE)_"^")
NEW IVMTYPE
+4 SET IVMTYPE=4
SET IVMFUTR=0
+5 SET IVMMTDT=$$FMDATE^HLFNC($PIECE($GET(^TMP($JOB,"IVMCM","ZMT4")),HLFS,2))
+6 SET TMSTAMP=$$FMDATE^HLFNC($PIECE($GET(^TMP($JOB,"IVMCM","ZMT4")),HLFS,25))
+7 SET SOURCE=$PIECE($GET(^TMP($JOB,"IVMCM","ZMT4")),HLFS,22)
+8 ;IVM*2.0*190
SET SRCTST=$PIECE($GET(^TMP($JOB,"IVMCM","ZMT4")),HLFS,18)
+9 SET IVMLAST=$$LST^DGMTU(DFN,$EXTRACT(IVMMTDT,1,3)_1231,4)
+10 ;last LTC test
SET IVMMTIEN=+IVMLAST
+11 ;deletion indicator sent?
+12 IF $PIECE($GET(^TMP($JOB,"IVMCM","ZMT4")),HLFS,3)=HLQ
Begin DoDot:1
+13 if ('IVMMTIEN)
QUIT
+14 SET NODE0=$GET(^DGMT(408.31,IVMMTIEN,0))
+15 IF $$EN^IVMCMD(IVMMTIEN)
Begin DoDot:2
+16 SET RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
+17 SET CODE=$SELECT(($EXTRACT($PIECE(RET,"^",2),1,3)=$EXTRACT(DT,1,3)):$PIECE(RET,"^",4),1:"")
+18 DO ADD^IVMCMB(DFN,IVMTYPE,"DELETE LONG TERM CARE TEST",+$GET(NODE0),$$GETCODE^DGMTH($PIECE(NODE0,"^",3)),CODE)
End DoDot:2
End DoDot:1
QUIT
+19 ;
+20 ;check date/time last edited, test date and source - if they match current test then this is a duplicate and does not need to be uploaded
+21 NEW NODE0,NODE2
+22 SET NODE2=$GET(^DGMT(408.31,IVMMTIEN,2))
SET NODE0=$GET(^(0))
+23 IF TMSTAMP
IF TMSTAMP=$PIECE(NODE2,"^",2)
IF IVMMTDT=$PIECE(NODE0,"^")
IF SOURCE=$PIECE(NODE2,"^",5)
QUIT
+24 ;
+25 DO DELTYPE^IVMCMD(DFN,IVMMTDT,4)
+26 IF $PIECE($GET(^TMP($JOB,"IVMCM","ZMT1")),HLFS,2)!($PIECE($GET(^TMP($JOB,"IVMCM","ZMT2")),HLFS,2))
Begin DoDot:1
+27 SET DGMTDT=IVMMTDT
SET DGMTYPT=IVMTYPE
+28 DO ADD^DGMTA
+29 DO COMPLETE^IVMCM1
End DoDot:1
QUIT
+30 DO EN^IVMCM1
+31 QUIT
