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

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1IBARXEL ;ALB/CPM - RX COPAY EXEMPTION INCOME TEST REMINDERS ;22-MAR-95
2 ;;2.0;INTEGRATED BILLING;**34,139,206,217**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; Entry point for the generation of income test reminder letters.
6 ; Invoked by the nightly IB Background job (routine IBAMTC).
7 ;
8 ; - check the job parameters
9 S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0)) I 'IBLET G ENQ
10 S IBLET0=$G(^IBE(354.6,IBLET,0))
11 S IBDEV=$P(IBLET0,"^",5) I IBDEV="" G ENQ
12 S IBREPR=$P(IBLET0,"^",7)
13 ;
14 ; - should the job run tonight?
15 D NOW^%DTC S IBDAT=%
16 S IBDAY=$$DOW^XLFDT(IBDAT\1,1)
17 I $E(IBDAT,8,17)>.17 S IBDAY=$S(IBDAY=6:0,1:IBDAY+1)
18 I $P(IBLET0,"^",6)'[IBDAY G ENQ
19 ;
20 ; - who needs a letter?
21 S IBSTART=$$FMADD^XLFDT(IBDAT\1,-366)
22 S IBEND=$$FMADD^XLFDT(IBDAT\1,-305)
23 ;
24 K ^TMP("IBEX",$J)
25 S IBD=IBSTART F S IBD=$O(^IBA(354.1,"B",IBD)) Q:'IBD!(IBD>IBEND) D
26 .S IBEX=0 F S IBEX=$O(^IBA(354.1,"B",IBD,IBEX)) Q:'IBEX D
27 ..S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
28 ..;
29 ..; - don't reprint letter unless requested
30 ..S IBLASTPR=$P(IBEXD,"^",16)
31 ..I IBREPR,IBLASTPR,IBLASTPR'=IBREPR Q
32 ..I 'IBREPR,IBLASTPR Q
33 ..;
34 ..Q:$P(IBEXD,"^",3)'=1 ; not a copay exemption
35 ..Q:'$P(IBEXD,"^",10) ; exemption is not active
36 ..;
37 ..S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
38 ..I IBEXREA'=110,IBEXREA'=120 Q ; exemption is not based on income
39 ..;
40 ..S DFN=+$P(IBEXD,"^",2)
41 ..Q:$$BIL^DGMTUB(DFN,IBD) ; vet is cat c or pend. adj. & agreed to pay deductible
42 ..I $P(IBLET0,"^",8),$$DOM(DFN) Q ; vet is in a dom
43 ..Q:$G(^DPT(DFN,.35)) ; vet is deceased
44 ..I +IBEXD'=$P($G(^IBA(354,DFN,0)),"^",3) Q ; exemption not current
45 ..Q:$D(^TMP("IBEX",$J,"V",DFN)) ; vet already getting letter
46 ..;
47 ..; - sort letters by zip code
48 ..K VA,VAERR,VAPA D ADD^VADPT
49 ..S IBZIP=$P(VAPA($S($$CONFADD():18,1:11)),"^",2) S:IBZIP="" IBZIP="99999-9999"
50 ..S:'$P(IBZIP,"-",2) IBZIP=$E(IBZIP,1,5)_"-0000"
51 ..S ^TMP("IBEX",$J,"V",DFN)=""
52 ..S ^TMP("IBEX",$J,"L",IBZIP,IBEX)=+IBEXD_"^"_+$P(IBEXD,"^",4)_"^"_DFN
53 ;
54 ; - open a print device if necessary
55 I '$D(^TMP("IBEX",$J,"L")) G ENQ
56 S IOP=IBDEV D ^%ZIS I POP G ENQ
57 U IO
58 ;
59 ; - print the letters
60 S IBSCR="" F S IBSCR=$O(^TMP("IBEX",$J,"L",IBSCR)) Q:IBSCR="" D
61 .S IBEX=0 F S IBEX=$O(^TMP("IBEX",$J,"L",IBSCR,IBEX)) Q:'IBEX D PRINT
62 ;
63ENQ I $G(IBREPR),IBLET S DA=IBLET,DIE="^IBE(354.6,",DR=".07////@" D ^DIE K DA,DR,DIE
64 ;
65 D ^%ZISC
66 K ^TMP("IBEX",$J),DFN,VAPA,VA,VAERR,X
67 K IBD,IBEX,IBEXD,IBEXREA,IBDAT,IBDAY,IBDEV,IBZIP,IBLET0,IBREPR,IBQUIT
68 K IBEND,IBLET,IBSTART,IBSCR,IBEXPD,IBDATA,IBNAM,IBALIN,IBLASTPR
69 Q
70 ;
71 ;
72PRINT ; Print a reminder letter.
73 ; Required variable input:
74 ; IBEX -- Pointer to exemption in file #354.1
75 ; IBLET -- Pointer to the reminder letter in file #354.6
76 ;
77 ; - set letter variables
78 S IBEXD=$G(^IBA(354.1,+IBEX,0))
79 S IBEXPD=$$DATE($$PLUS^IBARXEU0(+IBEXD))
80 ;S IBEXPD=$$DATE($$FMADD^XLFDT(+IBEXD,365))
81 S DFN=+$P(IBEXD,"^",2),IBQUIT=0
82 S IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
83 S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
84 I IBALIN<10!(IBALIN>25) S IBALIN=15
85 ;
86 ; - print letter
87 D ONE^IBARXEPL
88 ;
89 ; - update the exemption
90 S DA=IBEX,DIE="^IBA(354.1,",DR=".16////"_DT D ^DIE K DA,DR,DIE
91 K IBEXD,TAB,IBCNTL,IB,IBCNT,IBX,VAPA,VA,VAERR
92 Q
93 ;
94 ;
95DATE(X) ; Format the exemption expiration date.
96 N A S A="January^February^March^April^May^June^July^August^September^October^November^December"
97 Q $P(A,"^",+$E(X,4,5))_" "_+$E(X,6,7)_", "_(1700+$E(X,1,3))
98 ;
99DOM(DFN) ; Is the veteran in a domiciliary?
100 ; Input: DFN - Pointer to the patient in file #2
101 ; Output: 0 - Vet is not in a domiciliary
102 ; 1 - Vet is in a domiciliary
103 ;
104 N VAIN,VA,VAERR
105 D INP^VADPT
106 Q $P($G(^DIC(42,+$G(VAIN(4)),0)),"^",3)="D"
107 ;
108CONFADD() ; Determine, does the patient have a Confidential Address.
109 ; Input: VAPA() local array (by ADD^VADPT)
110 I '$G(VAPA(12)) Q 0 ; The Conf Address is not active
111 I $P($G(VAPA(22,3)),U,3)'="Y" Q 0 ; The Conf Address is not valid for billing-related correspondence
112 Q 1
Note: See TracBrowser for help on using the repository browser.