IBCORC1 ;ALB/CPM - RANK INSURANCE CARRIERS (COMPILE/PRINT) ; 30-JUN-93
;;2.0;INTEGRATED BILLING;**29,47,68,80**;21-MAR-94
;
DQ ; Tasked entry point to generate and print the rankings.
;
; - look at all insurance bills within date range and accumulate $$
K ^TMP("IBORIC",$J,"IC"),^("IC1"),^("AMT"),^("NUM")
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
;
; - if executed by IRM, generate the formatted bulletin and quit
I $G(IBIRM) D BULL^IBCORC3 G ENQ
;
; - 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),"." W:$P(IBINS0,"^",5) ?16,"**"
..W ?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"),^("IC1"),^("AMT"),^("NUM")
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","MP" 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("MP") 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=$$INACT(IBINS) ; see if company has been repointed
S ^(IBINS)=$G(^TMP("IBORIC",$J,"IC",IBINS))+IBAMT
I $G(IBIRM) S ^(IBINS)=$G(^TMP("IBORIC",$J,"IC1",IBINS))+1
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 !?45,"** - denotes an inactive company"
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
;
INACT(CN) ; Determine the repointed-to company for inactivated companies.
; Input: CN -- Pointer to the ins company in file #36
; Output: The repointed-to company, if inactivated (or the same)
N X,Y,Z S X=+$G(CN)
F S Y=$G(^DIC(36,X,0)) Q:'$P(Y,"^",5)!('$P(Y,"^",16))!($P(Y,"^",16)=X)!($D(Z(+$P(Y,"^",16)))) S X=$P(Y,"^",16),Z(X)=""
Q X
;
DEL ; Delete "REPOINT PATIENTS TO" field
N C1,C2,DA,DIR
W !,"The routine will delete the REPOINT PATIENTS TO field of the entry"
W !,"in the INSURANCE COMPANY file (#36) if the field entry is pointing"
W !,"back to itself (same IEN).",!
S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO" D ^DIR Q:+Y=0 W !!,"A dot (.) will appear for every 50 records processed.",!
S (C1,C2,DA)=0 F S DA=$O(^DIC(36,DA)) Q:+DA=0 I $P($G(^DIC(36,DA,0)),U,16)=DA S $P(^DIC(36,DA,0),U,16)="",C1=C1+1,C2=C2+1 I C1=50 W "." S C1=0
W !,*7,"Done...",C2," records changed." Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCORC1 4801 printed Feb 18, 2025@23:45:04 Page 2
IBCORC1 ;ALB/CPM - RANK INSURANCE CARRIERS (COMPILE/PRINT) ; 30-JUN-93
+1 ;;2.0;INTEGRATED BILLING;**29,47,68,80**;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 KILL ^TMP("IBORIC",$JOB,"IC"),^("IC1"),^("AMT"),^("NUM")
+4 SET IBDT=$$START(IBABEG,-1)
+5 FOR
SET IBDT=$ORDER(^DGCR(399,"AP",IBDT))
if 'IBDT!(IBDT>IBAEND)
QUIT
Begin DoDot:1
+6 SET IBN=0
FOR
SET IBN=$ORDER(^DGCR(399,"AP",IBDT,IBN))
if 'IBN
QUIT
DO EVAL
End DoDot:1
+7 ;
+8 ; - if executed by IRM, generate the formatted bulletin and quit
+9 IF $GET(IBIRM)
DO BULL^IBCORC3
GOTO ENQ
+10 ;
+11 ; - invert the list by carrier to rank by amount billed
+12 SET IBINS=0
FOR
SET IBINS=$ORDER(^TMP("IBORIC",$JOB,"IC",IBINS))
if 'IBINS
QUIT
SET ^TMP("IBORIC",$JOB,"AMT",-$GET(^(IBINS)),IBINS)=""
+13 ;
+14 ; - print out the ranking list
+15 SET IBAMT=""
SET (IBQ,IBCNT,IBPAG,IBTAMT)=0
DO HDR
+16 FOR
SET IBAMT=$ORDER(^TMP("IBORIC",$JOB,"AMT",IBAMT))
if IBAMT=""!(IBQ)!(IBCNT>IBNR)
QUIT
Begin DoDot:1
+17 SET IBINS=0
FOR
SET IBINS=$ORDER(^TMP("IBORIC",$JOB,"AMT",IBAMT,IBINS))
if 'IBINS!(IBQ)!(IBCNT>IBNR)
QUIT
Begin DoDot:2
+18 SET IBCNT=IBCNT+1
if IBCNT>IBNR
QUIT
+19 SET IBAMTP=-IBAMT
SET IBTAMT=IBTAMT+IBAMTP
+20 SET IBINS0=$GET(^DIC(36,IBINS,0))
SET IBINSA=$GET(^(.11))
+21 IF $Y>(IOSL-8)
DO PAUSE
if IBQ
QUIT
DO HDR
+22 WRITE !!,$JUSTIFY(IBCNT,4),"."
if $PIECE(IBINS0,"^",5)
WRITE ?16,"**"
+23 WRITE ?20,$SELECT($PIECE(IBINS0,"^")]"":$PIECE(IBINS0,"^"),1:"CARRIER UNKNOWN")
+24 SET X=IBAMTP
SET X2="2$"
SET X3=15
DO COMMA^%DTC
WRITE ?55,X
+25 DO INSDIS(IBINSA)
End DoDot:2
End DoDot:1
+26 if IBQ
GOTO ENQ
+27 ;
+28 ; - print a total
+29 IF $Y>(IOSL-4)
DO PAUSE
if IBQ
GOTO ENQ
DO HDR
+30 WRITE !!,"Total Amount Billed to all Ranked Carriers:"
SET X=IBTAMT
SET X2="2$"
SET X3=15
DO COMMA^%DTC
WRITE ?55,X
+31 DO PAUSE
+32 ;I IBFLG W !!,"Sending the report in a bulletin to the MCCR Program Office... " D BULL^IBCORC2 W "done."
+33 ;
ENQ KILL ^TMP("IBORIC",$JOB,"IC"),^("IC1"),^("AMT"),^("NUM")
+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","MP"
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("MP")
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 ; see if company has been repointed
SET IBINS=$$INACT(IBINS)
+8 SET ^(IBINS)=$GET(^TMP("IBORIC",$JOB,"IC",IBINS))+IBAMT
+9 IF $GET(IBIRM)
SET ^(IBINS)=$GET(^TMP("IBORIC",$JOB,"IC1",IBINS))+1
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 !?45,"** - denotes an inactive company"
+10 WRITE !,$$DASH,!?2,"Rank",?20,"Insurance Carrier",?55,"Total Amt Billed",!,$$DASH
+11 QUIT
+12 ;
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
+3 ;
INACT(CN) ; Determine the repointed-to company for inactivated companies.
+1 ; Input: CN -- Pointer to the ins company in file #36
+2 ; Output: The repointed-to company, if inactivated (or the same)
+3 NEW X,Y,Z
SET X=+$GET(CN)
+4 FOR
SET Y=$GET(^DIC(36,X,0))
if '$PIECE(Y,"^",5)!('$PIECE(Y,"^",16))!($PIECE(Y,"^",16)=X)!($DATA(Z(+$PIECE(Y,"^",16))))
QUIT
SET X=$PIECE(Y,"^",16)
SET Z(X)=""
+5 QUIT X
+6 ;
DEL ; Delete "REPOINT PATIENTS TO" field
+1 NEW C1,C2,DA,DIR
+2 WRITE !,"The routine will delete the REPOINT PATIENTS TO field of the entry"
+3 WRITE !,"in the INSURANCE COMPANY file (#36) if the field entry is pointing"
+4 WRITE !,"back to itself (same IEN).",!
+5 SET DIR(0)="YO"
SET DIR("A")="Are you sure you want to do this"
SET DIR("B")="NO"
DO ^DIR
if +Y=0
QUIT
WRITE !!,"A dot (.) will appear for every 50 records processed.",!
+6 SET (C1,C2,DA)=0
FOR
SET DA=$ORDER(^DIC(36,DA))
if +DA=0
QUIT
IF $PIECE($GET(^DIC(36,DA,0)),U,16)=DA
SET $PIECE(^DIC(36,DA,0),U,16)=""
SET C1=C1+1
SET C2=C2+1
IF C1=50
WRITE "."
SET C1=0
+7 WRITE !,*7,"Done...",C2," records changed."
QUIT
