Routine: IBCORC1

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

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

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)

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

IBCORC1.m