- 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
