- DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements;7/8/05 2:30pm
- ;;5.3;PIMS;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,1015,1016**;JUN 30, 2012;Build 20
- ;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 a Medal of Honor recipient
- ; 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
- I DGCS S OLD=$$OLD^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
- I $P($G(^DPT(DFN,.54)),U)="Y" S DGREQF=0
- D
- .I DGREQF,DGCS=3,'OLD 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
- ;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
- DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements;7/8/05 2:30pm
- +1 ;;5.3;PIMS;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,1015,1016**;JUN 30, 2012;Build 20
- +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 a Medal of Honor recipient
- +11 ; Input -- DFN Patient IEN
- +12 ; DGADDF Means Test Add Flag (Optional- default none)
- +13 ; (1 if using the 'Add a New Means Test' option)
- +14 ; DGMSGF Means Test Msg Flag (Optional- default none)
- +15 ; (1 to suppress messages)
- +16 ; DGNOIVMUPD No IVM Update Flag (Optional - default allow)
- +17 ; (1 if updating of an IVM test is not allowed)
- +18 ; Output -- DGREQF Means Test Require Flag
- +19 ; (1 if required and 0 if not required)
- +20 ; DGDOM1 DOM Patient Flag (defined and set to 1 if
- +21 ; patient currently on a DOM ward)
- +22 ; DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
- +23 ; used in CP^DG10. Killed there as well.
- +24 ; If NOT using the 'Add a New Means Test' option,
- +25 ; a REQUIRED date of test will be added for the
- +26 ; patient if it is required.
- +27 ; If a means test is required and the current
- +28 ; status is NO LONGER REQUIRED, the last date of
- +29 ; test and current means test status will be
- +30 ; updated to REQUIRED unless the DGNOIVMUPD flag is set to 1
- +31 ; and the current primary means test is an IVM test.
- +32 ; If a means test is no longer required the
- +33 ; last date of test and the current means test
- +34 ; status will also be updated to NO LONGER REQUIRED unless
- +35 ; the DGNOIVMUPD flag is set to 1 and the current primary
- +36 ; 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 IF DGCS
- SET OLD=$$OLD^DGMTU4(+DGMT0)
- +22 ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
- +23 IF $PIECE($GET(^DPT(DFN,.53)),U)="Y"
- SET DGREQF=0
- +24 ;Catastrophically disabled
- +25 ;DG*5.3*840
- IF $PIECE($GET(^DPT(DFN,.39)),U,6)="Y"
- SET DGREQF=0
- +26 ;Medal of Honor DG*5.3*840
- +27 IF $PIECE($GET(^DPT(DFN,.54)),U)="Y"
- SET DGREQF=0
- +28 Begin DoDot:1
- +29 IF DGREQF
- IF DGCS=3
- IF 'OLD
- DO REQ
- QUIT
- +30 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
- +31 ; next line added 2/19/02 - DG*5.3*426
- +32 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
- +33 IF DGREQF
- IF '$GET(DGADDF)
- IF (('DGCS)!(OLD))
- IF '$GET(DGMDOD)
- DO ADD
- QUIT
- +34 IF 'DGREQF
- IF DGCS
- IF DGCS'=3
- IF '$GET(DGDOM)
- IF '$GET(DGMDOD)
- IF '+$GET(IVMZ10F)
- DO NOL
- QUIT
- End DoDot:1
- +35 ;be sure to check whether or not patient is subject to RX copay!
- +36 DO EN^DGMTCOR
- +37 QUIT
- +38 ;Check if patient is in a DOM
- +39 ; call to DOM checks if patient currently on a DOM ward
- +40 ; (called from EN)
- +41 ; call to DOM1 checks if patient on a DOM ward for a specific date
- +42 ; before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
- +43 ; S VAINDT=specific date
- +44 ; S DFN=Patient IEN
- +45 ; output - DGDOM & DGDOM1 (defined and set to 1 if
- +46 ; 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 ;Secondary Eligibility
- +23 FOR DG=2,4,15:1:18
- SET DGE(DG)=""
- +24 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