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