IBARXEL1 ;ALB/CPM - RX COPAY EXEMPTION REMINDER REPRINT ;14-APR-95
;;2.0;INTEGRATED BILLING;**34,199,217,385**;21-MAR-94;Build 35
;;Per VHA Directive 2004-038, this routine should not be modified.
;
REPR ; Reprint a single income test reminder letter.
S IBLET=$O(^IBE(354.6,"B","IB INCOME TEST REMINDER",0))
I 'IBLET W !!,"You do not have the Income Test Reminder letter defined!" G REPRQ
;
S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQMZ",DIC("A")="Select BILLING PATIENT: "
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
D ^DIC K DIC S DFN=+Y G:Y<0 REPRQ
;
; - find the most recent active exemption
S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0))
S IBEXD=$G(^IBA(354.1,IBEX,0))
I 'IBEXD W !!,"This veteran has never had an active copayment exemption status!" G REPR
;
I $G(^DPT(DFN,.35)) W !!,*7,"Please note that this veteran died on ",$$DAT1^IBOUTL(+^(.35)),"."
;
; - VFA exemption - print not allowed
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
;
; - display the veteran's current exemption status
S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
W !!,$TR($J("",80)," ","=")
W !?10,"Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4))," (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
W !?12,"Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
;
; - display the previous status if the veteran has not reported income
I IBEXREA=210 D
.S IBCHK=1
.S IBEX=+$O(^(+$O(^IBA(354.1,"AIVDT",1,DFN,-IBEXD)),0))
.S IBEXD=$G(^IBA(354.1,IBEX,0)) Q:'IBEXD
.S IBEXREA=$$ACODE^IBARXEU0(IBEXD)
.W !!?4,"Prior Exemption Status: ",$$TEXT^IBARXEU0(+$P(IBEXD,"^",4))," (",$P($G(^IBE(354.2,+$P(IBEXD,"^",5),0)),"^"),")"
.W !?6,"Prior Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
;
; - if a letter has already been printed, display the print date
I $P(IBEXD,"^",16) D
.W !!?12,"Letter Printed: ",$$DAT1^IBOUTL($P(IBEXD,"^",16))
.S X=$P($$LST^DGMTCOU1(DFN,$$FMADD^XLFDT(DT,60),3),"^",2)
.W ?41,"Current Income Test Date: ",$S(X:$$DAT1^IBOUTL(X),1:"<none>")
W !,$TR($J("",80)," ","=")
;
; - exemption must be based on income
I IBEXREA'=110,IBEXREA'=120 W !!,"You may only generate a letter for an exemption based on income!",! K IBCHK G REPR
;
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!"
;
; check for Cat C or Pending Adj. and has agreed to pay deductible
I $$BIL^DGMTUB(DFN,DT) W !!,"**Please note that this veteran no longer requires a Means Test**"
;
; - okay to print letter?
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.'"
W ! D ^DIR K DIR,DIRUT,DTOUT,DUOUT,DIROUT I 'Y G REPRQ
;
W !!,"*** Please note that the reminder letter prints in 80 columns. ***",!
S %ZIS="QM" D ^%ZIS G:POP REPRQ
I $D(IO("Q")) D G REPRQ
.S ZTRTN="DQ^IBARXEL1",ZTDESC="IB - PRINT INCOME TEST REMINDER LETTER"
.F I="IBEX","IBLET" S ZTSAVE(I)=""
.D ^%ZTLOAD K IO("Q") D HOME^%ZIS
.W !!,$S($D(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q")
;
U IO
;
DQ ; Queued entry point.
D PRINT^IBARXEL
I $D(ZTQUEUED) S ZTREQ="@" Q
;
REPRQ D ^%ZISC
K DFN,IBLET,IBEX,IBEXD,IBEXREA,IBCHK,IBEXPD,IBQUIT,IBDATA,IBNAM,IBALIN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEL1 3469 printed Dec 13, 2024@02:07:15 Page 2
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
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
REPR ; Reprint a single income test reminder letter.
+1 SET IBLET=$ORDER(^IBE(354.6,"B","IB INCOME TEST REMINDER",0))
+2 IF 'IBLET
WRITE !!,"You do not have the Income Test Reminder letter defined!"
GOTO REPRQ
+3 ;
+4 SET DIC="^DPT("
SET DIC("S")="I $D(^IBA(354,+Y,0))"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select BILLING PATIENT: "
+5 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+6 DO ^DIC
KILL DIC
SET DFN=+Y
if Y<0
GOTO REPRQ
+7 ;
+8 ; - find the most recent active exemption
+9 SET IBEX=+$ORDER(^(+$ORDER(^IBA(354.1,"AIVDT",1,DFN,-(DT+.00001))),0))
+10 SET IBEXD=$GET(^IBA(354.1,IBEX,0))
+11 IF 'IBEXD
WRITE !!,"This veteran has never had an active copayment exemption status!"
GOTO REPR
+12 ;
+13 IF $GET(^DPT(DFN,.35))
WRITE !!,*7,"Please note that this veteran died on ",$$DAT1^IBOUTL(+^(.35)),"."
+14 ;
+15 ; - VFA exemption - print not allowed
+16 IF $$VFAOK^IBARXEU(IBEXD)
WRITE !!,"This veteran's current exemption is based on a Means Test and a new test is not required."
GOTO REPR
+17 ;
+18 ; - display the veteran's current exemption status
+19 SET IBEXREA=$$ACODE^IBARXEU0(IBEXD)
+20 WRITE !!,$TRANSLATE($JUSTIFY("",80)," ","=")
+21 WRITE !?10,"Exemption Status: ",$$TEXT^IBARXEU0(+$PIECE(IBEXD,"^",4))," (",$PIECE($GET(^IBE(354.2,+$PIECE(IBEXD,"^",5),0)),"^"),")"
+22 WRITE !?12,"Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
+23 ;
+24 ; - display the previous status if the veteran has not reported income
+25 IF IBEXREA=210
Begin DoDot:1
+26 SET IBCHK=1
+27 SET IBEX=+$ORDER(^(+$ORDER(^IBA(354.1,"AIVDT",1,DFN,-IBEXD)),0))
+28 SET IBEXD=$GET(^IBA(354.1,IBEX,0))
if 'IBEXD
QUIT
+29 SET IBEXREA=$$ACODE^IBARXEU0(IBEXD)
+30 WRITE !!?4,"Prior Exemption Status: ",$$TEXT^IBARXEU0(+$PIECE(IBEXD,"^",4))," (",$PIECE($GET(^IBE(354.2,+$PIECE(IBEXD,"^",5),0)),"^"),")"
+31 WRITE !?6,"Prior Exemption Date: ",$$DAT1^IBOUTL(+IBEXD)
End DoDot:1
+32 ;
+33 ; - if a letter has already been printed, display the print date
+34 IF $PIECE(IBEXD,"^",16)
Begin DoDot:1
+35 WRITE !!?12,"Letter Printed: ",$$DAT1^IBOUTL($PIECE(IBEXD,"^",16))
+36 SET X=$PIECE($$LST^DGMTCOU1(DFN,$$FMADD^XLFDT(DT,60),3),"^",2)
+37 WRITE ?41,"Current Income Test Date: ",$SELECT(X:$$DAT1^IBOUTL(X),1:"<none>")
End DoDot:1
+38 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","=")
+39 ;
+40 ; - exemption must be based on income
+41 IF IBEXREA'=110
IF IBEXREA'=120
WRITE !!,"You may only generate a letter for an exemption based on income!",!
KILL IBCHK
GOTO REPR
+42 ;
+43 IF '$GET(IBCHK)
IF +IBEXD>$$FMADD^XLFDT(DT,-305)
WRITE !!,"Please note that this exemption is not due to expire for ",$$FMDIFF^XLFDT(+IBEXD+10000,DT)," days!"
+44 ;
+45 ; check for Cat C or Pending Adj. and has agreed to pay deductible
+46 IF $$BIL^DGMTUB(DFN,DT)
WRITE !!,"**Please note that this veteran no longer requires a Means Test**"
+47 ;
+48 ; - okay to print letter?
+49 SET DIR(0)="Y"
SET DIR("A")="Okay to print the reminder letter"
SET DIR("?")="To print the income test reminder letter, answer 'YES.' Otherwise, answer 'NO.'"
+50 WRITE !
DO ^DIR
KILL DIR,DIRUT,DTOUT,DUOUT,DIROUT
IF 'Y
GOTO REPRQ
+51 ;
+52 WRITE !!,"*** Please note that the reminder letter prints in 80 columns. ***",!
+53 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO REPRQ
+54 IF $DATA(IO("Q"))
Begin DoDot:1
+55 SET ZTRTN="DQ^IBARXEL1"
SET ZTDESC="IB - PRINT INCOME TEST REMINDER LETTER"
+56 FOR I="IBEX","IBLET"
SET ZTSAVE(I)=""
+57 DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
+58 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued as task #"_ZTSK_".",1:"Unable to queue this job.")
+59 KILL ZTSK,IO("Q")
End DoDot:1
GOTO REPRQ
+60 ;
+61 USE IO
+62 ;
DQ ; Queued entry point.
+1 DO PRINT^IBARXEL
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 ;
REPRQ DO ^%ZISC
+1 KILL DFN,IBLET,IBEX,IBEXD,IBEXREA,IBCHK,IBEXPD,IBQUIT,IBDATA,IBNAM,IBALIN
+2 QUIT
