DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD,BDB,HM,DSB - Check Means Test Requirements;7/8/05 2:30pm ; 18 Jan 2020 12:52 PM
;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,773,840,841,858,972,993**;Aug 13, 1993;Build 92
;A patient requires a means test under the following conditions:
; - Primary Eligibility is NSC OR patient is SC 0% non-compensable
; - who is NOT receiving disability retirement from the military
; - who is NOT eligible for medicaid
; - who is NOT on a DOM ward
; - who has NOT been means tested in the past year
; - who is NOT a Purple Heart recipient
; - who is NOT Catastrophically Disabled
; - who is NOT Medal of Honor recipient
; - who is NOT Registration only
;
; Input -- DFN Patient IEN
; DGADDF Means Test Add Flag (Optional- default none)
; (1 if using the 'Add a New Means Test' option)
; DGMSGF Means Test Msg Flag (Optional- default none)
; (1 to suppress messages)
; DGNOIVMUPD No IVM Update Flag (Optional - default allow)
; (1 if updating of an IVM test is not allowed)
; Output -- DGREQF Means Test Require Flag
; (1 if required and 0 if not required)
; DGDOM1 DOM Patient Flag (defined and set to 1 if
; patient currently on a DOM ward)
; DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
; used in CP^DG10. Killed there as well.
; If NOT using the 'Add a New Means Test' option,
; a REQUIRED date of test will be added for the
; patient if it is required.
; If a means test is required and the current
; status is NO LONGER REQUIRED, the last date of
; test and current means test status will be
; updated to REQUIRED unless the DGNOIVMUPD flag is set to 1
; and the current primary means test is an IVM test.
; If a means test is no longer required the
; last date of test and the current means test
; status will also be updated to NO LONGER REQUIRED unless
; the DGNOIVMUPD flag is set to 1 and the current primary
; means test is an IVM test.
EN N DGCS,DGDOM,DGMT0,DGMTI,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMTLTD,DGMDOD,DGMTDT
;DG*5.3*146 change to exit if during patient merge process
Q:$G(VAFCA08)=1
;DGMTCOR is needed if uploading copay test
I $G(RXPRIME)'="DGMTU4" N DGMTCOR
S (DGQSENT,DGREQF)=0,(OLD,DGMTYPT)=1
I $D(^DPT(DFN,.36)) S X=^(.36) D
. I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DFN)) S DGREQF=1
. I $P(X,"^",12)=1 S DGREQF=0 ;new field, DG 672
. I $P(X,"^",13)=1 S DGREQF=0 ;new field, DG 672
S (DGMTI,DGMT0)="",DGMTI=+$$LST^DGMTU(DFN)
S:DGMTI DGMT0=$G(^DGMT(408.31,DGMTI,0))
;Added with DG*5.3*344
S:DGMTI DGMTDT=$P(DGMT0,U)
S DGMDOD=$P($G(^DPT(DFN,.35)),U)
I 'DGMTI,$G(DGMDOD) D EN^DGMTCOR S DGREQF=0 Q
I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
I DGREQF D DOM S:$G(DGDOM) DGREQF=0
S DGCS=$P(DGMT0,"^",3)
S DGMTLTD=+DGMT0,DGNOCOPF=0
I +$G(DGMDOD) S DGNOCOPF=1
;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
I DGCS S OLD=$$OLDMTPF^DGMTU4(+DGMT0)
;Purple Heart Recipient ;brm 10/02/00 added 1 line below
I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
;Catastrophically disabled
I $P($G(^DPT(DFN,.39)),U,6)="Y" S DGREQF=0 ;DG*5.3*840
;Medal of Honor DG*5.3*840. Functionality removed with DG*5.3*841
I $P($G(^DPT(DFN,.54)),U)="Y" S DGREQF=0 ;Line uncommented so if MOH ="Y", update Means Test to No Longer Required - DG*5.3*972 HM
;Begin DG*5.3*993 Means test Not required for Registration only
I ($G(DGENRYN)=0) S DGREQF=0
I '$D(DGENRYN)!($G(DGENRYN)="") N STATUS S STATUS=$$STATUS^DGENA($G(DFN)) I STATUS=25 S DGREQF=0
;End DG*5.3*993
D
.;DG*5.3*858 for 1 yr old nol means tests, if not nol, set a mt required stub
.I DGREQF,DGCS=3,$$OLD^DGMTU4(+DGMT0) D ADD Q
.I DGREQF,DGCS=3,'$$OLD^DGMTU4(+DGMT0) D REQ Q
.I DGREQF,'$G(DGADDF),((DGCS=6)!(DGCS=2)),$P(DGMT0,U,11)=1,DGMTLTD>2991005 S DGREQF=0,DGNOCOPF=1 Q
.; next line added 2/19/02 - DG*5.3*426
.I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q
.I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q
.I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q
;be sure to check whether or not patient is subject to RX copay!
D EN^DGMTCOR
Q
;Check if patient is in a DOM
; call to DOM checks if patient currently on a DOM ward
; (called from EN)
; call to DOM1 checks if patient on a DOM ward for a specific date
; before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
; S VAINDT=specific date
; S DFN=Patient IEN
; output - DGDOM & DGDOM1 (defined and set to 1 if
; patient on a DOM ward for specific date)
DOM N VAINDT,VADMVT
DOM1 D ADM^VADPT2
I VADMVT,$P($G(^DG(43,1,0)),"^",21),$D(^DIC(42,+$P($G(^DGPM(VADMVT,0)),"^",6),0)),$P(^(0),"^",3)="D" S (DGDOM,DGDOM1)=1
Q
SC(DFN) ;Check if patient is SC 0% non-compensable
; Input -- DFN Patient IEN
; Output -- 1=Yes and 0=No
; No if:
; No total annual VA check amount
; POW STATUS INDICATOR is yes
; Secondary Eligibility is one of the following:
; A&A, NSC, VA PENSION
; HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
N DG,DGE,DGF,Y
S Y=0
;Primary eligibility is SC LESS THAN 50%
I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
G:'Y SCQ
;Service connected percentage is 0
I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
;No Total annual VA check amount
I $P($G(^DPT(DFN,.362)),"^",20) S Y=0 G SCQ
;POW STATUS INDICATOR
I $P($G(^DPT(DFN,.52)),"^",5)="Y" S Y=0 G SCQ
;Purple Heart Indicator
I $P($G(^DPT(DFN,.53)),"^")="Y" S Y=0 G SCQ
;Begin DG*5.3*993 Means test Not required for Registration only
I ($G(DGENRYN)=0) S Y=0 G SCQ
I '$D(DGENRYN)!($G(DGENRYN)="") D
. S STATUS=$$STATUS^DGENA($G(DFN)) I STATUS=25 S Y=0 G SCQ
;End DG*5.3*993
;Secondary Eligibility
F DG=2,4,15:1:18 S DGE(DG)=""
S DG=0 F S DG=$O(^DPT(DFN,"E","B",DG)) Q:'DG D SELIG I DGF,$D(DGE(+DGF)) S Y=0 Q
SCQ Q +$G(Y)
ADD ;Add a required means test
N DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
W:'$G(DGMSGF) !,"MEANS TEST REQUIRED"
S DGMTACT="ADD" D PRIOR^DGMTEVT
S DGMTDT=DT D ADD^DGMTA
I DGMTI>0 S DGMTYPT=1 D
.N DATA S DATA(.03)=$$GETSTAT^DGMTH("R",1) I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
.D GETINCOM^DGMTU4(DFN,DT)
.D QUE
I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
Q
REQ ;Update means test status to REQUIRED
N DGMTA,AUTOCOMP,DGMTE,ERROR
;may have set prior MT for means test upload
I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
S AUTOCOMP=$$AUTOCOMP(DGMTI)
;if a test were auto-completed, don't want another being added inadvertently
I AUTOCOMP,$G(DGADDF) S DGADDF=0
I AUTOCOMP S DGCS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
I $G(IVMZ10)'="UPLOAD IN PROGRESS",'AUTOCOMP,'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
I ('AUTOCOMP),('$G(DGMSGF)) W !,"MEANS TEST REQUIRED"
I (AUTOCOMP),('$G(DGMSGF)) W !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
S DGMTYPT=1
D QUE
Q
AUTOCOMP(DGMTI) ;
;Will either automatically complete the test (RX copay or means test)
;based on the Test Determined Status, or will change the status to
;Required for means tests or Incomplete for Rx copay tests
;Input:
; DGMTI - the ien of the test
;Output:
; Function value - 1 if the test was completed, 0 otherwise
N NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
S RET=0
Q:'$G(DGMTI) RET
S NODE0=$G(^DGMT(408.31,DGMTI,0))
Q:(NODE0="") RET
S TYPE=$P(NODE0,"^",19)
S DFN=$P(NODE0,"^",2)
S TDATE=+NODE0
S NODE2=$G(^DGMT(408.31,DGMTI,2))
;get test-determined status code
S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
;if means test
I TYPE=1 D
.S DATA(.03)=$$GETSTAT^DGMTH("R",1),DATA(.17)=""
.I (CODE'=""),"ACGP"[CODE D
..S RET=1
..S DATA(.03)=$P(NODE2,"^",3)
..;determine status if there is a hardship
..I $P(NODE0,"^",20) D
...S DATA(.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="C"&($P(NODE0,U,27)>$P(NODE0,U,12)):"G",1:"A"),1)
.I (CODE="")!(CODE'=""&"ACGP"'[CODE) D
..; Check for another test in the current year and convert IAI records, if needed
..S CONVRT=$$VRCHKUP^DGMTU2(1,,TDATE)
..S DATA(2.11)=1
;RX copay test
I TYPE=2 D
.S DATA(.03)=$$GETSTAT^DGMTH("I",2),DATA(.17)=""
.I (CODE'=""),"EM"[CODE D
..S RET=1
..S DATA(.03)=$P(NODE2,"^",3)
.I (CODE="")!(CODE'=""&"EM"'[CODE) D
..; Check for another test in the current year and convert IAI records, if needed
..S CONVRT=$$VRCHKUP^DGMTU2(2,,TDATE)
..S DATA(2.11)=1
I '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR) W:'$G(DGMSGF) ERROR
;restore the pointers from the Income Relation file (408.22) to this
;test, using the linked test
S LINKIEN=$P(NODE2,"^",6)
I LINKIEN D
.S DGINI=0 F S DGINI=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI)) Q:'DGINI S DGINR=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
..K DATA
..S DATA(31)=DGMTI
..I $$UPD^DGENDBS(408.22,+DGINR,.DATA)
D GETINCOM^DGMTU4(DFN,TDATE)
Q RET
NOL ;Update means test status to NO LONGER REQUIRED
N DGMTA,DGINI,DGINR,DGMTDT,DATA
I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D G NOLQ ; Check for converted IVM MT
. ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM MEANS TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER REQUIRED'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
. S DGNOIVMUPD=2 ; Prevent double printing of the message
W:'$G(DGMSGF) !,"MEANS TEST NO LONGER REQUIRED"
;may have set prior MT for means test upload
I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
;save the Test Determined Status
D SAVESTAT^DGMTU4(DGMTI)
S DATA(.03)=3,DATA(.17)=DT I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
D QUE
;create a Rx copay test based on MT if needed
D COPYRX^DGMTR1(DFN,DGMTI)
NOLQ Q
SET ;Set Cross-reference
N D0,DA,DIV,DGIX,X
S DA=DGIEN,X=DGVAL,DGIX=0
F S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,1) S X=DGVAL
Q
KILL ;Kill Cross-reference
N D0,DA,DIV,DGIX,X
S DA=DGIEN,X=DGVAL,DGIX=0
F S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,2) S X=DGVAL
Q
QUE ;Queue means test event driver
D AFTER^DGMTEVT
S ZTDESC="MEANS TEST EVENT DRIVER",ZTDTH=$H,ZTRTN="EN^DGMTEVT"
F I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT" S ZTSAVE(I)=""
S ZTSAVE("DGMTINF")=1
I $D(IVMZ10) S ZTSAVE("IVMZ10")=""
I $D(DGENUPLD) S ZTSAVE("DGENUPLD")=""
S ZTIO="" D ^%ZTLOAD
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
;CODE file (#8.1)
N DGTXT
S DGF=$G(^DIC(8,+DG,0)) I DGF="" D Q
.S DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
.S DGTXT(5)="the ELIGIBILITY CODE file (#8)"
.D MAIL^DGMTR1
.Q
S DGF=$P(DGF,"^",9) I DGF=""!('$D(^DIC(8.1,+DGF,0))) D
.S DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
.S DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
.D MAIL^DGMTR1
.S DGF=""
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTR 11810 printed Oct 16, 2024@18:45:50 Page 2
DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD,BDB,HM,DSB - Check Means Test Requirements;7/8/05 2:30pm ; 18 Jan 2020 12:52 PM
+1 ;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,773,840,841,858,972,993**;Aug 13, 1993;Build 92
+2 ;A patient requires a means test under the following conditions:
+3 ; - Primary Eligibility is NSC OR patient is SC 0% non-compensable
+4 ; - who is NOT receiving disability retirement from the military
+5 ; - who is NOT eligible for medicaid
+6 ; - who is NOT on a DOM ward
+7 ; - who has NOT been means tested in the past year
+8 ; - who is NOT a Purple Heart recipient
+9 ; - who is NOT Catastrophically Disabled
+10 ; - who is NOT Medal of Honor recipient
+11 ; - who is NOT Registration only
+12 ;
+13 ; Input -- DFN Patient IEN
+14 ; DGADDF Means Test Add Flag (Optional- default none)
+15 ; (1 if using the 'Add a New Means Test' option)
+16 ; DGMSGF Means Test Msg Flag (Optional- default none)
+17 ; (1 to suppress messages)
+18 ; DGNOIVMUPD No IVM Update Flag (Optional - default allow)
+19 ; (1 if updating of an IVM test is not allowed)
+20 ; Output -- DGREQF Means Test Require Flag
+21 ; (1 if required and 0 if not required)
+22 ; DGDOM1 DOM Patient Flag (defined and set to 1 if
+23 ; patient currently on a DOM ward)
+24 ; DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
+25 ; used in CP^DG10. Killed there as well.
+26 ; If NOT using the 'Add a New Means Test' option,
+27 ; a REQUIRED date of test will be added for the
+28 ; patient if it is required.
+29 ; If a means test is required and the current
+30 ; status is NO LONGER REQUIRED, the last date of
+31 ; test and current means test status will be
+32 ; updated to REQUIRED unless the DGNOIVMUPD flag is set to 1
+33 ; and the current primary means test is an IVM test.
+34 ; If a means test is no longer required the
+35 ; last date of test and the current means test
+36 ; status will also be updated to NO LONGER REQUIRED unless
+37 ; the DGNOIVMUPD flag is set to 1 and the current primary
+38 ; means test is an IVM test.
EN NEW DGCS,DGDOM,DGMT0,DGMTI,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMTLTD,DGMDOD,DGMTDT
+1 ;DG*5.3*146 change to exit if during patient merge process
+2 if $GET(VAFCA08)=1
QUIT
+3 ;DGMTCOR is needed if uploading copay test
+4 IF $GET(RXPRIME)'="DGMTU4"
NEW DGMTCOR
+5 SET (DGQSENT,DGREQF)=0
SET (OLD,DGMTYPT)=1
+6 IF $DATA(^DPT(DFN,.36))
SET X=^(.36)
Begin DoDot:1
+7 IF $PIECE($GET(^DIC(8,+X,0)),"^",9)=5!($$SC(DFN))
SET DGREQF=1
+8 ;new field, DG 672
IF $PIECE(X,"^",12)=1
SET DGREQF=0
+9 ;new field, DG 672
IF $PIECE(X,"^",13)=1
SET DGREQF=0
End DoDot:1
+10 SET (DGMTI,DGMT0)=""
SET DGMTI=+$$LST^DGMTU(DFN)
+11 if DGMTI
SET DGMT0=$GET(^DGMT(408.31,DGMTI,0))
+12 ;Added with DG*5.3*344
+13 if DGMTI
SET DGMTDT=$PIECE(DGMT0,U)
+14 SET DGMDOD=$PIECE($GET(^DPT(DFN,.35)),U)
+15 IF 'DGMTI
IF $GET(DGMDOD)
DO EN^DGMTCOR
SET DGREQF=0
QUIT
+16 IF DGREQF
if $GET(^DPT(DFN,.38))
SET DGREQF=0
+17 IF DGREQF
DO DOM
if $GET(DGDOM)
SET DGREQF=0
+18 SET DGCS=$PIECE(DGMT0,"^",3)
+19 SET DGMTLTD=+DGMT0
SET DGNOCOPF=0
+20 IF +$GET(DGMDOD)
SET DGNOCOPF=1
+21 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
+22 IF DGCS
SET OLD=$$OLDMTPF^DGMTU4(+DGMT0)
+23 ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
+24 IF $PIECE($GET(^DPT(DFN,.53)),U)="Y"
SET DGREQF=0
+25 ;Catastrophically disabled
+26 ;DG*5.3*840
IF $PIECE($GET(^DPT(DFN,.39)),U,6)="Y"
SET DGREQF=0
+27 ;Medal of Honor DG*5.3*840. Functionality removed with DG*5.3*841
+28 ;Line uncommented so if MOH ="Y", update Means Test to No Longer Required - DG*5.3*972 HM
IF $PIECE($GET(^DPT(DFN,.54)),U)="Y"
SET DGREQF=0
+29 ;Begin DG*5.3*993 Means test Not required for Registration only
+30 IF ($GET(DGENRYN)=0)
SET DGREQF=0
+31 IF '$DATA(DGENRYN)!($GET(DGENRYN)="")
NEW STATUS
SET STATUS=$$STATUS^DGENA($GET(DFN))
IF STATUS=25
SET DGREQF=0
+32 ;End DG*5.3*993
+33 Begin DoDot:1
+34 ;DG*5.3*858 for 1 yr old nol means tests, if not nol, set a mt required stub
+35 IF DGREQF
IF DGCS=3
IF $$OLD^DGMTU4(+DGMT0)
DO ADD
QUIT
+36 IF DGREQF
IF DGCS=3
IF '$$OLD^DGMTU4(+DGMT0)
DO REQ
QUIT
+37 IF DGREQF
IF '$GET(DGADDF)
IF ((DGCS=6)!(DGCS=2))
IF $PIECE(DGMT0,U,11)=1
IF DGMTLTD>2991005
SET DGREQF=0
SET DGNOCOPF=1
QUIT
+38 ; next line added 2/19/02 - DG*5.3*426
+39 IF DGREQF
IF '$GET(DGADDF)
IF $GET(DGCS)=6
IF +$PIECE(DGMT0,U,14)
IF +$PIECE(DGMT0,U,11)
SET DGREQF=0
SET DGNOCOPF=1
QUIT
+40 IF DGREQF
IF '$GET(DGADDF)
IF (('DGCS)!(OLD))
IF '$GET(DGMDOD)
DO ADD
QUIT
+41 IF 'DGREQF
IF DGCS
IF DGCS'=3
IF '$GET(DGDOM)
IF '$GET(DGMDOD)
IF '+$GET(IVMZ10F)
DO NOL
QUIT
End DoDot:1
+42 ;be sure to check whether or not patient is subject to RX copay!
+43 DO EN^DGMTCOR
+44 QUIT
+45 ;Check if patient is in a DOM
+46 ; call to DOM checks if patient currently on a DOM ward
+47 ; (called from EN)
+48 ; call to DOM1 checks if patient on a DOM ward for a specific date
+49 ; before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
+50 ; S VAINDT=specific date
+51 ; S DFN=Patient IEN
+52 ; output - DGDOM & DGDOM1 (defined and set to 1 if
+53 ; patient on a DOM ward for specific date)
DOM NEW VAINDT,VADMVT
DOM1 DO ADM^VADPT2
+1 IF VADMVT
IF $PIECE($GET(^DG(43,1,0)),"^",21)
IF $DATA(^DIC(42,+$PIECE($GET(^DGPM(VADMVT,0)),"^",6),0))
IF $PIECE(^(0),"^",3)="D"
SET (DGDOM,DGDOM1)=1
+2 QUIT
SC(DFN) ;Check if patient is SC 0% non-compensable
+1 ; Input -- DFN Patient IEN
+2 ; Output -- 1=Yes and 0=No
+3 ; No if:
+4 ; No total annual VA check amount
+5 ; POW STATUS INDICATOR is yes
+6 ; Secondary Eligibility is one of the following:
+7 ; A&A, NSC, VA PENSION
+8 ; HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
+9 NEW DG,DGE,DGF,Y
+10 SET Y=0
+11 ;Primary eligibility is SC LESS THAN 50%
+12 IF $DATA(^DPT(DFN,.36))
IF $PIECE($GET(^DIC(8,+^(.36),0)),"^",9)=3
SET Y=1
+13 if 'Y
GOTO SCQ
+14 ;Service connected percentage is 0
+15 IF $PIECE($GET(^DPT(DFN,.3)),"^",2)'=0
SET Y=0
GOTO SCQ
+16 ;No Total annual VA check amount
+17 IF $PIECE($GET(^DPT(DFN,.362)),"^",20)
SET Y=0
GOTO SCQ
+18 ;POW STATUS INDICATOR
+19 IF $PIECE($GET(^DPT(DFN,.52)),"^",5)="Y"
SET Y=0
GOTO SCQ
+20 ;Purple Heart Indicator
+21 IF $PIECE($GET(^DPT(DFN,.53)),"^")="Y"
SET Y=0
GOTO SCQ
+22 ;Begin DG*5.3*993 Means test Not required for Registration only
+23 IF ($GET(DGENRYN)=0)
SET Y=0
GOTO SCQ
+24 IF '$DATA(DGENRYN)!($GET(DGENRYN)="")
Begin DoDot:1
+25 SET STATUS=$$STATUS^DGENA($GET(DFN))
IF STATUS=25
SET Y=0
GOTO SCQ
End DoDot:1
+26 ;End DG*5.3*993
+27 ;Secondary Eligibility
+28 FOR DG=2,4,15:1:18
SET DGE(DG)=""
+29 SET DG=0
FOR
SET DG=$ORDER(^DPT(DFN,"E","B",DG))
if 'DG
QUIT
DO SELIG
IF DGF
IF $DATA(DGE(+DGF))
SET Y=0
QUIT
SCQ QUIT +$GET(Y)
ADD ;Add a required means test
+1 NEW DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
+2 if '$GET(DGMSGF)
WRITE !,"MEANS TEST REQUIRED"
+3 SET DGMTACT="ADD"
DO PRIOR^DGMTEVT
+4 SET DGMTDT=DT
DO ADD^DGMTA
+5 IF DGMTI>0
SET DGMTYPT=1
Begin DoDot:1
+6 NEW DATA
SET DATA(.03)=$$GETSTAT^DGMTH("R",1)
IF $$UPD^DGENDBS(408.31,DGMTI,.DATA)
+7 DO GETINCOM^DGMTU4(DFN,DT)
+8 DO QUE
End DoDot:1
+9 IF $GET(IVMZ10)'="UPLOAD IN PROGRESS"
IF '$$OPEN^IVMCQ2(DFN)
IF '$$SENT^IVMCQ2(DFN)
DO QRYQUE2^IVMCQ2(DFN,$GET(DUZ),0,$GET(XQY))
SET DGQSENT=1
IF '$DATA(ZTQUEUED)
IF '$GET(DGMSGF)
WRITE !!,"Financial query queued to be sent to HEC..."
+10 QUIT
REQ ;Update means test status to REQUIRED
+1 NEW DGMTA,AUTOCOMP,DGMTE,ERROR
+2 ;may have set prior MT for means test upload
+3 IF $GET(MTPRIME)'="DGMTU4"
NEW DGMTP,DGMTACT
SET DGMTACT="STA"
DO PRIOR^DGMTEVT
+4 SET AUTOCOMP=$$AUTOCOMP(DGMTI)
+5 ;if a test were auto-completed, don't want another being added inadvertently
+6 IF AUTOCOMP
IF $GET(DGADDF)
SET DGADDF=0
+7 IF AUTOCOMP
SET DGCS=$PIECE($GET(^DGMT(408.31,DGMTI,0)),"^",3)
+8 IF $GET(IVMZ10)'="UPLOAD IN PROGRESS"
IF 'AUTOCOMP
IF '$$OPEN^IVMCQ2(DFN)
IF '$$SENT^IVMCQ2(DFN)
DO QRYQUE2^IVMCQ2(DFN,$GET(DUZ),0,$GET(XQY))
SET DGQSENT=1
IF '$DATA(ZTQUEUED)
IF '$GET(DGMSGF)
WRITE !!,"Financial query queued to be sent to HEC..."
+9 IF ('AUTOCOMP)
IF ('$GET(DGMSGF))
WRITE !,"MEANS TEST REQUIRED"
+10 IF (AUTOCOMP)
IF ('$GET(DGMSGF))
WRITE !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
+11 SET DGMTYPT=1
+12 DO QUE
+13 QUIT
AUTOCOMP(DGMTI) ;
+1 ;Will either automatically complete the test (RX copay or means test)
+2 ;based on the Test Determined Status, or will change the status to
+3 ;Required for means tests or Incomplete for Rx copay tests
+4 ;Input:
+5 ; DGMTI - the ien of the test
+6 ;Output:
+7 ; Function value - 1 if the test was completed, 0 otherwise
+8 NEW NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
+9 SET RET=0
+10 if '$GET(DGMTI)
QUIT RET
+11 SET NODE0=$GET(^DGMT(408.31,DGMTI,0))
+12 if (NODE0="")
QUIT RET
+13 SET TYPE=$PIECE(NODE0,"^",19)
+14 SET DFN=$PIECE(NODE0,"^",2)
+15 SET TDATE=+NODE0
+16 SET NODE2=$GET(^DGMT(408.31,DGMTI,2))
+17 ;get test-determined status code
+18 SET CODE=$$GETCODE^DGMTH($PIECE(NODE2,"^",3))
+19 ;if means test
+20 IF TYPE=1
Begin DoDot:1
+21 SET DATA(.03)=$$GETSTAT^DGMTH("R",1)
SET DATA(.17)=""
+22 IF (CODE'="")
IF "ACGP"[CODE
Begin DoDot:2
+23 SET RET=1
+24 SET DATA(.03)=$PIECE(NODE2,"^",3)
+25 ;determine status if there is a hardship
+26 IF $PIECE(NODE0,"^",20)
Begin DoDot:3
+27 SET DATA(.03)=$$GETSTAT^DGMTH($SELECT(CODE="P":"P",CODE="C"&($PIECE(NODE0,U,27)>$PIECE(NODE0,U,12)):"G",1:"A"),1)
End DoDot:3
End DoDot:2
+28 IF (CODE="")!(CODE'=""&"ACGP"'[CODE)
Begin DoDot:2
+29 ; Check for another test in the current year and convert IAI records, if needed
+30 SET CONVRT=$$VRCHKUP^DGMTU2(1,,TDATE)
+31 SET DATA(2.11)=1
End DoDot:2
End DoDot:1
+32 ;RX copay test
+33 IF TYPE=2
Begin DoDot:1
+34 SET DATA(.03)=$$GETSTAT^DGMTH("I",2)
SET DATA(.17)=""
+35 IF (CODE'="")
IF "EM"[CODE
Begin DoDot:2
+36 SET RET=1
+37 SET DATA(.03)=$PIECE(NODE2,"^",3)
End DoDot:2
+38 IF (CODE="")!(CODE'=""&"EM"'[CODE)
Begin DoDot:2
+39 ; Check for another test in the current year and convert IAI records, if needed
+40 SET CONVRT=$$VRCHKUP^DGMTU2(2,,TDATE)
+41 SET DATA(2.11)=1
End DoDot:2
End DoDot:1
+42 IF '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
if '$GET(DGMSGF)
WRITE ERROR
+43 ;restore the pointers from the Income Relation file (408.22) to this
+44 ;test, using the linked test
+45 SET LINKIEN=$PIECE(NODE2,"^",6)
+46 IF LINKIEN
Begin DoDot:1
+47 SET DGINI=0
FOR
SET DGINI=$ORDER(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI))
if 'DGINI
QUIT
SET DGINR=$ORDER(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI,""))
IF $PIECE($GET(^DGMT(408.22,+DGINR,"MT")),"^")]""
Begin DoDot:2
+48 KILL DATA
+49 SET DATA(31)=DGMTI
+50 IF $$UPD^DGENDBS(408.22,+DGINR,.DATA)
End DoDot:2
End DoDot:1
+51 DO GETINCOM^DGMTU4(DFN,TDATE)
+52 QUIT RET
NOL ;Update means test status to NO LONGER REQUIRED
+1 NEW DGMTA,DGINI,DGINR,DGMTDT,DATA
+2 ; Check for converted IVM MT
IF $GET(DGNOIVMUPD)
IF $$IVMCVT^DGMTCOR(DGMTI)
Begin DoDot:1
+3 ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM MEANS TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER REQUIRED'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
+4 ; Prevent double printing of the message
SET DGNOIVMUPD=2
End DoDot:1
GOTO NOLQ
+5 if '$GET(DGMSGF)
WRITE !,"MEANS TEST NO LONGER REQUIRED"
+6 ;may have set prior MT for means test upload
+7 IF $GET(MTPRIME)'="DGMTU4"
NEW DGMTP,DGMTACT
SET DGMTACT="STA"
DO PRIOR^DGMTEVT
+8 ;save the Test Determined Status
+9 DO SAVESTAT^DGMTU4(DGMTI)
+10 SET DATA(.03)=3
SET DATA(.17)=DT
IF $$UPD^DGENDBS(408.31,DGMTI,.DATA)
+11 DO QUE
+12 ;create a Rx copay test based on MT if needed
+13 DO COPYRX^DGMTR1(DFN,DGMTI)
NOLQ QUIT
SET ;Set Cross-reference
+1 NEW D0,DA,DIV,DGIX,X
+2 SET DA=DGIEN
SET X=DGVAL
SET DGIX=0
+3 FOR
SET DGIX=$ORDER(^DD(DGFL,DGFLD,1,DGIX))
if 'DGIX
QUIT
XECUTE ^(DGIX,1)
SET X=DGVAL
+4 QUIT
KILL ;Kill Cross-reference
+1 NEW D0,DA,DIV,DGIX,X
+2 SET DA=DGIEN
SET X=DGVAL
SET DGIX=0
+3 FOR
SET DGIX=$ORDER(^DD(DGFL,DGFLD,1,DGIX))
if 'DGIX
QUIT
XECUTE ^(DGIX,2)
SET X=DGVAL
+4 QUIT
QUE ;Queue means test event driver
+1 DO AFTER^DGMTEVT
+2 SET ZTDESC="MEANS TEST EVENT DRIVER"
SET ZTDTH=$HOROLOG
SET ZTRTN="EN^DGMTEVT"
+3 FOR I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT"
SET ZTSAVE(I)=""
+4 SET ZTSAVE("DGMTINF")=1
+5 IF $DATA(IVMZ10)
SET ZTSAVE("IVMZ10")=""
+6 IF $DATA(DGENUPLD)
SET ZTSAVE("DGENUPLD")=""
+7 SET ZTIO=""
DO ^%ZTLOAD
+8 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+9 QUIT
SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
+1 ;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
+2 ;CODE file (#8.1)
+3 NEW DGTXT
+4 SET DGF=$GET(^DIC(8,+DG,0))
IF DGF=""
Begin DoDot:1
+5 SET DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
+6 SET DGTXT(5)="the ELIGIBILITY CODE file (#8)"
+7 DO MAIL^DGMTR1
+8 QUIT
End DoDot:1
QUIT
+9 SET DGF=$PIECE(DGF,"^",9)
IF DGF=""!('$DATA(^DIC(8.1,+DGF,0)))
Begin DoDot:1
+10 SET DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
+11 SET DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
+12 DO MAIL^DGMTR1
+13 SET DGF=""
+14 QUIT
End DoDot:1
+15 QUIT
