Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXEL

IBARXEL.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. EN ; Entry point for the generation of income test reminder letters.
  1. ; Invoked by the nightly IB Background job (routine IBAMTC).
  1. ;
  1. ; - check the job parameters
  1. S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0)) I 'IBLET G ENQ
  1. S IBLET0=$G(^IBE(354.6,IBLET,0))
  1. S IBDEV=$P(IBLET0,"^",5) I IBDEV="" G ENQ
  1. S IBREPR=$P(IBLET0,"^",7)
  1. ;
  1. ; - should the job run tonight?
  1. D NOW^%DTC S IBDAT=%
  1. S IBDAY=$$DOW^XLFDT(IBDAT\1,1)
  1. I $E(IBDAT,8,17)>.17 S IBDAY=$S(IBDAY=6:0,1:IBDAY+1)
  1. I $P(IBLET0,"^",6)'[IBDAY G ENQ
  1. ;
  1. ; - who needs a letter?
  1. S IBSTART=$$FMADD^XLFDT(IBDAT\1,-366)
  1. S IBEND=$$FMADD^XLFDT(IBDAT\1,-305)
  1. ;
  1. K ^TMP("IBEX",$J)
  1. S IBD=IBSTART F S IBD=$O(^IBA(354.1,"B",IBD)) Q:'IBD!(IBD>IBEND) D
  1. .S IBEX=0 F S IBEX=$O(^IBA(354.1,"B",IBD,IBEX)) Q:'IBEX D
  1. ..S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
  1. ..;
  1. ..; - don't reprint letter unless requested
  1. ..S IBLASTPR=$P(IBEXD,"^",16)
  1. ..I IBREPR,IBLASTPR,IBLASTPR'=IBREPR Q
  1. ..I 'IBREPR,IBLASTPR Q
  1. ..;
  1. ..Q:$P(IBEXD,"^",3)'=1 ; not a copay exemption
  1. ..Q:'$P(IBEXD,"^",10) ; exemption is not active
  1. ..;
  1. ..S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
  1. ..I IBEXREA'=110,IBEXREA'=120 Q ; exemption is not based on income
  1. ..;
  1. ..; -- veteran income test excempt from expiration under VFA rules
  1. ..Q:$$VFAOK^IBARXEU(IBEXD)
  1. ..;
  1. ..S DFN=+$P(IBEXD,"^",2)
  1. ..Q:$$BIL^DGMTUB(DFN,IBD) ; vet is cat c or pend. adj. & agreed to pay deductible
  1. ..I $P(IBLET0,"^",8),$$DOM(DFN) Q ; vet is in a dom
  1. ..Q:$G(^DPT(DFN,.35)) ; vet is deceased
  1. ..I +IBEXD'=$P($G(^IBA(354,DFN,0)),"^",3) Q ; exemption not current
  1. ..Q:$D(^TMP("IBEX",$J,"V",DFN)) ; vet already getting letter
  1. ..;
  1. ..; - sort letters by zip code
  1. ..K VA,VAERR,VAPA D ADD^VADPT
  1. ..S IBZIP=$P(VAPA($S($$CONFADD():18,1:11)),"^",2) S:IBZIP="" IBZIP="99999-9999"
  1. ..S:'$P(IBZIP,"-",2) IBZIP=$E(IBZIP,1,5)_"-0000"
  1. ..S ^TMP("IBEX",$J,"V",DFN)=""
  1. ..S ^TMP("IBEX",$J,"L",IBZIP,IBEX)=+IBEXD_"^"_+$P(IBEXD,"^",4)_"^"_DFN
  1. ;
  1. ; - open a print device if necessary
  1. I '$D(^TMP("IBEX",$J,"L")) G ENQ
  1. S IOP=IBDEV D ^%ZIS I POP G ENQ
  1. U IO
  1. ;
  1. ; - print the letters
  1. S IBSCR="" F S IBSCR=$O(^TMP("IBEX",$J,"L",IBSCR)) Q:IBSCR="" D
  1. .S IBEX=0 F S IBEX=$O(^TMP("IBEX",$J,"L",IBSCR,IBEX)) Q:'IBEX D PRINT
  1. ;
  1. ENQ I $G(IBREPR),IBLET S DA=IBLET,DIE="^IBE(354.6,",DR=".07////@" D ^DIE K DA,DR,DIE
  1. ;
  1. D ^%ZISC
  1. K ^TMP("IBEX",$J),DFN,VAPA,VA,VAERR,X
  1. K IBD,IBEX,IBEXD,IBEXREA,IBDAT,IBDAY,IBDEV,IBZIP,IBLET0,IBREPR,IBQUIT
  1. K IBEND,IBLET,IBSTART,IBSCR,IBEXPD,IBDATA,IBNAM,IBALIN,IBLASTPR
  1. Q
  1. ;
  1. ;
  1. PRINT ; Print a reminder letter.
  1. ; Required variable input:
  1. ; IBEX -- Pointer to exemption in file #354.1
  1. ; IBLET -- Pointer to the reminder letter in file #354.6
  1. ;
  1. ; - set letter variables
  1. S IBEXD=$G(^IBA(354.1,+IBEX,0))
  1. S IBEXPD=$$DATE($$PLUS^IBARXEU0(+IBEXD))
  1. ;S IBEXPD=$$DATE($$FMADD^XLFDT(+IBEXD,365))
  1. S DFN=+$P(IBEXD,"^",2),IBQUIT=0
  1. S IBDATA=$$PT^IBEFUNC(DFN),IBNAM=$P(IBDATA,"^")
  1. S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
  1. I IBALIN<10!(IBALIN>25) S IBALIN=15
  1. ;
  1. ; - print letter
  1. D ONE^IBARXEPL
  1. ;
  1. ; - update the exemption
  1. S DA=IBEX,DIE="^IBA(354.1,",DR=".16////"_DT D ^DIE K DA,DR,DIE
  1. K IBEXD,TAB,IBCNTL,IB,IBCNT,IBX,VAPA,VA,VAERR
  1. Q
  1. ;
  1. ;
  1. DATE(X) ; Format the exemption expiration date.
  1. N A S A="January^February^March^April^May^June^July^August^September^October^November^December"
  1. Q $P(A,"^",+$E(X,4,5))_" "_+$E(X,6,7)_", "_(1700+$E(X,1,3))
  1. ;
  1. DOM(DFN) ; Is the veteran in a domiciliary?
  1. ; Input: DFN - Pointer to the patient in file #2
  1. ; Output: 0 - Vet is not in a domiciliary
  1. ; 1 - Vet is in a domiciliary
  1. ;
  1. N VAIN,VA,VAERR
  1. D INP^VADPT
  1. Q $P($G(^DIC(42,+$G(VAIN(4)),0)),"^",3)="D"
  1. ;
  1. CONFADD() ; Determine, does the patient have a Confidential Address.
  1. ; Input: VAPA() local array (by ADD^VADPT)
  1. I '$G(VAPA(12)) Q 0 ; The Conf Address is not active
  1. I $P($G(VAPA(22,3)),U,3)'="Y" Q 0 ; The Conf Address is not valid for billing-related correspondence
  1. Q 1