IBARXEC5 ;ALB/AAS - RX COPAY EXEMPTION CONVERSION REPORT PRINT ; 14-JAN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% ;
PRINT ; -- Print report
S IBPAG=0,IBQUIT=0 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y
K IBBCNT
D HDR
I '$D(^TMP("IBCONV",$J)) W !,"No Charges Canceled due to Income Exemption in date range." Q
S IBNAM="",(IBPCNT,IBTAMT,IBTCNT)=0
F S IBNAM=$O(^TMP("IBCONV",$J,IBNAM)) Q:IBNAM=""!(IBQUIT) D
.S DFN=0 F S DFN=$O(^TMP("IBCONV",$J,IBNAM,DFN)) Q:'DFN!(IBQUIT) S IBPCNT=IBPCNT+1 D
..S (IBBCNT,IBAMT,IBN)=0 F S IBN=$O(^TMP("IBCONV",$J,IBNAM,DFN,IBN)) D:IBN="" SUB Q:'IBN!(IBQUIT) S X2=^(IBN) D ONE
;
D:'IBQUIT SUM
K ^TMP("IBCONV",$J)
Q
;
ONE ; -- print one line
I ($Y+5)>IOSL D PAUSE^IBOUTL,HDR:'IBQUIT
W ! I 'IBBCNT W $E(IBNAM,1,20),?22,$P(X2,"^",2) S ERR="" D ERR I ERR]"" W ?36,ERR,!
;
S N=$G(^IB(IBN,0)),N1=$G(^(1)) ; new copay nodes
S O=$G(^IB(+$P(N,"^",9),0)),O1=$G(^(1)) ; original copay nodes
S IBBCNT=IBBCNT+1,IBAMT=IBAMT+$P(N,"^",7),IBTAMT=IBTAMT+$P(N,"^",7),IBTCNT=IBTCNT+1
;
W ?36,$$DAT1^IBOUTL($P(O1,"^",2))
;
S Y=+$P($P($P(O,"^",4),";",2),":",2)
W $J($P($P(O,"^",8),"-"),9),$S(+Y:"/"_Y,1:"")
W ?57,$$DAT1^IBOUTL($P(N1,"^",2)),?68,+N,?81,$P(N,"^",11),?97,"$",$P(N,"^",7)
Q
;
HDR ; -- print header
I $D(IBCONVER)!($G(IBQUIC))!(IBPAG)!($E(IOST,1,2)="C-") W @IOF
S IBPAG=IBPAG+1
W "Rx Copay Income Exemption Report",?(IOM-35)
W $P(IBPDAT,"@")," ",$P(IBPDAT,"@",2)," Page ",IBPAG
W !,"Charges Canceled ",$S(IBBDT=IBEDT:"on "_$$DAT1^IBOUTL(IBBDT),1:"from "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT))
W !," Cancel Cancel Original"
W !,"Name Pt. ID Rx Date Rx/Refill Date IB Number Bill No. Amount"
W !,$TR($J(" ",IOM)," ","-")
Q
;
SUB ; -- write sub totals
W !,?85,"--------------"
W !,?85,"Count = ",$J(IBBCNT,4)
W !,?85,"Amount = $",$J(IBAMT,4),!
Q
;
SUM ; -- print final summary
W !!?40,"======================================="
W !?40," Total Patient Count = ",$J(IBPCNT,7)
W !?40," Total Rx Count = ",$J(IBTCNT,7)
W !?40," Total Dollar amount = $",$J(IBTAMT,7)
Q
;
ERR ; -- see if any errors
N DJ S DJ=""
F S DJ=$O(^TMP("IB-ERROR",DJ)) Q:DJ="" S ERR=$G(^TMP("IB-ERROR",DJ,DFN)) Q:ERR]""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEC5 2440 printed Apr 09, 2024@21:28:46 Page 2
IBARXEC5 ;ALB/AAS - RX COPAY EXEMPTION CONVERSION REPORT PRINT ; 14-JAN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% ;
PRINT ; -- Print report
+1 SET IBPAG=0
SET IBQUIT=0
DO NOW^%DTC
SET Y=%
DO D^DIQ
SET IBPDAT=Y
+2 KILL IBBCNT
+3 DO HDR
+4 IF '$DATA(^TMP("IBCONV",$JOB))
WRITE !,"No Charges Canceled due to Income Exemption in date range."
QUIT
+5 SET IBNAM=""
SET (IBPCNT,IBTAMT,IBTCNT)=0
+6 FOR
SET IBNAM=$ORDER(^TMP("IBCONV",$JOB,IBNAM))
if IBNAM=""!(IBQUIT)
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("IBCONV",$JOB,IBNAM,DFN))
if 'DFN!(IBQUIT)
QUIT
SET IBPCNT=IBPCNT+1
Begin DoDot:2
+8 SET (IBBCNT,IBAMT,IBN)=0
FOR
SET IBN=$ORDER(^TMP("IBCONV",$JOB,IBNAM,DFN,IBN))
if IBN=""
DO SUB
if 'IBN!(IBQUIT)
QUIT
SET X2=^(IBN)
DO ONE
End DoDot:2
End DoDot:1
+9 ;
+10 if 'IBQUIT
DO SUM
+11 KILL ^TMP("IBCONV",$JOB)
+12 QUIT
+13 ;
ONE ; -- print one line
+1 IF ($Y+5)>IOSL
DO PAUSE^IBOUTL
if 'IBQUIT
DO HDR
+2 WRITE !
IF 'IBBCNT
WRITE $EXTRACT(IBNAM,1,20),?22,$PIECE(X2,"^",2)
SET ERR=""
DO ERR
IF ERR]""
WRITE ?36,ERR,!
+3 ;
+4 ; new copay nodes
SET N=$GET(^IB(IBN,0))
SET N1=$GET(^(1))
+5 ; original copay nodes
SET O=$GET(^IB(+$PIECE(N,"^",9),0))
SET O1=$GET(^(1))
+6 SET IBBCNT=IBBCNT+1
SET IBAMT=IBAMT+$PIECE(N,"^",7)
SET IBTAMT=IBTAMT+$PIECE(N,"^",7)
SET IBTCNT=IBTCNT+1
+7 ;
+8 WRITE ?36,$$DAT1^IBOUTL($PIECE(O1,"^",2))
+9 ;
+10 SET Y=+$PIECE($PIECE($PIECE(O,"^",4),";",2),":",2)
+11 WRITE $JUSTIFY($PIECE($PIECE(O,"^",8),"-"),9),$SELECT(+Y:"/"_Y,1:"")
+12 WRITE ?57,$$DAT1^IBOUTL($PIECE(N1,"^",2)),?68,+N,?81,$PIECE(N,"^",11),?97,"$",$PIECE(N,"^",7)
+13 QUIT
+14 ;
HDR ; -- print header
+1 IF $DATA(IBCONVER)!($GET(IBQUIC))!(IBPAG)!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET IBPAG=IBPAG+1
+3 WRITE "Rx Copay Income Exemption Report",?(IOM-35)
+4 WRITE $PIECE(IBPDAT,"@")," ",$PIECE(IBPDAT,"@",2)," Page ",IBPAG
+5 WRITE !,"Charges Canceled ",$SELECT(IBBDT=IBEDT:"on "_$$DAT1^IBOUTL(IBBDT),1:"from "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT))
+6 WRITE !," Cancel Cancel Original"
+7 WRITE !,"Name Pt. ID Rx Date Rx/Refill Date IB Number Bill No. Amount"
+8 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+9 QUIT
+10 ;
SUB ; -- write sub totals
+1 WRITE !,?85,"--------------"
+2 WRITE !,?85,"Count = ",$JUSTIFY(IBBCNT,4)
+3 WRITE !,?85,"Amount = $",$JUSTIFY(IBAMT,4),!
+4 QUIT
+5 ;
SUM ; -- print final summary
+1 WRITE !!?40,"======================================="
+2 WRITE !?40," Total Patient Count = ",$JUSTIFY(IBPCNT,7)
+3 WRITE !?40," Total Rx Count = ",$JUSTIFY(IBTCNT,7)
+4 WRITE !?40," Total Dollar amount = $",$JUSTIFY(IBTAMT,7)
+5 QUIT
+6 ;
ERR ; -- see if any errors
+1 NEW DJ
SET DJ=""
+2 FOR
SET DJ=$ORDER(^TMP("IB-ERROR",DJ))
if DJ=""
QUIT
SET ERR=$GET(^TMP("IB-ERROR",DJ,DFN))
if ERR]""
QUIT
+3 QUIT
