IBOTR3 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - OUTPUT ;5-JUN-91
;;2.0;INTEGRATED BILLING;**42,80,100,118,128,133,447,516,528,529,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCROTR3
;
EN(IBDIV) ; - Entry point from IBOTR2.
;
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
; - Extract zero totals if no data available.
;I $G(IBXTRACT),'$D(^TMP($J,"IBOTR",IBDIV)) D G END
I $G(IBXTRACT),'$D(^TMP($J,"IBOTR",IBDIV)) D D EOR G END ;IB*752/DTG
.S IBUNPD=0 F X=1:1:8 S IBTT(X)=0
.D E^IBJDE(8,0)
;
I $G(IBXTRACT) G IBX ; Calculate grand totals for extract.
;
S IBPAG=0,IBLINE="",$P(IBLINE,"-",IOM)="-",Y=DT D D^DIQ S IBTDT=Y
I $D(IBAF) D ADDFLD^IBOTR4
;I '$D(^TMP($J,"IBOTR",IBDIV)) D S IBCALC=3 D PAUSE G END
I '$D(^TMP($J,"IBOTR",IBDIV)) D S IBCALC=3 D EOR,PAUSE G END ;IB*752/DTG
.S IBX=$S("Bb"'[IBBRT:IBBRT,IBBRN="C":"A",1:"I")
.;IB*752/DTG do correct header for excel
.;D HDR W !!," NO INFORMATION MATCHES SELECTION CRITERIA."
.I IBOUT="E" D EXCHDR
.I IBOUT="R" D HDR
.W !!," NO INFORMATION MATCHES SELECTION CRITERIA."
;
IBX S IBX="" F S IBX=$O(^TMP($J,"IBOTR",IBDIV,IBX)) Q:IBX="" D Q:IBQUIT
.I IBPRNT'="G"!('$G(IBG)) S IBTT="0^0^0^0^0^0^0^0^0^0"
.I IBOUT="E" D EXCHDR
.I IBOUT="R" D:'$G(IBXTRACT) HDR Q:IBQUIT
.D INS
; IB*752/DTG - add pause before leaving report
S IBCALC=3 I '$G(IBQUIT) D EOR,PAUSE
;
END K IBINS,IBPAG,IBLINE,IBTDT,IBX,IBTT,IBTI,IBCALC,IBBN,IBD,IBDS,IBAFT
K IBAMT,IBG,IBI,IBPERC,IBUNPD,X,X1,X2,IBGRP,IBOUT,STOP
K IBBLNO,IBRJFLAG,IBGRPD,INSC
Q
;
;IB*752/DTG - add end of report message
EOR ; end of report
N IBLEN S IBLEN="" I "Rr"[$E(IBOUT,1) S $P(IBLEN," ",59)=" "
W !!,IBLEN_"END OF REPORT"
Q
;
INS ; - Loop through each insurance company or amount.
I IBSORT="I" D
.S IBINS="" F S IBINS=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS)) Q:IBINS="" D BILLNO Q:IBQUIT
I IBSORT'="I" D
.S IBAMT="" F S IBAMT=$O(^TMP($J,"IBOTRS",IBDIV,IBX,IBAMT)) Q:IBAMT="" S IBINS="" F S IBINS=$O(^TMP($J,"IBOTRS",IBDIV,IBX,IBAMT,IBINS)) Q:IBINS=""!(IBQUIT) D BILLNO Q:IBQUIT
;
; - Extract grand totals data.
I $G(IBXTRACT),'IBQUIT D Q
.S IBUNPD=$J($P(IBTT,U,2)-$P(IBTT,U,5),0,2)
.F X=1:1:8 S IBTT(X)=$S(19'[X:$J($P(IBTT,U,X),0,2),1:$P(IBTT,U,X))
.D E^IBJDE(8,0)
;
I 'IBQUIT,'$G(IBG),IBOUT="R" D GTOT^IBOTR4 ; Write grand totals for report.
Q
;
BILLNO ; - Loop through all bills for an insurance company.
I $G(IBXTRACT) G LOOP
I IBOUT="E" S IBDS=0,INSC=$P(IBINS,"@@") G LOOP
I $Y>(IOSL-15) S IBCALC=15 D PAUSE Q:IBQUIT D HDR Q:IBQUIT
I IBPRNT'="G" S IBDS=0,IBTI="0^0^0^0" D INSADD
E I $G(IBG) S IBTT="0^0^0^0^0^0^0^0^0^0" D INSADD
LOOP ; add group# for p447
S IBGRP="" F S IBGRP=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBGRP)) Q:IBGRP=""!(IBQUIT) D
. I IBOUT="E",IBGRP'="" S IBGRPD=$S(IBGRP'=0:$$GET1^DIQ(355.3,IBGRP_",",2.02),1:"None Defined")
. ; IB*2.0*516/TAZ Print the actual group number instead of internal group number.
. I IBOUT="R" I IBPRNT="M" W !!,"Group #: "_$S(IBGRP'=0:$$GET1^DIQ(355.3,IBGRP_",",2.02),1:"None Defined")
. ;
. S IBBN="" F S IBBN=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBGRP,IBBN)) Q:IBBN="" S IBD=^(IBBN) D DETAIL Q:IBQUIT
I IBOUT="E" Q
I 'IBQUIT,IBOUT="R" D
.I IBPRNT'="G" D SUBTOT^IBOTR4 ; Write insurance co. sub-totals.
.E D:$G(IBG) GTOT^IBOTR4 ; Write insurance co. grand totals.
Q
;
DETAIL ; - Write out detail lines.
N IBPEN S IBPEN=$S($P(IBBN,"@@",2)["*":0,1:$P(IBD,U,6)-$P(IBD,U,7))
I IBOUT="E" D EXOUT Q
G:IBPRNT="S" SUBTOT G:IBPRNT="G" GNDTOT
I $Y>(IOSL-7) S IBCALC=7 D PAUSE Q:IBQUIT D HDR Q:IBQUIT D INSADD
;
;IB*2.0*529 Reject flag re-added back to the software.
S IBBLNO=$P($P(IBBN,"@@",2),"*") I IBBLNO["%" S IBBLNO=$P(IBBLNO,"%",2)
S IBRJFLAG=+$$BILLREJ^IBJTU6(IBBLNO),IBRJFLAG=$S(IBRJFLAG=1:"c",1:"")
W !,IBRJFLAG,$P(IBBN,"@@",2),?13,$P(IBBN,"@@"),?35,$$DATE($P(IBD,U,2))
;end IB*2.0*529
W ?44,$$DATE($P(IBD,U,3)),?54,$$DATE($P(IBD,U,4))
W ?64,$S($P(IBD,U,5):$$DATE($P(IBD,U,5)),1:$P(IBD,U,5))
S X1=$S($P(IBD,U,5):$P(IBD,U,5),1:DT),X2=$P(IBD,U,4) D ^%DTC S IBDS=IBDS+X
W ?74,$J(X,4),?79,$J($P(IBD,U,6),11,2),?91,$J($P(IBD,U,7),10,2)
W ?102,$J($P(IBD,U,6)-$P(IBD,U,7),11,2),?114,$J(IBPEN,11,2)
W ?126,$J($S(+$P(IBD,U,6)=0:0,1:$P(IBD,U,7)/$P(IBD,U,6)*100),6,2)
;
SUBTOT ; - Update sub-totals.
S $P(IBTI,U)=$P(IBTI,U)+1,$P(IBTI,U,2)=$P(IBTI,U,2)+$P(IBD,U,6)
S $P(IBTI,U,3)=$P(IBTI,U,3)+$P(IBD,U,7),$P(IBTI,U,4)=$P(IBTI,U,4)+IBPEN
;
GNDTOT ; - Update grand totals.
S $P(IBTT,U)=$P(IBTT,U)+1,$P(IBTT,U,2)=$P(IBTT,U,2)+$P(IBD,U,6)
I +$P($P(IBBN,"@@"),"(",2)<65 S $P(IBTT,U,3)=$P(IBTT,U,3)+$P(IBD,U,6),$P(IBTT,U,6)=$P(IBTT,U,6)+$P(IBD,U,7)
E S $P(IBTT,U,4)=$P(IBTT,U,4)+$P(IBD,U,6),$P(IBTT,U,7)=$P(IBTT,U,7)+$P(IBD,U,7)
S $P(IBTT,U,5)=$P(IBTT,U,5)+$P(IBD,U,7),$P(IBTT,U,8)=$P(IBTT,U,8)+IBPEN
I $G(IBCANC),$P(IBD,U,8) S $P(IBTT,U,9)=$P(IBTT,U,9)+1,$P(IBTT,U,10)=$P(IBTT,U,10)+$P(IBD,U,6)
Q
;
HDR ; - Print the report header.
S IBPAG=IBPAG+1 W @IOF,IBRTN," PAYMENT TREND REPORT - "
W $S(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
W ?109,IBTDT," PAGE ",$J(IBPAG,3),!
I IBDIV W "For: ",$P($G(^DG(40.8,IBDIV,0)),U)," - "
W IBDFN,": ",$$DATE(IBBDT)," - ",$$DATE(IBEDT)
I IBPRNT="M" W ?82,"Note: '*' after the Bill No. denotes a CLOSED bill"
W:$D(IBAF) !,IBAFT G:IBPRNT="G" HDL
W !!,"BILL",?13,"PATIENT",?55,"DATE",?64,"DATE BILL",?75,"#"
W ?83,"AMOUNT",?93,"AMOUNT",?106,"AMOUNT",?117,"AMOUNT",?127,"PERC"
W !,"NUMBER",?13,"NAME (AGE)",?35,"BILL FROM - TO",?54,"PRINTED"
W ?65,"CLOSED",?74,"DAYS",?83,"BILLED",?92,"COLLECTED",?106,"UNPAID"
W ?117,"PENDING",?127,"COLL"
HDL W !,IBLINE
I IBPRNT="M" W !?56,"M A I N R E P O R T"
I IBPRNT="G" W !?55,"G R A N D T O T A L S",!
I IBPRNT="S" W !?49,"S U M M A R Y S T A T I S T I C S"
I "OP"[IBSORT W !?30,"S O R T E D B Y A M O U N T ",$S(IBSORT="O":"O W E",1:"P A I")," D - H I G H E S T T O L O W E S T"
S IBQUIT=$$STOP^IBOUTL("Trend Report")
Q
;
EXCHDR ;
W !,IBRTN," PAYMENT TREND REPORT"
;W !,$S(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
W " - ",$S(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING" ;IB*752/DTG fix excel header
I IBDIV W !,"For: ",$P($G(^DG(40.8,IBDIV,0)),U)
W !,IBDFN,": ",$$DATE(IBBDT)," - ",$$DATE(IBEDT)
I IBPRNT="M" W !,"Note: '*' after the Bill No. denotes a CLOSED bill"
I IBPRNT="M" W !,"M A I N R E P O R T"
I IBPRNT="G" W !,"G R A N D T O T A L S",!
I IBPRNT="S" W !,"S U M M A R Y S T A T I S T I C S"
I "OP"[IBSORT W !,"S O R T E D B Y A M O U N T ",$S(IBSORT="O":"O W E",1:"P A I")," D - H I G H E S T T O L O W E S T"
W:$D(IBAF) !,IBAFT G:IBPRNT="G" EXHDL
W !,"INSURANCE NAME^GROUP #^BILL NUMBER^PATIENT NAME (AGE)^BILL FROM^DATE BILL TO^DATE PRINTED^DATE BILL CLOSED^# DAYS^AMOUNT BILLED^AMOUNT COLLECTED^AMOUNT UNPAID^AMOUNT PENDING^PERC COLL"
EXHDL ;
Q
;
EXOUT ; Print excel format
;IB*2.0*529 Reject flag re-added back to the software.
S IBBLNO=$P($P(IBBN,"@@",2),"*") I IBBLNO["%" S IBBLNO=$P(IBBLNO,"%",2)
S IBRJFLAG=+$$BILLREJ^IBJTU6(IBBLNO),IBRJFLAG=$S(IBRJFLAG=1:"c",1:"")
;end IB*2.0*529
W !,$P(INSC,"~~",1)_"/"_$P(INSC,"~~",2)_U_$G(IBGRPD)_U_IBRJFLAG_$P(IBBN,"@@",2)_U_$P(IBBN,"@@")_U_$$DATE($P(IBD,U,2))_U_$$DATE($P(IBD,U,3))_U_$$DATE($P(IBD,U,4))
W U_$S($P(IBD,U,5):$$DATE($P(IBD,U,5)),1:$P(IBD,U,5))
S X1=$S($P(IBD,U,5):$P(IBD,U,5),1:DT),X2=$P(IBD,U,4) D ^%DTC S IBDS=IBDS+X
W U_$J(X,4)_U_$J($P(IBD,U,6),11,2)_U_$J($P(IBD,U,7),10,2)
W U_$J($P(IBD,U,6)-$P(IBD,U,7),11,2)_U_$J(IBPEN,11,2)
W U_$J($S(+$P(IBD,U,6)=0:0,1:$P(IBD,U,7)/$P(IBD,U,6)*100),6,2)
Q
;
DATE(IBX) S:IBX]"" IBX=$E(IBX,4,5)_"/"_$E(IBX,6,7)_"/"_$E(IBX,2,3) Q IBX
;
PAUSE I $E(IOST,1,2)'="C-" Q
I IOSL<60 F IBI=$Y:1:(IOSL-IBCALC) W !
S DIR(0)="E" D ^DIR K DIR
I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
Q
;
INSADD ; - Display Insurance Company name and address.
; Input: IBINS
N D,PH,IEN,IBINS1,IBPTIN
;
;IB*2.0*529 - display TIN with insurance company
S IBINS1=$P(IBINS,"@@")
S IBPTIN=$P(IBINS1,"~~",2),IBINS1=$P(IBINS1,"~~")
W !!?16,"INSURANCE CARRIER: ",IBINS1,"/",IBPTIN
;end IB*2.0*529
S IEN=$P(IBINS,"@@",2) G:'IEN INSADQ
S D=$G(^DIC(36,IEN,.11)),PH=$P($G(^(.13)),U) G:D="" INSADQ
W:$P(D,U)]"" !?35,$P(D,U)
W:$P(D,U,2)]"" !?35,$P(D,U,2)
W:$P(D,U,3)]"" !?35,$P(D,U,3)
W:$P(D,U)]""!($P(D,U,2)]"")!($P(D,U,3)]"") !?35
W $P(D,U,4) W:$P(D,U,4)]""&($P(D,U,5)]"") ", "
W $P($G(^DIC(5,+$P(D,U,5),0)),U)
W:$P(D,U,6)]""&($P(D,U,4)]""!($P(D,U,5)]"")) " "
W $P(D,U,6) W:PH]"" $J("",8),"Phone: ",PH
INSADQ W ! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOTR3 8843 printed Sep 23, 2025@20:02:32 Page 2
IBOTR3 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - OUTPUT ;5-JUN-91
+1 ;;2.0;INTEGRATED BILLING;**42,80,100,118,128,133,447,516,528,529,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCROTR3
+5 ;
EN(IBDIV) ; - Entry point from IBOTR2.
+1 ;
+2 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+3 ; - Extract zero totals if no data available.
+4 ;I $G(IBXTRACT),'$D(^TMP($J,"IBOTR",IBDIV)) D G END
+5 ;IB*752/DTG
IF $GET(IBXTRACT)
IF '$DATA(^TMP($JOB,"IBOTR",IBDIV))
Begin DoDot:1
+6 SET IBUNPD=0
FOR X=1:1:8
SET IBTT(X)=0
+7 DO E^IBJDE(8,0)
End DoDot:1
DO EOR
GOTO END
+8 ;
+9 ; Calculate grand totals for extract.
IF $GET(IBXTRACT)
GOTO IBX
+10 ;
+11 SET IBPAG=0
SET IBLINE=""
SET $PIECE(IBLINE,"-",IOM)="-"
SET Y=DT
DO D^DIQ
SET IBTDT=Y
+12 IF $DATA(IBAF)
DO ADDFLD^IBOTR4
+13 ;I '$D(^TMP($J,"IBOTR",IBDIV)) D S IBCALC=3 D PAUSE G END
+14 ;IB*752/DTG
IF '$DATA(^TMP($JOB,"IBOTR",IBDIV))
Begin DoDot:1
+15 SET IBX=$SELECT("Bb"'[IBBRT:IBBRT,IBBRN="C":"A",1:"I")
+16 ;IB*752/DTG do correct header for excel
+17 ;D HDR W !!," NO INFORMATION MATCHES SELECTION CRITERIA."
+18 IF IBOUT="E"
DO EXCHDR
+19 IF IBOUT="R"
DO HDR
+20 WRITE !!," NO INFORMATION MATCHES SELECTION CRITERIA."
End DoDot:1
SET IBCALC=3
DO EOR
DO PAUSE
GOTO END
+21 ;
IBX SET IBX=""
FOR
SET IBX=$ORDER(^TMP($JOB,"IBOTR",IBDIV,IBX))
if IBX=""
QUIT
Begin DoDot:1
+1 IF IBPRNT'="G"!('$GET(IBG))
SET IBTT="0^0^0^0^0^0^0^0^0^0"
+2 IF IBOUT="E"
DO EXCHDR
+3 IF IBOUT="R"
if '$GET(IBXTRACT)
DO HDR
if IBQUIT
QUIT
+4 DO INS
End DoDot:1
if IBQUIT
QUIT
+5 ; IB*752/DTG - add pause before leaving report
+6 SET IBCALC=3
IF '$GET(IBQUIT)
DO EOR
DO PAUSE
+7 ;
END KILL IBINS,IBPAG,IBLINE,IBTDT,IBX,IBTT,IBTI,IBCALC,IBBN,IBD,IBDS,IBAFT
+1 KILL IBAMT,IBG,IBI,IBPERC,IBUNPD,X,X1,X2,IBGRP,IBOUT,STOP
+2 KILL IBBLNO,IBRJFLAG,IBGRPD,INSC
+3 QUIT
+4 ;
+5 ;IB*752/DTG - add end of report message
EOR ; end of report
+1 NEW IBLEN
SET IBLEN=""
IF "Rr"[$EXTRACT(IBOUT,1)
SET $PIECE(IBLEN," ",59)=" "
+2 WRITE !!,IBLEN_"END OF REPORT"
+3 QUIT
+4 ;
INS ; - Loop through each insurance company or amount.
+1 IF IBSORT="I"
Begin DoDot:1
+2 SET IBINS=""
FOR
SET IBINS=$ORDER(^TMP($JOB,"IBOTR",IBDIV,IBX,IBINS))
if IBINS=""
QUIT
DO BILLNO
if IBQUIT
QUIT
End DoDot:1
+3 IF IBSORT'="I"
Begin DoDot:1
+4 SET IBAMT=""
FOR
SET IBAMT=$ORDER(^TMP($JOB,"IBOTRS",IBDIV,IBX,IBAMT))
if IBAMT=""
QUIT
SET IBINS=""
FOR
SET IBINS=$ORDER(^TMP($JOB,"IBOTRS",IBDIV,IBX,IBAMT,IBINS))
if IBINS=""!(IBQUIT)
QUIT
DO BILLNO
if IBQUIT
QUIT
End DoDot:1
+5 ;
+6 ; - Extract grand totals data.
+7 IF $GET(IBXTRACT)
IF 'IBQUIT
Begin DoDot:1
+8 SET IBUNPD=$JUSTIFY($PIECE(IBTT,U,2)-$PIECE(IBTT,U,5),0,2)
+9 FOR X=1:1:8
SET IBTT(X)=$SELECT(19'[X:$JUSTIFY($PIECE(IBTT,U,X),0,2),1:$PIECE(IBTT,U,X))
+10 DO E^IBJDE(8,0)
End DoDot:1
QUIT
+11 ;
+12 ; Write grand totals for report.
IF 'IBQUIT
IF '$GET(IBG)
IF IBOUT="R"
DO GTOT^IBOTR4
+13 QUIT
+14 ;
BILLNO ; - Loop through all bills for an insurance company.
+1 IF $GET(IBXTRACT)
GOTO LOOP
+2 IF IBOUT="E"
SET IBDS=0
SET INSC=$PIECE(IBINS,"@@")
GOTO LOOP
+3 IF $Y>(IOSL-15)
SET IBCALC=15
DO PAUSE
if IBQUIT
QUIT
DO HDR
if IBQUIT
QUIT
+4 IF IBPRNT'="G"
SET IBDS=0
SET IBTI="0^0^0^0"
DO INSADD
+5 IF '$TEST
IF $GET(IBG)
SET IBTT="0^0^0^0^0^0^0^0^0^0"
DO INSADD
LOOP ; add group# for p447
+1 SET IBGRP=""
FOR
SET IBGRP=$ORDER(^TMP($JOB,"IBOTR",IBDIV,IBX,IBINS,IBGRP))
if IBGRP=""!(IBQUIT)
QUIT
Begin DoDot:1
+2 IF IBOUT="E"
IF IBGRP'=""
SET IBGRPD=$SELECT(IBGRP'=0:$$GET1^DIQ(355.3,IBGRP_",",2.02),1:"None Defined")
+3 ; IB*2.0*516/TAZ Print the actual group number instead of internal group number.
+4 IF IBOUT="R"
IF IBPRNT="M"
WRITE !!,"Group #: "_$SELECT(IBGRP'=0:$$GET1^DIQ(355.3,IBGRP_",",2.02),1:"None Defined")
+5 ;
+6 SET IBBN=""
FOR
SET IBBN=$ORDER(^TMP($JOB,"IBOTR",IBDIV,IBX,IBINS,IBGRP,IBBN))
if IBBN=""
QUIT
SET IBD=^(IBBN)
DO DETAIL
if IBQUIT
QUIT
End DoDot:1
+7 IF IBOUT="E"
QUIT
+8 IF 'IBQUIT
IF IBOUT="R"
Begin DoDot:1
+9 ; Write insurance co. sub-totals.
IF IBPRNT'="G"
DO SUBTOT^IBOTR4
+10 ; Write insurance co. grand totals.
IF '$TEST
if $GET(IBG)
DO GTOT^IBOTR4
End DoDot:1
+11 QUIT
+12 ;
DETAIL ; - Write out detail lines.
+1 NEW IBPEN
SET IBPEN=$SELECT($PIECE(IBBN,"@@",2)["*":0,1:$PIECE(IBD,U,6)-$PIECE(IBD,U,7))
+2 IF IBOUT="E"
DO EXOUT
QUIT
+3 if IBPRNT="S"
GOTO SUBTOT
if IBPRNT="G"
GOTO GNDTOT
+4 IF $Y>(IOSL-7)
SET IBCALC=7
DO PAUSE
if IBQUIT
QUIT
DO HDR
if IBQUIT
QUIT
DO INSADD
+5 ;
+6 ;IB*2.0*529 Reject flag re-added back to the software.
+7 SET IBBLNO=$PIECE($PIECE(IBBN,"@@",2),"*")
IF IBBLNO["%"
SET IBBLNO=$PIECE(IBBLNO,"%",2)
+8 SET IBRJFLAG=+$$BILLREJ^IBJTU6(IBBLNO)
SET IBRJFLAG=$SELECT(IBRJFLAG=1:"c",1:"")
+9 WRITE !,IBRJFLAG,$PIECE(IBBN,"@@",2),?13,$PIECE(IBBN,"@@"),?35,$$DATE($PIECE(IBD,U,2))
+10 ;end IB*2.0*529
+11 WRITE ?44,$$DATE($PIECE(IBD,U,3)),?54,$$DATE($PIECE(IBD,U,4))
+12 WRITE ?64,$SELECT($PIECE(IBD,U,5):$$DATE($PIECE(IBD,U,5)),1:$PIECE(IBD,U,5))
+13 SET X1=$SELECT($PIECE(IBD,U,5):$PIECE(IBD,U,5),1:DT)
SET X2=$PIECE(IBD,U,4)
DO ^%DTC
SET IBDS=IBDS+X
+14 WRITE ?74,$JUSTIFY(X,4),?79,$JUSTIFY($PIECE(IBD,U,6),11,2),?91,$JUSTIFY($PIECE(IBD,U,7),10,2)
+15 WRITE ?102,$JUSTIFY($PIECE(IBD,U,6)-$PIECE(IBD,U,7),11,2),?114,$JUSTIFY(IBPEN,11,2)
+16 WRITE ?126,$JUSTIFY($SELECT(+$PIECE(IBD,U,6)=0:0,1:$PIECE(IBD,U,7)/$PIECE(IBD,U,6)*100),6,2)
+17 ;
SUBTOT ; - Update sub-totals.
+1 SET $PIECE(IBTI,U)=$PIECE(IBTI,U)+1
SET $PIECE(IBTI,U,2)=$PIECE(IBTI,U,2)+$PIECE(IBD,U,6)
+2 SET $PIECE(IBTI,U,3)=$PIECE(IBTI,U,3)+$PIECE(IBD,U,7)
SET $PIECE(IBTI,U,4)=$PIECE(IBTI,U,4)+IBPEN
+3 ;
GNDTOT ; - Update grand totals.
+1 SET $PIECE(IBTT,U)=$PIECE(IBTT,U)+1
SET $PIECE(IBTT,U,2)=$PIECE(IBTT,U,2)+$PIECE(IBD,U,6)
+2 IF +$PIECE($PIECE(IBBN,"@@"),"(",2)<65
SET $PIECE(IBTT,U,3)=$PIECE(IBTT,U,3)+$PIECE(IBD,U,6)
SET $PIECE(IBTT,U,6)=$PIECE(IBTT,U,6)+$PIECE(IBD,U,7)
+3 IF '$TEST
SET $PIECE(IBTT,U,4)=$PIECE(IBTT,U,4)+$PIECE(IBD,U,6)
SET $PIECE(IBTT,U,7)=$PIECE(IBTT,U,7)+$PIECE(IBD,U,7)
+4 SET $PIECE(IBTT,U,5)=$PIECE(IBTT,U,5)+$PIECE(IBD,U,7)
SET $PIECE(IBTT,U,8)=$PIECE(IBTT,U,8)+IBPEN
+5 IF $GET(IBCANC)
IF $PIECE(IBD,U,8)
SET $PIECE(IBTT,U,9)=$PIECE(IBTT,U,9)+1
SET $PIECE(IBTT,U,10)=$PIECE(IBTT,U,10)+$PIECE(IBD,U,6)
+6 QUIT
+7 ;
HDR ; - Print the report header.
+1 SET IBPAG=IBPAG+1
WRITE @IOF,IBRTN," PAYMENT TREND REPORT - "
+2 WRITE $SELECT(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
+3 WRITE ?109,IBTDT," PAGE ",$JUSTIFY(IBPAG,3),!
+4 IF IBDIV
WRITE "For: ",$PIECE($GET(^DG(40.8,IBDIV,0)),U)," - "
+5 WRITE IBDFN,": ",$$DATE(IBBDT)," - ",$$DATE(IBEDT)
+6 IF IBPRNT="M"
WRITE ?82,"Note: '*' after the Bill No. denotes a CLOSED bill"
+7 if $DATA(IBAF)
WRITE !,IBAFT
if IBPRNT="G"
GOTO HDL
+8 WRITE !!,"BILL",?13,"PATIENT",?55,"DATE",?64,"DATE BILL",?75,"#"
+9 WRITE ?83,"AMOUNT",?93,"AMOUNT",?106,"AMOUNT",?117,"AMOUNT",?127,"PERC"
+10 WRITE !,"NUMBER",?13,"NAME (AGE)",?35,"BILL FROM - TO",?54,"PRINTED"
+11 WRITE ?65,"CLOSED",?74,"DAYS",?83,"BILLED",?92,"COLLECTED",?106,"UNPAID"
+12 WRITE ?117,"PENDING",?127,"COLL"
HDL WRITE !,IBLINE
+1 IF IBPRNT="M"
WRITE !?56,"M A I N R E P O R T"
+2 IF IBPRNT="G"
WRITE !?55,"G R A N D T O T A L S",!
+3 IF IBPRNT="S"
WRITE !?49,"S U M M A R Y S T A T I S T I C S"
+4 IF "OP"[IBSORT
WRITE !?30,"S O R T E D B Y A M O U N T ",$SELECT(IBSORT="O":"O W E",1:"P A I")," D - H I G H E S T T O L O W E S T"
+5 SET IBQUIT=$$STOP^IBOUTL("Trend Report")
+6 QUIT
+7 ;
EXCHDR ;
+1 WRITE !,IBRTN," PAYMENT TREND REPORT"
+2 ;W !,$S(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
+3 ;IB*752/DTG fix excel header
WRITE " - ",$SELECT(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
+4 IF IBDIV
WRITE !,"For: ",$PIECE($GET(^DG(40.8,IBDIV,0)),U)
+5 WRITE !,IBDFN,": ",$$DATE(IBBDT)," - ",$$DATE(IBEDT)
+6 IF IBPRNT="M"
WRITE !,"Note: '*' after the Bill No. denotes a CLOSED bill"
+7 IF IBPRNT="M"
WRITE !,"M A I N R E P O R T"
+8 IF IBPRNT="G"
WRITE !,"G R A N D T O T A L S",!
+9 IF IBPRNT="S"
WRITE !,"S U M M A R Y S T A T I S T I C S"
+10 IF "OP"[IBSORT
WRITE !,"S O R T E D B Y A M O U N T ",$SELECT(IBSORT="O":"O W E",1:"P A I")," D - H I G H E S T T O L O W E S T"
+11 if $DATA(IBAF)
WRITE !,IBAFT
if IBPRNT="G"
GOTO EXHDL
+12 WRITE !,"INSURANCE NAME^GROUP #^BILL NUMBER^PATIENT NAME (AGE)^BILL FROM^DATE BILL TO^DATE PRINTED^DATE BILL CLOSED^# DAYS^AMOUNT BILLED^AMOUNT COLLECTED^AMOUNT UNPAID^AMOUNT PENDING^PERC COLL"
EXHDL ;
+1 QUIT
+2 ;
EXOUT ; Print excel format
+1 ;IB*2.0*529 Reject flag re-added back to the software.
+2 SET IBBLNO=$PIECE($PIECE(IBBN,"@@",2),"*")
IF IBBLNO["%"
SET IBBLNO=$PIECE(IBBLNO,"%",2)
+3 SET IBRJFLAG=+$$BILLREJ^IBJTU6(IBBLNO)
SET IBRJFLAG=$SELECT(IBRJFLAG=1:"c",1:"")
+4 ;end IB*2.0*529
+5 WRITE !,$PIECE(INSC,"~~",1)_"/"_$PIECE(INSC,"~~",2)_U_$GET(IBGRPD)_U_IBRJFLAG_$PIECE(IBBN,"@@",2)_U_$PIECE(IBBN,"@@")_U_$$DATE($PIECE(IBD,U,2))_U_$$DATE($PIECE(IBD,U,3))_U_$$DATE($PIECE(IBD,U,4))
+6 WRITE U_$SELECT($PIECE(IBD,U,5):$$DATE($PIECE(IBD,U,5)),1:$PIECE(IBD,U,5))
+7 SET X1=$SELECT($PIECE(IBD,U,5):$PIECE(IBD,U,5),1:DT)
SET X2=$PIECE(IBD,U,4)
DO ^%DTC
SET IBDS=IBDS+X
+8 WRITE U_$JUSTIFY(X,4)_U_$JUSTIFY($PIECE(IBD,U,6),11,2)_U_$JUSTIFY($PIECE(IBD,U,7),10,2)
+9 WRITE U_$JUSTIFY($PIECE(IBD,U,6)-$PIECE(IBD,U,7),11,2)_U_$JUSTIFY(IBPEN,11,2)
+10 WRITE U_$JUSTIFY($SELECT(+$PIECE(IBD,U,6)=0:0,1:$PIECE(IBD,U,7)/$PIECE(IBD,U,6)*100),6,2)
+11 QUIT
+12 ;
DATE(IBX) if IBX]""
SET IBX=$EXTRACT(IBX,4,5)_"/"_$EXTRACT(IBX,6,7)_"/"_$EXTRACT(IBX,2,3)
QUIT IBX
+1 ;
PAUSE IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+1 IF IOSL<60
FOR IBI=$Y:1:(IOSL-IBCALC)
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQUIT=1
KILL DIRUT,DTOUT,DUOUT
+4 QUIT
+5 ;
INSADD ; - Display Insurance Company name and address.
+1 ; Input: IBINS
+2 NEW D,PH,IEN,IBINS1,IBPTIN
+3 ;
+4 ;IB*2.0*529 - display TIN with insurance company
+5 SET IBINS1=$PIECE(IBINS,"@@")
+6 SET IBPTIN=$PIECE(IBINS1,"~~",2)
SET IBINS1=$PIECE(IBINS1,"~~")
+7 WRITE !!?16,"INSURANCE CARRIER: ",IBINS1,"/",IBPTIN
+8 ;end IB*2.0*529
+9 SET IEN=$PIECE(IBINS,"@@",2)
if 'IEN
GOTO INSADQ
+10 SET D=$GET(^DIC(36,IEN,.11))
SET PH=$PIECE($GET(^(.13)),U)
if D=""
GOTO INSADQ
+11 if $PIECE(D,U)]""
WRITE !?35,$PIECE(D,U)
+12 if $PIECE(D,U,2)]""
WRITE !?35,$PIECE(D,U,2)
+13 if $PIECE(D,U,3)]""
WRITE !?35,$PIECE(D,U,3)
+14 if $PIECE(D,U)]""!($PIECE(D,U,2)]"")!($PIECE(D,U,3)]"")
WRITE !?35
+15 WRITE $PIECE(D,U,4)
if $PIECE(D,U,4)]""&($PIECE(D,U,5)]"")
WRITE ", "
+16 WRITE $PIECE($GET(^DIC(5,+$PIECE(D,U,5),0)),U)
+17 if $PIECE(D,U,6)]""&($PIECE(D,U,4)]""!($PIECE(D,U,5)]""))
WRITE " "
+18 WRITE $PIECE(D,U,6)
if PH]""
WRITE $JUSTIFY("",8),"Phone: ",PH
INSADQ WRITE !
QUIT
