IBARXEL ;ALB/CPM - RX COPAY EXEMPTION INCOME TEST REMINDERS ;22-MAR-95
;;2.0;INTEGRATED BILLING;**34,139,206,217,385**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; Entry point for the generation of income test reminder letters.
; Invoked by the nightly IB Background job (routine IBAMTC).
;
; - check the job parameters
S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0)) I 'IBLET G ENQ
S IBLET0=$G(^IBE(354.6,IBLET,0))
S IBDEV=$P(IBLET0,"^",5) I IBDEV="" G ENQ
S IBREPR=$P(IBLET0,"^",7)
;
; - should the job run tonight?
D NOW^%DTC S IBDAT=%
S IBDAY=$$DOW^XLFDT(IBDAT\1,1)
I $E(IBDAT,8,17)>.17 S IBDAY=$S(IBDAY=6:0,1:IBDAY+1)
I $P(IBLET0,"^",6)'[IBDAY G ENQ
;
; - who needs a letter?
S IBSTART=$$FMADD^XLFDT(IBDAT\1,-366)
S IBEND=$$FMADD^XLFDT(IBDAT\1,-305)
;
K ^TMP("IBEX",$J)
S IBD=IBSTART F S IBD=$O(^IBA(354.1,"B",IBD)) Q:'IBD!(IBD>IBEND) D
.S IBEX=0 F S IBEX=$O(^IBA(354.1,"B",IBD,IBEX)) Q:'IBEX D
..S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
..;
..; - don't reprint letter unless requested
..S IBLASTPR=$P(IBEXD,"^",16)
..I IBREPR,IBLASTPR,IBLASTPR'=IBREPR Q
..I 'IBREPR,IBLASTPR Q
..;
..Q:$P(IBEXD,"^",3)'=1 ; not a copay exemption
..Q:'$P(IBEXD,"^",10) ; exemption is not active
..;
..S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
..I IBEXREA'=110,IBEXREA'=120 Q ; exemption is not based on income
..;
..; -- veteran income test excempt from expiration under VFA rules
..Q:$$VFAOK^IBARXEU(IBEXD)
..;
..S DFN=+$P(IBEXD,"^",2)
..Q:$$BIL^DGMTUB(DFN,IBD) ; vet is cat c or pend. adj. & agreed to pay deductible
..I $P(IBLET0,"^",8),$$DOM(DFN) Q ; vet is in a dom
..Q:$G(^DPT(DFN,.35)) ; vet is deceased
..I +IBEXD'=$P($G(^IBA(354,DFN,0)),"^",3) Q ; exemption not current
..Q:$D(^TMP("IBEX",$J,"V",DFN)) ; vet already getting letter
..;
..; - sort letters by zip code
..K VA,VAERR,VAPA D ADD^VADPT
..S IBZIP=$P(VAPA($S($$CONFADD():18,1:11)),"^",2) S:IBZIP="" IBZIP="99999-9999"
..S:'$P(IBZIP,"-",2) IBZIP=$E(IBZIP,1,5)_"-0000"
..S ^TMP("IBEX",$J,"V",DFN)=""
..S ^TMP("IBEX",$J,"L",IBZIP,IBEX)=+IBEXD_"^"_+$P(IBEXD,"^",4)_"^"_DFN
;
; - open a print device if necessary
I '$D(^TMP("IBEX",$J,"L")) G ENQ
S IOP=IBDEV D ^%ZIS I POP G ENQ
U IO
;
; - print the letters
S IBSCR="" F S IBSCR=$O(^TMP("IBEX",$J,"L",IBSCR)) Q:IBSCR="" D
.S IBEX=0 F S IBEX=$O(^TMP("IBEX",$J,"L",IBSCR,IBEX)) Q:'IBEX D PRINT
;
ENQ I $G(IBREPR),IBLET S DA=IBLET,DIE="^IBE(354.6,",DR=".07////@" D ^DIE K DA,DR,DIE
;
D ^%ZISC
K ^TMP("IBEX",$J),DFN,VAPA,VA,VAERR,X
K IBD,IBEX,IBEXD,IBEXREA,IBDAT,IBDAY,IBDEV,IBZIP,IBLET0,IBREPR,IBQUIT
K IBEND,IBLET,IBSTART,IBSCR,IBEXPD,IBDATA,IBNAM,IBALIN,IBLASTPR
Q
;
;
PRINT ; Print a reminder letter.
; Required variable input:
; IBEX -- Pointer to exemption in file #354.1
; IBLET -- Pointer to the reminder letter in file #354.6
;
; - set letter variables
S IBEXD=$G(^IBA(354.1,+IBEX,0))
S IBEXPD=$$DATE($$PLUS^IBARXEU0(+IBEXD))
;S IBEXPD=$$DATE($$FMADD^XLFDT(+IBEXD,365))
S DFN=+$P(IBEXD,"^",2),IBQUIT=0
S IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
I IBALIN<10!(IBALIN>25) S IBALIN=15
;
; - print letter
D ONE^IBARXEPL
;
; - update the exemption
S DA=IBEX,DIE="^IBA(354.1,",DR=".16////"_DT D ^DIE K DA,DR,DIE
K IBEXD,TAB,IBCNTL,IB,IBCNT,IBX,VAPA,VA,VAERR
Q
;
;
DATE(X) ; Format the exemption expiration date.
N A S A="January^February^March^April^May^June^July^August^September^October^November^December"
Q $P(A,"^",+$E(X,4,5))_" "_+$E(X,6,7)_", "_(1700+$E(X,1,3))
;
DOM(DFN) ; Is the veteran in a domiciliary?
; Input: DFN - Pointer to the patient in file #2
; Output: 0 - Vet is not in a domiciliary
; 1 - Vet is in a domiciliary
;
N VAIN,VA,VAERR
D INP^VADPT
Q $P($G(^DIC(42,+$G(VAIN(4)),0)),"^",3)="D"
;
CONFADD() ; Determine, does the patient have a Confidential Address.
; Input: VAPA() local array (by ADD^VADPT)
I '$G(VAPA(12)) Q 0 ; The Conf Address is not active
I $P($G(VAPA(22,3)),U,3)'="Y" Q 0 ; The Conf Address is not valid for billing-related correspondence
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEL 4289 printed Dec 13, 2024@02:07:14 Page 2
IBARXEL ;ALB/CPM - RX COPAY EXEMPTION INCOME TEST REMINDERS ;22-MAR-95
+1 ;;2.0;INTEGRATED BILLING;**34,139,206,217,385**;21-MAR-94;Build 35
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; Entry point for the generation of income test reminder letters.
+1 ; Invoked by the nightly IB Background job (routine IBAMTC).
+2 ;
+3 ; - check the job parameters
+4 SET IBLET=$ORDER(^IBE(354.6,"B","IB INCOME TEST REMINDER",0))
IF 'IBLET
GOTO ENQ
+5 SET IBLET0=$GET(^IBE(354.6,IBLET,0))
+6 SET IBDEV=$PIECE(IBLET0,"^",5)
IF IBDEV=""
GOTO ENQ
+7 SET IBREPR=$PIECE(IBLET0,"^",7)
+8 ;
+9 ; - should the job run tonight?
+10 DO NOW^%DTC
SET IBDAT=%
+11 SET IBDAY=$$DOW^XLFDT(IBDAT\1,1)
+12 IF $EXTRACT(IBDAT,8,17)>.17
SET IBDAY=$SELECT(IBDAY=6:0,1:IBDAY+1)
+13 IF $PIECE(IBLET0,"^",6)'[IBDAY
GOTO ENQ
+14 ;
+15 ; - who needs a letter?
+16 SET IBSTART=$$FMADD^XLFDT(IBDAT\1,-366)
+17 SET IBEND=$$FMADD^XLFDT(IBDAT\1,-305)
+18 ;
+19 KILL ^TMP("IBEX",$JOB)
+20 SET IBD=IBSTART
FOR
SET IBD=$ORDER(^IBA(354.1,"B",IBD))
if 'IBD!(IBD>IBEND)
QUIT
Begin DoDot:1
+21 SET IBEX=0
FOR
SET IBEX=$ORDER(^IBA(354.1,"B",IBD,IBEX))
if 'IBEX
QUIT
Begin DoDot:2
+22 SET IBEXD=$GET(^IBA(354.1,IBEX,0))
if 'IBEXD
QUIT
+23 ;
+24 ; - don't reprint letter unless requested
+25 SET IBLASTPR=$PIECE(IBEXD,"^",16)
+26 IF IBREPR
IF IBLASTPR
IF IBLASTPR'=IBREPR
QUIT
+27 IF 'IBREPR
IF IBLASTPR
QUIT
+28 ;
+29 ; not a copay exemption
if $PIECE(IBEXD,"^",3)'=1
QUIT
+30 ; exemption is not active
if '$PIECE(IBEXD,"^",10)
QUIT
+31 ;
+32 SET IBEXREA=$$ACODE^IBARXEU0(IBEXD)
+33 ; exemption is not based on income
IF IBEXREA'=110
IF IBEXREA'=120
QUIT
+34 ;
+35 ; -- veteran income test excempt from expiration under VFA rules
+36 if $$VFAOK^IBARXEU(IBEXD)
QUIT
+37 ;
+38 SET DFN=+$PIECE(IBEXD,"^",2)
+39 ; vet is cat c or pend. adj. & agreed to pay deductible
if $$BIL^DGMTUB(DFN,IBD)
QUIT
+40 ; vet is in a dom
IF $PIECE(IBLET0,"^",8)
IF $$DOM(DFN)
QUIT
+41 ; vet is deceased
if $GET(^DPT(DFN,.35))
QUIT
+42 ; exemption not current
IF +IBEXD'=$PIECE($GET(^IBA(354,DFN,0)),"^",3)
QUIT
+43 ; vet already getting letter
if $DATA(^TMP("IBEX",$JOB,"V",DFN))
QUIT
+44 ;
+45 ; - sort letters by zip code
+46 KILL VA,VAERR,VAPA
DO ADD^VADPT
+47 SET IBZIP=$PIECE(VAPA($SELECT($$CONFADD():18,1:11)),"^",2)
if IBZIP=""
SET IBZIP="99999-9999"
+48 if '$PIECE(IBZIP,"-",2)
SET IBZIP=$EXTRACT(IBZIP,1,5)_"-0000"
+49 SET ^TMP("IBEX",$JOB,"V",DFN)=""
+50 SET ^TMP("IBEX",$JOB,"L",IBZIP,IBEX)=+IBEXD_"^"_+$PIECE(IBEXD,"^",4)_"^"_DFN
End DoDot:2
End DoDot:1
+51 ;
+52 ; - open a print device if necessary
+53 IF '$DATA(^TMP("IBEX",$JOB,"L"))
GOTO ENQ
+54 SET IOP=IBDEV
DO ^%ZIS
IF POP
GOTO ENQ
+55 USE IO
+56 ;
+57 ; - print the letters
+58 SET IBSCR=""
FOR
SET IBSCR=$ORDER(^TMP("IBEX",$JOB,"L",IBSCR))
if IBSCR=""
QUIT
Begin DoDot:1
+59 SET IBEX=0
FOR
SET IBEX=$ORDER(^TMP("IBEX",$JOB,"L",IBSCR,IBEX))
if 'IBEX
QUIT
DO PRINT
End DoDot:1
+60 ;
ENQ IF $GET(IBREPR)
IF IBLET
SET DA=IBLET
SET DIE="^IBE(354.6,"
SET DR=".07////@"
DO ^DIE
KILL DA,DR,DIE
+1 ;
+2 DO ^%ZISC
+3 KILL ^TMP("IBEX",$JOB),DFN,VAPA,VA,VAERR,X
+4 KILL IBD,IBEX,IBEXD,IBEXREA,IBDAT,IBDAY,IBDEV,IBZIP,IBLET0,IBREPR,IBQUIT
+5 KILL IBEND,IBLET,IBSTART,IBSCR,IBEXPD,IBDATA,IBNAM,IBALIN,IBLASTPR
+6 QUIT
+7 ;
+8 ;
PRINT ; Print a reminder letter.
+1 ; Required variable input:
+2 ; IBEX -- Pointer to exemption in file #354.1
+3 ; IBLET -- Pointer to the reminder letter in file #354.6
+4 ;
+5 ; - set letter variables
+6 SET IBEXD=$GET(^IBA(354.1,+IBEX,0))
+7 SET IBEXPD=$$DATE($$PLUS^IBARXEU0(+IBEXD))
+8 ;S IBEXPD=$$DATE($$FMADD^XLFDT(+IBEXD,365))
+9 SET DFN=+$PIECE(IBEXD,"^",2)
SET IBQUIT=0
+10 SET IBDATA=$$PT^IBEFUNC(DFN)
SET IBNAM=$PIECE(IBDATA,"^")
+11 SET IBALIN=$PIECE($GET(^IBE(354.6,IBLET,0)),"^",4)
+12 IF IBALIN<10!(IBALIN>25)
SET IBALIN=15
+13 ;
+14 ; - print letter
+15 DO ONE^IBARXEPL
+16 ;
+17 ; - update the exemption
+18 SET DA=IBEX
SET DIE="^IBA(354.1,"
SET DR=".16////"_DT
DO ^DIE
KILL DA,DR,DIE
+19 KILL IBEXD,TAB,IBCNTL,IB,IBCNT,IBX,VAPA,VA,VAERR
+20 QUIT
+21 ;
+22 ;
DATE(X) ; Format the exemption expiration date.
+1 NEW A
SET A="January^February^March^April^May^June^July^August^September^October^November^December"
+2 QUIT $PIECE(A,"^",+$EXTRACT(X,4,5))_" "_+$EXTRACT(X,6,7)_", "_(1700+$EXTRACT(X,1,3))
+3 ;
DOM(DFN) ; Is the veteran in a domiciliary?
+1 ; Input: DFN - Pointer to the patient in file #2
+2 ; Output: 0 - Vet is not in a domiciliary
+3 ; 1 - Vet is in a domiciliary
+4 ;
+5 NEW VAIN,VA,VAERR
+6 DO INP^VADPT
+7 QUIT $PIECE($GET(^DIC(42,+$GET(VAIN(4)),0)),"^",3)="D"
+8 ;
CONFADD() ; Determine, does the patient have a Confidential Address.
+1 ; Input: VAPA() local array (by ADD^VADPT)
+2 ; The Conf Address is not active
IF '$GET(VAPA(12))
QUIT 0
+3 ; The Conf Address is not valid for billing-related correspondence
IF $PIECE($GET(VAPA(22,3)),U,3)'="Y"
QUIT 0
+4 QUIT 1
