source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECU.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1EASECU ;ALB/PHH,LBD,AMA - LTC Co-Pay Test Utilities ; 22 AUG 2001
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40,79**;Mar 15, 2001;Build 3
3 ;
4LST(DFN,DGDT,DGMTYPT) ;Last LTC Co-Pay test for a patient
5 ; Input -- DFN Patient IEN
6 ; DGDT Date/Time (Optional- default today@2359)
7 ; DGMTYPT Type of Test (Optional - if not defined
8 ; LTC Co-Pay will be assumed)
9 ; Output -- LTC Co-Pay Test IEN^Date of Test
10 ; ^Status Name^Status Code^Source of Test
11 N DGIDT,DGMTFL1,DGMTI,DGNOD,Y I '$D(DGMTYPT) S DGMTYPT=3
12 S DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
13 F S DGIDT=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT)) Q:'DGIDT!$G(DGMTFL1) D
14 . F DGMTI=0:0 S DGMTI=+$O(^DGMT(408.31,"AID",DGMTYPT,DFN,DGIDT,DGMTI)) Q:'DGMTI!$G(DGMTFL1) D
15 . . S DGNOD=$G(^DGMT(408.31,DGMTI,0)) I DGNOD S DGMTFL1=1,Y=DGMTI_"^"_$P(^(0),"^")_"^"_$$MTS(+$P(^(0),"^",3))_"^"_$P(DGNOD,"^",23)
16 Q $G(Y)
17 ;
18MTS(DGMTS) ;LTC Co-Pay test status -- default current
19 ; Input -- DGMTS LTC Co-Pay Test Status IEN
20 ; Output -- Status Name^Status Code
21 N Y
22 I $G(DGMTS) S Y=$P($G(^DG(408.32,DGMTS,0)),"^",1,2)
23 Q $G(Y)
24 ;
25EXMPT(DFN) ;Check if veteran is exempt from LTC co-payments:
26 ; If the veteran has a compensable SC disability, OR
27 ; If the veteran is a single, NSC pensioner not in receipt of A&A
28 ; and HB benefits
29 ; Input -- DFN Patient IEN
30 ; Output -- 0 = veteran not exempt
31 ; 1 = veteran has compensable SC disability
32 ; 2 = veteran is single NSC pensioner (no A&A, HB)
33 N X,Y,ELG
34 S Y=0
35 ; if service connected percentage is greater than 10% OR service
36 ; connected percentage is less than 10% and annual VA
37 ; check amount is greater than 0, then exempt type 1
38 S X=$G(^DPT(DFN,.36)),ELG=$P($G(^DIC(8,+X,0)),U,9)
39 I ELG=1!($P($G(^DPT(DFN,.3)),U,2)'<10) S Y=1 G EXMPTQ
40 I ELG=3,$P($G(^DPT(DFN,.3)),U,2)<10,$P($G(^DPT(DFN,.362)),U,20)>0 S Y=1 G EXMPTQ
41 ; if Service Connected quit
42 I $P($G(^DPT(DFN,.3)),U)="Y" G EXMPTQ
43 ; if Marital Status = 'Married' or 'Separated' quit
44 S X=$P($G(^DIC(11,+$P($G(^DPT(DFN,0)),U,5),0)),U,3)
45 I "^M^S^"[("^"_X_"^") G EXMPTQ
46 ; if not receiving VA pension quit
47 S X=$G(^DPT(DFN,.362)) I $P(X,U,14)'="Y" G EXMPTQ
48 ; if receiving A&A or HP benefits quit
49 I $P(X,U,12)="Y"!($P(X,U,13)="Y") G EXMPTQ
50 S Y=2
51EXMPTQ Q Y
52 ;
53DIS(DFN) ;Display patient's current LTC Copay Test status and test date
54 ; Input -- DFN IEN of Patient file
55 ; Output -- None
56 N DGX,DGMTI,DGMTDT,DGMTS
57 Q:'$G(DFN)
58 S DGX=$$LST(DFN) Q:'DGX
59 S DGMTI=+DGX,DGMTDT=$P(DGX,U,2),DGMTS=$P(DGX,U,3) S:DGMTS="" DGMTS="UNKNOWN"
60 W !,"LTC Copayment Status: ",DGMTS," Last Test: " S Y=DGMTDT X ^DD("DD") W Y
61 ; If last test is over a year old and patient is not deceased or not
62 ; exempt due to eligibility (compensable SC) or LTC before 11/30/99
63 ; display message that a new test is required
64 I $$FMDIFF^XLFDT(DT,DGMTDT)>364 D
65 . I $P($G(^DPT(DFN,.35)),U) Q
66 . I "^1^4^"[(U_$P($G(^DGMT(408.31,DGMTI,2)),U,7)_U) Q
67 . W " **NEW TEST REQUIRED**"
68 I $P($G(^DGMT(408.31,DGMTI,0)),U,11)=0 W !,"Patient INELIGIBLE to Receive LTC Services -- Did Not Agree to Pay Copayments"
69 Q
70 ;
71FORM(DGMTI) ; Return the version of the 10-10EC form used to complete
72 ; the LTC Copay Test passed in DGMTI
73 ; Input: DGMTI - LTC Copay Test (IEN file #408.31)
74 ; Output: 0 = Original format
75 ; 1 = Revised format
76 I '$G(DGMTI) Q 0
77 Q $P($G(^DGMT(408.31,DGMTI,2)),U,10)
78 ;
79 ;EAS*1.0*79 - Instead of changing DIS (in case another routine
80 ; calls it), copied it but also used LTC Admission Date
81DISDT(DFN,EASADM) ;Display patient's LTC Copay Test status for a given LTC Admission Date
82 ; Input -- DFN - IEN of Patient file
83 ; EASADM - LTC Admission Date
84 ; Output -- None
85 N DGX,DGMTI,DGMTDT,DGMTS
86 Q:'$G(DFN) Q:'$G(EASADM)
87 S DGX=$$LST(DFN,EASADM) Q:'DGX
88 S DGMTI=+DGX,DGMTDT=$P(DGX,U,2),DGMTS=$P(DGX,U,3) S:DGMTS="" DGMTS="UNKNOWN"
89 W !,"LTC Copayment Status: ",DGMTS," Last Test: " S Y=DGMTDT X ^DD("DD") W Y
90 ; If last test is over a year old and patient is not deceased or not
91 ; exempt due to eligibility (compensable SC) or LTC before 11/30/99
92 ; display message that a new test is required
93 I $$FMDIFF^XLFDT(DT,DGMTDT)>364 D
94 . I $P($G(^DPT(DFN,.35)),U) Q
95 . I "^1^4^"[(U_$P($G(^DGMT(408.31,DGMTI,2)),U,7)_U) Q
96 . W " **NEW TEST REQUIRED**"
97 I $P($G(^DGMT(408.31,DGMTI,0)),U,11)=0 W !,"Patient INELIGIBLE to Receive LTC Services -- Did Not Agree to Pay Copayments"
98 Q
Note: See TracBrowser for help on using the repository browser.