Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGMTCOR

DGMTCOR.m

Go to the documentation of this file.
  1. DGMTCOR ;ALB/CAW,SCG,LBD,TMK,HM,DSB - Check Copay Test Requirements;07/28/08
  1. ;;5.3;Registration;**21,45,182,290,305,330,344,495,564,773,840,858,972,993**;Aug 13, 1993;Build 92
  1. ;
  1. ;A patient may apply for a copay test under the following conditions:
  1. ; - Applicant is a veteran
  1. ; - Applicant's primary or other eligibility does NOT contain
  1. ; - Service Connected 50% to 100% or
  1. ; - Aid and Attendance or
  1. ; - Housebound or
  1. ; - VA Pension
  1. ; - Catastrophically Disabled
  1. ; - Medal of Honor Recipient
  1. ; - Primary Eligibility is NSC
  1. ; - who has NOT been means tested
  1. ; - who claims exposure to agent orange or ionizing radiation
  1. ; - who is eligible for medicaid
  1. ; - Applicants who have answered 'no' to Receiving A&A, HB, or Pension
  1. ; - Applicants who have previously qualified and applied for a copay
  1. ; exemption, still qualify and have NOT been copay tested in the
  1. ; past year
  1. ; - Applicants who are not currently a DOM patient or inpatient
  1. ; (they are temporarily exempt from copay testing) DG*5.3*290
  1. ; - Applicants who do not have POW eligibility (DG*5.3*564 - HVE III)
  1. ; - Applicants who do not meet criteria for Unemployable:
  1. ; Unemployable="Y", SC%>0, not receiving A&A, HB or Pension, and
  1. ; Total VA Check Amount>0 (DG*5.3*564 - HVE III)
  1. ; - Applicant is not Registration only DG*5.3*993
  1. ;
  1. ; Input -- DFN Patient IEN
  1. ; DGADDF Means Test Add Flag (optional)
  1. ; DGNOIVMUPD Do Not Update IVM Copay Test Flag (optional)
  1. ; Output -- DGMTCOR Copay Test Flag
  1. ; (1 if eligible and 0 if not eligible)
  1. ;
  1. ;
  1. EN ;
  1. Q:$G(VAFCA08)=1
  1. N DGMTI,DGMTYPT,DGMDOD
  1. D ON^DGMTCOU G:'Y ENQ
  1. S DGRGAUTO=1 ;possible change in cp status w/o call to cp event driver
  1. D CHK
  1. ;
  1. Q:($G(DGWRT)=8)!($G(DGWRT)=9) ;brm;quit if inpatient or dom;DG*5.3*290
  1. S IVMZ10F=+$G(IVMZ10F)
  1. I 'DGMTCOR,'$G(DGADDF),'$G(DGMDOD),'IVMZ10F D NLA
  1. I DGMTCOR,'$G(DGADDF),'$G(DGMDOD) D INC
  1. I DGRGAUTO&'$G(DGADDF) D QREGAUTO ;if cp event driver not fired off & NOT a new means test
  1. ;
  1. ENQ Q
  1. ;
  1. CHK N STATUS,DGELIG,DGE,DGI,DGNODE,DGMDOD,DGMTDT,DGMTI,DGMTL
  1. S DGMTCOR=1,DGMT="",DGMTYPT=2
  1. I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0,DGWRT=1 G CHKQ ;NON-VET
  1. ;Added with DG*5.3*344
  1. S DGMTL=$$LST^DGMTU(DFN),DGMTI=+DGMTL,DGMTDT=$P(DGMTL,U,2)
  1. S DGMDOD=$P($G(^DPT(DFN,.35)),U)
  1. I 'DGMTI,$G(DGMDOD) S DGMTCOR=0 Q
  1. I DGMDOD,(DGMTCOR),(DGMTDT>(DGMDOD-1)) S DGMTCOR=0 G CHKQ
  1. ;
  1. I '$P($G(^DPT(DFN,.36)),U) S DGMTCOR=0,DGWRT=2 G CHKQ ;NO PRIM ELIG
  1. I +$G(DGMDOD) S DGNOCOPF=1
  1. ;
  1. ;This doesn't work! The "AEL" x-ref not there when changing the primary
  1. ;eligibility! Problem with order that the cross-references are called
  1. ;in, DGMTR is called before the "AEL" x-ref is set!
  1. ;F S DGMTI=$O(^DPT("AEL",DFN,DGMTI)) Q:'DGMTI S DGMTE=$P($G(^DIC(8,DGMTI,0)),U,9) I "^1^2^4^15^"[("^"_DGMTE_"^") S DGMTCOR=0,DGWRT=3 G CHKQ
  1. ;
  1. ;
  1. S DGI=$P($G(^DPT(DFN,.36)),"^"),DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U
  1. S DGI=0 F S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U
  1. I (DGELIG["^1^") S DGMTCOR=0,DGWRT=3 G CHKQ ;SC 50-100%
  1. ;Begin DG*5.3*993 Registration only
  1. I $G(DGENRYN)=0 S DGMTCOR=0,DGWRT=14 G CHKQ
  1. I '$G(DGENRYN) S STATUS=$$STATUS^DGENA(DFN) I STATUS=25 S DGMTCOR=0,DGWRT=14 G CHKQ
  1. ;End DG*5.3*993
  1. F DGI=.3,.362,.39,.52,.54 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) ;DG*5.3*840; added MOH indicator field on loop DG*5.3*972 HM
  1. I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0,DGWRT=5 G CHKQ ;A&A
  1. I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0,DGWRT=6 G CHKQ ;HB
  1. I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0,DGWRT=7 G CHKQ ;PENSION
  1. I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0,DGWRT=10 G CHKQ ;POW (DG*5.3*564)
  1. I $P(DGNODE(.39),U,6)["Y"!(DGELIG["^21^") S DGMTCOR=0,DGWRT=12 G CHKQ ;CD (DG*5.3*840
  1. I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0,DGWRT=11 G CHKQ ;UNEMPLOYABLE (DG*5.3*564)
  1. I $P(DGNODE(.54),U,1)["Y" S DGMTCOR=0,DGWRT=13 G CHKQ ;MOH (DG*5.3*972);HM
  1. ;brm added next 3 lines for DG*5.3*290
  1. N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR,NOW
  1. D DOM^DGMTR I $G(DGDOM) S DGMTCOR=0,DGRGAUTO=0,DGWRT=8 Q ;DOM
  1. D IN5^VADPT I $G(VAIP(1))'="" S DGMTCOR=0,DGRGAUTO=0,DGWRT=9 Q ;INP
  1. ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
  1. I DGMTI,'$$OLDMTPF^DGMTU4(DGMTDT) S STATUS=$P($G(^DGMT(408.31,+DGMTI,0)),U,3) I STATUS'="3" S DGMTCOR=0,DGWRT=4 G CHKQ
  1. CHKQ Q
  1. ;
  1. NLA ; Change Status to NO LONGER APPLICABLE - if appropriate
  1. ;
  1. N DGCS,DGMTI,DGMT0,DGINI,DGINR,DGVAL,DGFL,DGFLD,DGIEN,DGMTACT,TDATE
  1. S DGMTI=+$$LST^DGMTU(DFN,"",2) Q:'DGMTI!($P($G(^DGMT(408.31,DGMTI,0)),U,3)=10)
  1. ; Do not allow update of IVM test by site
  1. I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D Q ;Check if converted IVM MT
  1. . ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM RX COPAY TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER APPLICABLE'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
  1. . S DGNOIVMUPD=2 ; Prevent double printing of the message
  1. S DGMT0=$G(^DGMT(408.31,DGMTI,0)) Q:'DGMT0
  1. S DGCS=$P(DGMT0,U,3)
  1. S TDATE=+DGMT0
  1. S DGMTACT="STA" D PRIOR^DGMTEVT
  1. ;
  1. D SAVESTAT^DGMTU4(DGMTI)
  1. ;
  1. S DGFL=408.31,DGIEN=DGMTI
  1. S DGFLD=.03 I DGCS]"" S DGVAL=DGCS D KILL^DGMTR
  1. S DGVAL=10,$P(^DGMT(408.31,DGMTI,0),"^",3)=DGVAL D SET^DGMTR
  1. S DGFLD=.17,DGVAL=DT,$P(^DGMT(408.31,DGMTI,0),"^",17)=DT D SET^DGMTR
  1. W:'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY TEST NO LONGER APPLICABLE"
  1. D GETINCOM^DGMTU4(DFN,TDATE)
  1. S DGMTYPT=2 D QUE^DGMTR
  1. S DGRGAUTO=0
  1. NLAQ Q
  1. ;
  1. INC ;Update copay status to 'INCOMPLETE' if applicable OR restore completed test
  1. N DGMTACT,DGMTI,DGFL,DGFLD,DGIEN,DGMTP,DGVAL,DGMT0,AUTOCOMP,ERROR
  1. S AUTOCOMP=0
  1. S DGMTI=+$$LST^DGMTU(DFN,"",2)
  1. D
  1. .Q:'DGMTI
  1. .I ($P($G(^DGMT(408.31,DGMTI,0)),U,3)'=10) S AUTOCOMP=1 Q
  1. .S DGMT0=$G(^DGMT(408.31,DGMTI,0)),DGCS=$P(DGMT0,U,3)
  1. .Q:'DGMT0
  1. .S DGMTACT="STA" D PRIOR^DGMTEVT
  1. .S AUTOCOMP=$$AUTOCOMP^DGMTR(DGMTI)
  1. .W:'AUTOCOMP&'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY EXEMPTION TEST UPDATED TO INCOMPLETE"
  1. .W:AUTOCOMP&'$G(DGMTMSG)&'$D(ZTQUEUED) !,"COPAY EXEMPTION TEST UPDATED TO ",$$GETNAME^DGMTH($P($G(^DGMT(408.31,DGMTI,0)),"^",3))
  1. .S DGMTYPT=2 D QUE^DGMTR
  1. .S DGRGAUTO=0
  1. ;
  1. I $G(IVMZ10)'="UPLOAD IN PROGRESS",$G(DGQSENT)'=1,'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..."
  1. ;
  1. INCQ Q
  1. ;
  1. QREGAUTO ;Queues off test done by IB recalculating CP status
  1. ; Input: DFN
  1. ; Action: Possible update of Copay Status
  1. ;
  1. Q:'$D(^IBA(354.1,"APIDT",DFN,1)) ;No action if no status on file
  1. S ZTDESC="CHECK PATIENT FILE CHANGES VS CP STATUS",ZTDTH=$H,ZTRTN="REGAUTO^IBARXEU5",ZTSAVE("DFN")="",ZTIO=""
  1. D ^%ZTLOAD
  1. K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
  1. Q
  1. ;
  1. IVMCVT(IVMTIEN) ; Check for a converted IVM Means Test
  1. ; Input IVMTIEN - MT IEN to check
  1. ; Return 1 - if converted MT
  1. ; 0 - if not a converted MT
  1. ;
  1. N FLAG,IVMAR
  1. S FLAG=0
  1. I '$G(IVMTIEN) G IVMQ
  1. D GETS^DIQ(408.31,IVMTIEN,".23;.25","E","IVMAR")
  1. ; To identify an IVM converted test in the ANNUAL MEANS TEST, #408.31, if the Source of Test (#.23)
  1. ; is equal to 'IVM' OR the Date IVM Verified MT Completed (#.25) is populated, then the test should
  1. ; be considered a converted test.
  1. I IVMAR(408.31,IVMTIEN_",",.23,"E")="IVM" S FLAG=1 G IVMQ
  1. I IVMAR(408.31,IVMTIEN_",",.25,"E")]"" S FLAG=1 G IVMQ
  1. IVMQ ;
  1. Q FLAG