source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEL1.m@ 677

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

initial load of WorldVistAEHR
File size: 3.1 KB
RevLine 
[613]1IBARXEL1 ;ALB/CPM - RX COPAY EXEMPTION REMINDER REPRINT ;14-APR-95
2 ;;2.0;INTEGRATED BILLING;**34,199,217**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5REPR ; Reprint a single income test reminder letter.
6 S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0))
7 I 'IBLET W !!,"You do not have the Income Test Reminder letter defined!" G REPRQ
8 ;
9 S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQMZ",DIC("A")="Select BILLING PATIENT: "
10 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
11 D ^DIC K DIC S DFN=+Y G:Y<0 REPRQ
12 ;
13 ; - find the most recent active exemption
14 S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0))
15 S IBEXD=$G(^IBA(354.1,IBEX,0))
16 I 'IBEXD W !!,"This veteran has never had an active copayment exemption status!" G REPR
17 ;
18 I $G(^DPT(DFN,.35)) W !!,*7,"Please note that this veteran died on ",$$DAT1^IBOUTL(+^(.35)),"."
19 ;
20 ; - display the veteran's current exemption status
21 S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
22 W !!,$TR($J("",80)," ","=")
23 W !?10,"Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4))," (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
24 W !?12,"Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
25 ;
26 ; - display the previous status if the veteran has not reported income
27 I IBEXREA=210 D
28 .S IBCHK=1
29 .S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-IBEXD)),0))
30 .S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
31 .S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
32 .W !!?4,"Prior Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4))," (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
33 .W !?6,"Prior Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
34 ;
35 ; - if a letter has already been printed, display the print date
36 I $P(IBEXD,"^",16) D
37 .W !!?12,"Letter Printed: ",$$DAT1^IBOUTL($P(IBEXD,"^",16))
38 .S X=$P($$LST^DGMTCOU1(DFN,$$FMADD^XLFDT(DT,60),3),"^",2)
39 .W ?41,"Current Income Test Date: ",$S(X:$$DAT1^IBOUTL(X),1:"<none>")
40 W !,$TR($J("",80)," ","=")
41 ;
42 ; - exemption must be based on income
43 I IBEXREA'=110,IBEXREA'=120 W !!,"You may only generate a letter for an exemption based on income!",! K IBCHK G REPR
44 ;
45 I '$G(IBCHK),+IBEXD>$$FMADD^XLFDT(DT,-305) W !!,"Please note that this exemption is not due to expire for ",$$FMDIFF^XLFDT(+IBEXD+10000,DT)," days!"
46 ;
47 ; check for Cat C or Pending Adj. and has agreed to pay deductible
48 I $$BIL^DGMTUB(DFN,DT) W !!,"**Please note that this veteran no longer requires a Means Test**"
49 ;
50 ; - okay to print letter?
51 S DIR(0)="Y",DIR("A")="Okay to print the reminder letter",DIR("?")="To print the income test reminder letter, answer 'YES.' Otherwise, answer 'NO.'"
52 W ! D ^DIR K DIR,DIRUT,DTOUT,DUOUT,DIROUT I 'Y G REPRQ
53 ;
54 W !!,"*** Please note that the reminder letter prints in 80 columns. ***",!
55 S %ZIS="QM" D ^%ZIS G:POP REPRQ
56 I $D(IO("Q")) D G REPRQ
57 .S ZTRTN="DQ^IBARXEL1",ZTDESC="IB - PRINT INCOME TEST REMINDER LETTER"
58 .F I="IBEX","IBLET" S ZTSAVE(I)=""
59 .D ^%ZTLOAD K IO("Q") D HOME^%ZIS
60 .W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
61 .K ZTSK,IO("Q")
62 ;
63 U IO
64 ;
65DQ ; Queued entry point.
66 D PRINT^IBARXEL
67 I $D(ZTQUEUED) S ZTREQ="@" Q
68 ;
69REPRQ D ^%ZISC
70 K DFN,IBLET,IBEX,IBEXD,IBEXREA,IBCHK,IBEXPD,IBQUIT,IBDATA,IBNAM,IBALIN
71 Q
Note: See TracBrowser for help on using the repository browser.