| 1 | IBARXEL ;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 | ;
|
|---|
| 5 | EN ; 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 | ;
|
|---|
| 63 | ENQ 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 | ;
|
|---|
| 72 | PRINT ; 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 | ;
|
|---|
| 95 | DATE(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 | ;
|
|---|
| 99 | DOM(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 | ;
|
|---|
| 108 | CONFADD() ; 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
|
|---|
