- 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 Jan 18, 2025@03:08:28 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