IBCORC1 ;ALB/CPM - RANK INSURANCE CARRIERS (COMPILE/PRINT) ; 30-JUN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DQ ; Tasked entry point to generate and print the rankings.
;
; - look at all insurance bills within date range and accumulate $$
D ENQ1 S IBDT=$$START(IBABEG,-1)
F S IBDT=$O(^DGCR(399,"AP",IBDT)) Q:'IBDT!(IBDT>IBAEND) D
.S IBN=0 F S IBN=$O(^DGCR(399,"AP",IBDT,IBN)) Q:'IBN D EVAL
;
; - invert the list by carrier to rank by amount billed
S IBINS=0 F S IBINS=$O(^TMP("IBORIC",$J,"IC",IBINS)) Q:'IBINS S ^TMP("IBORIC",$J,"AMT",-$G(^(IBINS)),IBINS)=""
;
; - print out the ranking list
S IBAMT="",(IBQ,IBCNT,IBPAG,IBTAMT)=0 D HDR
F S IBAMT=$O(^TMP("IBORIC",$J,"AMT",IBAMT)) Q:IBAMT=""!(IBQ)!(IBCNT>IBNR) D
.S IBINS=0 F S IBINS=$O(^TMP("IBORIC",$J,"AMT",IBAMT,IBINS)) Q:'IBINS!(IBQ)!(IBCNT>IBNR) D
..S IBCNT=IBCNT+1 Q:IBCNT>IBNR
..S IBAMTP=-IBAMT,IBTAMT=IBTAMT+IBAMTP
..S IBINS0=$G(^DIC(36,IBINS,0)),IBINSA=$G(^(.11))
..I $Y>(IOSL-8) D PAUSE Q:IBQ D HDR
..W !!,$J(IBCNT,4),".",?20,$S($P(IBINS0,"^")]"":$P(IBINS0,"^"),1:"CARRIER UNKNOWN")
..S X=IBAMTP,X2="2$",X3=15 D COMMA^%DTC W ?55,X
..D INSDIS(IBINSA)
G:IBQ ENQ
;
; - print a total
I $Y>(IOSL-4) D PAUSE G:IBQ ENQ D HDR
W !!,"Total Amount Billed to all Ranked Carriers:" S X=IBTAMT,X2="2$",X3=15 D COMMA^%DTC W ?55,X
D PAUSE
I IBFLG W !!,"Sending the report in a bulletin to the MCCR Program Office... " D BULL^IBCORC2 W "done."
;
ENQ K ^TMP("IBORIC",$J,"IC"),^TMP("IBORIC",$J,"AMT")
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBAMT,IBAMTP,IBI,IBINS0,IBINSA
K IBQ,IBPAG,IBNR,IBCNT,IBDT,IBND,IBINS,IBN,IBTAMT,X,X1,X2,X3,Y
ENQ1 Q
;
EVAL ; Accumulate amount billed for the carrier if the bill type is correct.
F IBI=0,"M","S" S IBND(IBI)=$G(^DGCR(399,IBN,IBI))
I IBND(0)="" G EVALQ ; no zeroth node
I $P(IBND(0),"^",11)'="i" G EVALQ ; insurer not responsible
S IBINS=+IBND("M") I 'IBINS G EVALQ ; no carrier associated with bill
I $P(IBND("S"),"^",16) G EVALQ ; bill has been cancelled
S IBAMT=+$$ORI^PRCAFN(IBN) I IBAMT'>0 G EVALQ ; no bill amount
S ^(IBINS)=$G(^TMP("IBORIC",$J,"IC",IBINS))+IBAMT
EVALQ Q
;
PAUSE ; Pause for screen output.
Q:$E(IOST,1,2)'="C-"
N IBI,DIR,DIRUT,DIROUT,DUOUT,DTOUT
F IBI=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
;
HDR ; Display report header.
N X,Y
S X="Ranking Of The Top "_IBNR_" Insurance Carriers By Total Amount Billed"
S Y=$$SITE^VASITE
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1
W ?(80-$L(X)\2),X,!
W !," Facility: ",$P(Y,"^",2)," (",$P(Y,"^",3),")",?58,"Run Date: ",$$DAT1^IBOUTL(DT)
W !,"Date Range: ",$$DAT1^IBOUTL(IBABEG)," thru ",$$DAT1^IBOUTL(IBAEND),?62,"Page: ",IBPAG
W !!,$$DASH,!?2,"Rank",?20,"Insurance Carrier",?55,"Total Amt Billed",!,$$DASH
Q
;
DASH() ; Write dashed line.
Q $TR($J("",79)," ","=")
;
INSDIS(X) ; Display Insurance Company name and address.
; Input: X -- .11 node of ins company entry in file #36
W:$P(X,"^")]"" !?20,$P(X,"^")
W:$P(X,"^",2)]"" !?20,$P(X,"^",2)
W:$P(X,"^",3)]"" !?20,$P(X,"^",3)
W:$P(X,"^")]""!($P(X,"^",2)]"")!($P(X,"^",3)]"") !?20
W $P(X,"^",4) W:$P(X,"^",4)]""&($P(X,"^",5)]"") ", "
W $P($G(^DIC(5,+$P(X,"^",5),0)),"^")
W:$P(X,"^",6)]""&($P(X,"^",4)]""!($P(X,"^",5)]"")) " "
W $P(X,"^",6)
Q
;
START(X1,X2) ; Return the Start Date for the search, less one day.
N X,%H D C^%DTC
Q X
IBCORC1 ;ALB/CPM - RANK INSURANCE CARRIERS (COMPILE/PRINT) ; 30-JUN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DQ ; Tasked entry point to generate and print the rankings.
+1 ;
+2 ; - look at all insurance bills within date range and accumulate $$
+3 DO ENQ1
SET IBDT=$$START(IBABEG,-1)
+4 FOR
SET IBDT=$ORDER(^DGCR(399,"AP",IBDT))
IF 'IBDT!(IBDT>IBAEND)
QUIT
Begin DoDot:1
+5 SET IBN=0
FOR
SET IBN=$ORDER(^DGCR(399,"AP",IBDT,IBN))
IF 'IBN
QUIT
DO EVAL
End DoDot:1
+6 ;
+7 ; - invert the list by carrier to rank by amount billed
+8 SET IBINS=0
FOR
SET IBINS=$ORDER(^TMP("IBORIC",$JOB,"IC",IBINS))
IF 'IBINS
QUIT
SET ^TMP("IBORIC",$JOB,"AMT",-$GET(^(IBINS)),IBINS)=""
+9 ;
+10 ; - print out the ranking list
+11 SET IBAMT=""
SET (IBQ,IBCNT,IBPAG,IBTAMT)=0
DO HDR
+12 FOR
SET IBAMT=$ORDER(^TMP("IBORIC",$JOB,"AMT",IBAMT))
IF IBAMT=""!(IBQ)!(IBCNT>IBNR)
QUIT
Begin DoDot:1
+13 SET IBINS=0
FOR
SET IBINS=$ORDER(^TMP("IBORIC",$JOB,"AMT",IBAMT,IBINS))
IF 'IBINS!(IBQ)!(IBCNT>IBNR)
QUIT
Begin DoDot:2
+14 SET IBCNT=IBCNT+1
IF IBCNT>IBNR
QUIT
+15 SET IBAMTP=-IBAMT
SET IBTAMT=IBTAMT+IBAMTP
+16 SET IBINS0=$GET(^DIC(36,IBINS,0))
SET IBINSA=$GET(^(.11))
+17 IF $Y>(IOSL-8)
DO PAUSE
IF IBQ
QUIT
DO HDR
+18 WRITE !!,$JUSTIFY(IBCNT,4),".",?20,$SELECT($PIECE(IBINS0,"^")]"":$PIECE(IBINS0,"^"),1:"CARRIER UNKNOWN")
+19 SET X=IBAMTP
SET X2="2$"
SET X3=15
DO COMMA^%DTC
WRITE ?55,X
+20 DO INSDIS(IBINSA)
End DoDot:2
End DoDot:1
+21 IF IBQ
GOTO ENQ
+22 ;
+23 ; - print a total
+24 IF $Y>(IOSL-4)
DO PAUSE
IF IBQ
GOTO ENQ
DO HDR
+25 WRITE !!,"Total Amount Billed to all Ranked Carriers:"
SET X=IBTAMT
SET X2="2$"
SET X3=15
DO COMMA^%DTC
WRITE ?55,X
+26 DO PAUSE
+27 IF IBFLG
WRITE !!,"Sending the report in a bulletin to the MCCR Program Office... "
DO BULL^IBCORC2
WRITE "done."
+28 ;
ENQ KILL ^TMP("IBORIC",$JOB,"IC"),^TMP("IBORIC",$JOB,"AMT")
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 DO ^%ZISC
+3 KILL DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBAMT,IBAMTP,IBI,IBINS0,IBINSA
+4 KILL IBQ,IBPAG,IBNR,IBCNT,IBDT,IBND,IBINS,IBN,IBTAMT,X,X1,X2,X3,Y
ENQ1 QUIT
+1 ;
EVAL ; Accumulate amount billed for the carrier if the bill type is correct.
+1 FOR IBI=0,"M","S"
SET IBND(IBI)=$GET(^DGCR(399,IBN,IBI))
+2 ; no zeroth node
IF IBND(0)=""
GOTO EVALQ
+3 ; insurer not responsible
IF $PIECE(IBND(0),"^",11)'="i"
GOTO EVALQ
+4 ; no carrier associated with bill
SET IBINS=+IBND("M")
IF 'IBINS
GOTO EVALQ
+5 ; bill has been cancelled
IF $PIECE(IBND("S"),"^",16)
GOTO EVALQ
+6 ; no bill amount
SET IBAMT=+$$ORI^PRCAFN(IBN)
IF IBAMT'>0
GOTO EVALQ
+7 SET ^(IBINS)=$GET(^TMP("IBORIC",$JOB,"IC",IBINS))+IBAMT
EVALQ QUIT
+1 ;
PAUSE ; Pause for screen output.
+1 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 NEW IBI,DIR,DIRUT,DIROUT,DUOUT,DTOUT
+3 FOR IBI=$Y:1:(IOSL-3)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+5 QUIT
+6 ;
HDR ; Display report header.
+1 NEW X,Y
+2 SET X="Ranking Of The Top "_IBNR_" Insurance Carriers By Total Amount Billed"
+3 SET Y=$$SITE^VASITE
+4 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+5 SET IBPAG=IBPAG+1
+6 WRITE ?(80-$LENGTH(X)\2),X,!
+7 WRITE !," Facility: ",$PIECE(Y,"^",2)," (",$PIECE(Y,"^",3),")",?58,"Run Date: ",$$DAT1^IBOUTL(DT)
+8 WRITE !,"Date Range: ",$$DAT1^IBOUTL(IBABEG)," thru ",$$DAT1^IBOUTL(IBAEND),?62,"Page: ",IBPAG
+9 WRITE !!,$$DASH,!?2,"Rank",?20,"Insurance Carrier",?55,"Total Amt Billed",!,$$DASH
+10 QUIT
+11 ;
DASH() ; Write dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",79)," ","=")
+2 ;
INSDIS(X) ; Display Insurance Company name and address.
+1 ; Input: X -- .11 node of ins company entry in file #36
+2 IF $PIECE(X,"^")]""
WRITE !?20,$PIECE(X,"^")
+3 IF $PIECE(X,"^",2)]""
WRITE !?20,$PIECE(X,"^",2)
+4 IF $PIECE(X,"^",3)]""
WRITE !?20,$PIECE(X,"^",3)
+5 IF $PIECE(X,"^")]""!($PIECE(X,"^",2)]"")!($PIECE(X,"^",3)]"")
WRITE !?20
+6 WRITE $PIECE(X,"^",4)
IF $PIECE(X,"^",4)]""&($PIECE(X,"^",5)]"")
WRITE ", "
+7 WRITE $PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^")
+8 IF $PIECE(X,"^",6)]""&($PIECE(X,"^",4)]""!($PIECE(X,"^",5)]""))
WRITE " "
+9 WRITE $PIECE(X,"^",6)
+10 QUIT
+11 ;
START(X1,X2) ; Return the Start Date for the search, less one day.
+1 NEW X,%H
DO C^%DTC
+2 QUIT X
