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

IBARXEL1.m

Go to the documentation of this file. 
  1. IBARXEL1 ;ALB/CPM - RX COPAY EXEMPTION REMINDER REPRINT ;14-APR-95
  1.  ;;2.0;INTEGRATED BILLING;**34,199,217,385**;21-MAR-94;Build 35
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. REPR ; Reprint a single income test reminder letter.
  1.  S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0))
  1.  I 'IBLET W !!,"You do not have the Income Test Reminder letter defined!" G REPRQ
  1.  ;
  1.  S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQMZ",DIC("A")="Select BILLING PATIENT: "
  1.  N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
  1.  D ^DIC K DIC S DFN=+Y G:Y<0 REPRQ
  1.  ;
  1.  ; - find the most recent active exemption
  1.  S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0))
  1.  S IBEXD=$G(^IBA(354.1,IBEX,0))
  1.  I 'IBEXD W !!,"This veteran has never had an active copayment exemption status!" G REPR
  1.  ;
  1.  I $G(^DPT(DFN,.35)) W !!,*7,"Please note that this veteran died on ",$$DAT1^IBOUTL(+^(.35)),"."
  1.  ;
  1.  ; - VFA exemption - print not allowed
  1.  I $$VFAOK^IBARXEU(IBEXD) W !!,"This veteran's current exemption is based on a Means Test and a new test is not required." G REPR
  1.  ;
  1.  ; - display the veteran's current exemption status
  1.  S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
  1.  W !!,$TR($J("",80)," ","=")
  1.  W !?10,"Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4)),"  (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
  1.  W !?12,"Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
  1.  ;
  1.  ; - display the previous status if the veteran has not reported income
  1.  I IBEXREA=210 D
  1.  .S IBCHK=1
  1.  .S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-IBEXD)),0))
  1.  .S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
  1.  .S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
  1.  .W !!?4,"Prior Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4)),"  (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
  1.  .W !?6,"Prior Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
  1.  ;
  1.  ; - if a letter has already been printed, display the print date
  1.  I $P(IBEXD,"^",16) D
  1.  .W !!?12,"Letter Printed: ",$$DAT1^IBOUTL($P(IBEXD,"^",16))
  1.  .S X=$P($$LST^DGMTCOU1(DFN,$$FMADD^XLFDT(DT,60),3),"^",2)
  1.  .W ?41,"Current Income Test Date: ",$S(X:$$DAT1^IBOUTL(X),1:"<none>")
  1.  W !,$TR($J("",80)," ","=")
  1.  ;
  1.  ; - exemption must be based on income
  1.  I IBEXREA'=110,IBEXREA'=120 W !!,"You may only generate a letter for an exemption based on income!",! K IBCHK G REPR
  1.  ;
  1.  I '$G(IBCHK),+IBEXD>$$FMADD^XLFDT(DT,-305) W !!,"Please note that this exemption is not due to expire for ",$$FMDIFF^XLFDT(+IBEXD+10000,DT)," days!"
  1.  ;
  1.  ; check for Cat C or Pending Adj. and has agreed to pay deductible
  1.  I $$BIL^DGMTUB(DFN,DT) W !!,"**Please note that this veteran no longer requires a Means Test**"
  1.  ;
  1.  ; - okay to print letter?
  1.  S DIR(0)="Y",DIR("A")="Okay to print the reminder letter",DIR("?")="To print the income test reminder letter, answer 'YES.'  Otherwise, answer 'NO.'"
  1.  W ! D ^DIR K DIR,DIRUT,DTOUT,DUOUT,DIROUT I 'Y G REPRQ
  1.  ;
  1.  W !!,"*** Please note that the reminder letter prints in 80 columns. ***",!
  1.  S %ZIS="QM" D ^%ZIS G:POP REPRQ
  1.  I $D(IO("Q")) D  G REPRQ
  1.  .S ZTRTN="DQ^IBARXEL1",ZTDESC="IB - PRINT INCOME TEST REMINDER LETTER"
  1.  .F I="IBEX","IBLET" S ZTSAVE(I)=""
  1.  .D ^%ZTLOAD K IO("Q") D HOME^%ZIS
  1.  .W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
  1.  .K ZTSK,IO("Q")
  1.  ;
  1.  U IO
  1.  ;
  1. DQ ; Queued entry point.
  1.  D PRINT^IBARXEL
  1.  I $D(ZTQUEUED) S ZTREQ="@" Q
  1.  ;
  1. REPRQ D ^%ZISC
  1.  K DFN,IBLET,IBEX,IBEXD,IBEXREA,IBCHK,IBEXPD,IBQUIT,IBDATA,IBNAM,IBALIN
  1.  Q