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