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

EASECA.m

Go to the documentation of this file.
  1. EASECA ;ALB/PHH,LBD,HM - Add a New LTC Co-Pay Test ;10 AUG 2001
  1. ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,174**;Mar 15, 2001;Build 26
  1. ;
  1. EN ;Entry point to add a new LTC Co-Pay test
  1. N DGMDOD S DGMDOD=""
  1. S DGMTYPT=3
  1. I $D(DGMTDFN)#2 K DGMTDFN
  1. S DIC="^DPT(",DIC(0)="AEMQ" W !! D ^DIC K DIC G Q:Y<0 S (DFN,DGMTDFN)=+Y
  1. I $P($G(^DPT(DFN,.35)),U)'="" S DGMDOD=$P(^DPT(DFN,.35),U)
  1. I $G(DGMDOD) W !!,"Patient died on: ",$$FMTE^XLFDT(DGMDOD,"1D") Q
  1. ; Is patient a veteran? Added for LTC III (EAS*1*34)
  1. I $P($G(^DPT(DFN,"VET")),U)'="Y" W !!,"Patient is not a Veteran." Q
  1. ;
  1. S DGLDT=$$LST^EASECU(DFN,"",DGMTYPT),DGLD=$P(DGLDT,U,2),DGLDYR=$E(DGLD,1,3)_"1231"
  1. ;
  1. DT S %DT("A")="Date of LTC Copay Test: ",%DT="AEX",%DT(0)="-NOW",%DT("B")="NOW" W ! D ^%DT K %DT G Q:Y<0 S DGMTDT=Y
  1. I DGLD,DGMTDT'>DGLD W !?3,*7,"The date of test must be after the date of the last test on " S Y=DGLD X ^DD("DD") W Y,"." G DT
  1. ; LTC III (EAS*1*34) - change to allow multiple tests within a year
  1. I DGLD S X1=DGMTDT,X2=DGLD D ^%DTC I X<365 D G EN:$G(Y)'=1
  1. .W !?3,*7,"An LTC Copay Test already exists on " S Y=DGLD X ^DD("DD") W Y,"."
  1. .S DIR(0)="Y",DIR("A")="Are you sure you want to add a new test",DIR("B")="NO" D ^DIR K DIR
  1. .;S DGTTYP="LTC COPAY "
  1. .;W !,$S($P($G(^DG(408.34,+$P($G(^DGMT(408.31,+DGLDT,0)),U,23),0)),U)="VAMC":" Use the 'EASEC "_DGTTYP_"TEST EDIT' Option.",1:" Use the 'EASEC "_DGTTYP_"TEST VIEW' Option.")
  1. ;
  1. D ADD G EN:DGMTI<0
  1. ;
  1. EXMPT ; Is veteran exempt from LTC copayments?
  1. S DGEXMPT=$$EXMPT^EASECU(DFN)
  1. I DGEXMPT D EXMPT^EASECSCC(DFN,DGMTI,DGEXMPT) D Q G EN
  1. ; Is veteran exempt for reason other than low income?
  1. ; LTC Phase IV (EAS*1*40)
  1. W !!
  1. S DIR("A")="Is veteran EXEMPT from LTC copayments",DIR("B")="NO",DIR(0)="Y",DIR("?")="Enter either 'Y' or 'N'."
  1. S DIR("?",1)="Answer 'Yes' if the veteran is exempt from LTC copayments"
  1. S DIR("?",2)="for a reason other than low income.",DIR("?",3)=""
  1. D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D DEL,Q G EN
  1. I Y D D Q G EN
  1. .; Get reason for exemption
  1. .S DIR("A")="Reason for Exemption",DIR(0)="P^714.1:EM"
  1. .S DIR("S")="I $P(^(0),U,2),""^1^2^12^14^""'[(U_Y_U)" ;EAS*1.0*174 HM exclude 14 also
  1. .D ^DIR K DIR I 'Y!($D(DUOUT))!($D(DTOUT)) D D DEL Q
  1. ..W !!,"A reason for exemption must be entered. LTC Copay Test cannot be added.",!
  1. .D EXMPT^EASECSCC(DFN,DGMTI,+Y)
  1. ; Check if veteran's income is below the pension threshold
  1. D EN^EASECMT I $G(DGOUT) D DEL,Q G EN
  1. I DGEXMPT D EXMPT^EASECSCC(DFN,DGMTI,2) D Q G EN
  1. W !! F I=1:1:80 W "="
  1. W !!,?10,"Veteran is NOT EXEMPT from Long Term Care copayments based"
  1. W !,?10,"on last year's income and must complete a 10-10EC form."
  1. W !! F I=1:1:80 W "="
  1. ; Does veteran decline to provide income information?
  1. W !!
  1. D REF^EASECSCC I $D(DTOUT)!($D(DUOUT)) D Q G EN
  1. I $D(DGREF) D D Q G EN
  1. .; Ask if veteran agrees to pay copayments; complete LTC copay test
  1. .D AGREE^EASECSCC Q:$D(DTOUT)!($D(DUOUT))
  1. .S DGSTA="NON-EXEMPT",DGCAT="T" D STA^DGMTSCU2 S (DGINT,DGDET,DGNWT)=""
  1. .D UPD^EASECSCC
  1. ; Go to LTC co-pay test (1010-EC) input screens
  1. S DGMTACT="ADD",DGMTROU="EN^EASECA" G EN^EASECSC
  1. ;
  1. Q K DA,DFN,DGADDF,DGBL,DGCAT,DGEXMPT,DGFL,DGFLD,DGIRO,DGLD,DGLDT,DGLDYR
  1. K DGMTACT,DGMTCOR,DGMTDT,DGMTI,DGMTROU,DGMTYPT,DGOUT,DGREQF,DGSTA
  1. K DGTTYP,DGVI,DGVO,DTOUT,DUOUT,X,X1,X2,Y
  1. Q
  1. ;
  1. ADD ;Add LTC Copay test
  1. ; Input -- DFN Patient IEN
  1. ; DGMTDT Date
  1. ; DGMTYPT Type of Test 3 = LTC Copay
  1. ; Output -- DGMTI Annual LTC Copay Test IEN
  1. N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,DS,X,D0,DGSITE
  1. ;
  1. S X=DGMTDT,(DIC,DIK)="^DGMT(408.31,",DIC(0)="L",DLAYGO=408.31
  1. S DGSITE=$$GETSITE^DGMTU4(.DUZ)
  1. ; For LTC IV (EAS*1*40) - set 1010EC Form field (#2.1) = 1
  1. S DIC("DR")=".02////"_DFN_";.019////"_DGMTYPT_";.23////1;2.05////"_DGSITE_";2.1////1"
  1. K DD,D0
  1. D FILE^DICN S DGMTI=+Y
  1. ADDQ Q
  1. ;
  1. DEL ;Delete incomplete LTC Copay test
  1. ; Input -- DGMTI LTC Copay test IEN
  1. N DA,DIK
  1. Q:'$G(DGMTI) Q:$P($G(^DGMT(408.31,DGMTI,0)),U,19)'=3
  1. S DA=DGMTI,DIK="^DGMT(408.31,"
  1. D ^DIK
  1. Q