IBJDB22.m

IBJDB22 ;ALB/RB - REASONS NOT BILLABLE REPORT (PRINT) ;19-JUN-00

 ;;2.0;INTEGRATED BILLING;**123,159,399**;21-MAR-94;Build 8

 ;

EN ; - Entry point from IBJDB21.

 ;

 ; - Extract summary data.

 I $G(IBXTRACT) D EXTMO(.IB) G ENQ

 ;

 S (IBQ,ECNT,ETOT,SCNT,STOT)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)

 ;

 S IBDIV="" I 'IBSD S VAUTD(0)=""

 F  S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV=""  D  I IBQ Q

 . F IBEP=1:1:4 I IBSEL[IBEP D  I IBQ Q

 . . D @($S(IBRPT="D":"DET",1:"SUM"))

 ;

 I IBQ G ENQ

 ;

 I 'IBQ,IBRPT="D" D

 . S IBDIV="" I 'IBSD S VAUTD(0)=""

 . F  S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV=""  D  I IBQ Q

 . . F IBEP=1:1:4 I IBSEL[IBEP D SUM I IBQ Q

 ;

ENQ K %,IB0,IBDH,IBDIV,IBEP,IBEPH,IBN,IBP,IBPAG,IBPT,IBQ,IBRT,IBRUN,IBSORT

 K IBT1,IBU,GTOT,ECNT,ETOT,SCNT,STOT

 Q

 ;

DET ; - Print detailed report.

 I '$D(^TMP("IBJDB2",$J,IBDIV,IBEP)) D  D PAUSE Q

 . D HDR Q:IBQ  W !!,"No entries for this episode.",!

 S IBT1=0,(IBSORT1,IBPT,IB0)=""

 F  S IBSORT1=$O(^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1)) Q:IBSORT1=""  D  Q:IBQ

 . D HDR Q:IBQ

 . F  S IBPT=$O(^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1,IBPT)) Q:IBPT=""  S IBP=$G(^(IBPT)) D  Q:IBQ

 . . I $Y>(IOSL-8) D PAUSE Q:IBQ  D HDR Q:IBQ

 . . D WPAT

 . . F  S IB0=$O(^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1,IBPT,IB0)) Q:IB0=""  S IBN=$G(^(IB0)) D  Q:IBQ

 . . . I $Y>(IOSL-8) D PAUSE Q:IBQ  D HDR Q:IBQ  D WPAT

 . . . W ?45,$$DTE(+IBN),?55,$$DTE($P(IBN,U,2))

 . . . I $P(IBN,U,4)'="" W ?65,$$DTE($P(IBN,U,3)),?76,$E($P(IBN,U,4),1,19)

 . . . E  W ?65,$$DTE($P(IBN,U,2)) W ?76,"POSTMASTER"

 . . . S IBU=5 S:12[IBEP IBU=$S(IBSORT="R":6,1:IBU)

 . . . I 12[IBEP W ?97,$E($P(IBN,U,IBU),1,25),?124,$J($P(IBN,U,8),8,2),!

 . . . I 34[IBEP,+$P(IBN,U,11)>0 W ?99,$J($P(IBN,U,8),8,2) F X=2:1:$P($P(IBN,U,11),";",1)+1 W ?114,$P($P(IBN,U,11),";",X)_" "

 . . . I 34[IBEP,+$P(IBN,U,11)<0 W ?99,$J($P(IBN,U,8),8,2),!

 . . . I 34[IBEP,+$P(IBN,U,11)>0 W !

 . . . I $P(IBN,U,9)]"" W ?15,"Comments: ",$P(IBN,U,9) W:12'[IBEP !

 . . . I 12[IBEP,+$P(IBN,U,11)>0,$P(IBN,U,9)="" W ?27,"Related Bills: " F X=2:1:$P($P(IBN,U,11),";",1)+1 W ?41,$P($P(IBN,U,11),";",X)_" "

 . . . I 2[IBEP,$P(IBN,U,10)'="" W ?76,"Nx Adm:",?85,$P(IBN,U,10)

 . . . I 12[IBEP,+$P(IBN,U,11)>0,$P(IBN,U,9)'="" W !,?27,"Related Bills: " F X=2:1:$P($P(IBN,U,11),";",1)+1 W ?41,$P($P(IBN,U,11),";",X)_" "

 . . . I 12[IBEP W ?97,$E($P(IBN,U,$S("PR"[IBSORT:7,1:6)),1,25),!

 . . . S SCNT=SCNT+1,ECNT=ECNT+1

 . . . S STOT=STOT+$P(IBN,U,8),ETOT=ETOT+$P(IBN,U,8)

 . I 'IBQ D TOT2 I $O(^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1))'="" D PAUSE Q

 I 'IBQ D TOT1,PAUSE

 ;

DETQ Q

 ;

EXTMO(IBSM) ; Extract/transmit data to DM Extract Module

 ; IBSM - Array containing the summary information

 ;

 N I,IB,IBI,IBJ,IBLST,IBR,IBRNB,IBSQ,IBTR,IBTP,IBZ,RNBC,RNBN

 ;

 F I=1:1 S RNBN=$P($T(RNB+I),";;",2,99) Q:RNBN=""  D

 . S RNBC=$O(^IBE(356.8,"B",RNBN,0)) Q:'RNBC

 . S IBTR(RNBC)=I

 ;

 S IBRNB="",IBLST=$O(^IBE(356.8,999),-1)*2

 F IBTP=1:1:4 D

 . F IBJ=1:1:IBLST,999,1000 S IB(IBTP,IBJ)=$S(IBJ#2:0,1:"0.00")

 . F  S IBRNB=$O(IBSM(0,IBTP,IBRNB)) Q:IBRNB=""  D

 . . I '$D(IBTR(IBRNB)) Q

 . . S IBSQ=$S(IBRNB<999:IBTR(IBRNB)*2-1,1:999)

 . . S IBZ=$G(IBSM(0,IBTP,IBRNB))

 . . S IB(IBTP,IBSQ)=+IBZ

 . . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)

 . F I=1:1:3 D E^IBJDE(21+(IBTP*3)+I,0)

 . K IB(IBTP)

 ;

 Q

 ;

SUM ; - Print summary line(s).

 I '$D(IB(IBDIV,IBEP)) D  D PAUSE Q

 . D SUMH W !!?14,"No statistics available."

 D SUMH Q:IBQ

 S IBRNB=0 F  S IBRNB=$O(IB(IBDIV,IBEP,IBRNB)) Q:'IBRNB  D  Q:IBQ

 . S IBN=IB(IBDIV,IBEP,IBRNB)

 . W !?14,$P($G(^IBE(356.8,IBRNB,0)),U),?48,$J(+IBN,5),?57,$J($P(IBN,U,2),9,2)

 . S $P(GTOT,U)=$P(GTOT,U)+IBN,$P(GTOT,U,2)=$P(GTOT,U,2)+$P(IBN,U,2)

 D SUMT

 ;

 Q

 ;

SUMH ; - Print summary header.

 I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13

 S IBPAG=$G(IBPAG)+1 W ?68,"Page: ",IBPAG

 S IBEPH="REASONS NOT BILLABLE SUMMARY/"_IBEPS(IBEP)

 W !!?(80-$L(IBEPH))\2,IBEPH

 I IBDIV D

 .S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)

 .W !?(80-$L(IBDH)\2),IBDH

 ;

 W !?22,"Period : from ",$$DTE(IBBDT)," thru ",$$DTE(IBEDT),!

 W !?24,"Run Date: ",IBRUN

 W !!?46,"No. of",?61,"Total",!?14,"RNB Category",?46,"Entries"

 W ?60,"Amount",!?14,$$DASH(52)

 S GTOT="0^0",IBQ=$$STOP^IBOUTL("Reasons Not Billable Summary")

 Q

 ;

SUMT ; - Print summary totals.

 W !?47,"-------------------"

 W !?33,"Grand Totals:",?47,$J(+GTOT,6),?56,$J($P(GTOT,U,2),10,2) D PAUSE

 Q

 ;

HDR ; - Write the detailed report header.

 I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13

 S IBPAG=$G(IBPAG)+1 W "Reasons Not Billable (RNB) Report "

 W ?88,"Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)

 S X=IBE(IBEP)_" events by "

 I 1234[IBEP D

 . S X=X_$S(IBSORT="P":"provider",IBSORT="S":"specialty",1:"RNB category")

 . I $G(IBSORT1)'="" S X=X_" ("_IBSORT1_")"

 E  S X=X_"RNB category"

 S X=X_" from "_$$DTE(IBBDT)_" thru "_$$DTE(IBEDT)_" ("_IBD_")"

 I 12[IBEP D

 . I IBSORT'="R" D

 . . S X=X_" / "_$S(IBSRNB="S":"SPECIFIC",1:"ALL")_" REASONS NOT BILLABLE"

 . I IBSORT'="P" D

 . . S X=X_" / "_$S(IBSPRV="S":"SPECIFIC",1:"ALL")_" PROVIDERS"

 . I IBSORT'="S",IBEP=1 D

 . . S X=X_" / "_$S(IBSISP="S":"SPECIFIC",1:"ALL")_" SPECIALTIES"

 . I IBSORT'="S",IBEP=2 D

 . . S X=X_" / "_$S(IBSOSP="S":"SPECIFIC",1:"ALL")_" SPECIALTIES"

 F I=1:1 W !,$E(X,1,132) S X=$E(X,133,999) I X="" Q

 ;

 I IBDIV W !,"Division: ",$P($G(^DG(40.8,IBDIV,0)),U)

 W !!?26,"Last",?32,"Insurance",?45,"Episode   Date      Dte Last"

 I 12[IBEP W ?97,$S("PS"[IBSORT:"RNB Category",1:"Provider")

 W !,"Patient",?26,"4SSN",?32,"Carrier"

 W ?45,"Date      Entered   Edited     Last Edited By"

 I 12[IBEP W ?97,$S("PR"[IBSORT:"Specialty",1:"Provider")

 ;

 I 34[IBEP W ?101,"Amount",?114,"Related Bills",!,$$DASH(IOM),!

 E  W ?126,"Amount",!,$$DASH(IOM),!

 S IBQ=$$STOP^IBOUTL("Reasons Not Billable Report")

 Q

 ;

WPAT ; - Write patient data.

 W $P(IBPT,"@@"),?26,$P(IBPT,"@@",2),?32,$E($P(IBP,U),1,12)

 Q

 ;

TOT1 ; - Print episode totals.

 I 34[IBEP W !?97,"----------",!

 E  W !?122,"----------",!

 I 34[IBEP W ?55

 E  W ?80

 W "TOTAL FOR EPISODE - Count: ",$J(ECNT,5),"  Amount: ",$J(ETOT,10,2)

 S (ECNT,ETOT)=0

 Q

 ;

TOT2 ; - Print sub-totals.

 I 34[IBEP W ?98,"---------",!

 E  W ?123,"---------",!

 I 34[IBEP W ?60

 E  W ?85

 W "TOTAL EVENTS - Count:  ",$J(SCNT,4),"  Amount:  ",$J(STOT,9,2),!

 S (SCNT,STOT)=0

 Q

 ;

DASH(X) ; - Return a dashed line.

 Q $TR($J("",X)," ","=")

 ;

PAUSE ; - Page break.

 I $E(IOST,1,2)'="C-" Q

 N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y

 F IBX=$Y:1:(IOSL-3) W !

 S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1

 Q

 ;

DTE(X) ; - Format the date.

 Q $S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")

 ;

RNB ; - Reasons Not Billable 

 ;;NOT INSURED

 ;;SC TREATMENT

 ;;AGENT ORANGE

 ;;IONIZING RADIATION

 ;;ENV. CONTAM.

 ;;SERVICE NOT COVERED

 ;;COVERAGE CANCELED

 ;;NEEDS SC DETERMINATION

 ;;NON-BILLABLE APPOINTMENT TYPE

 ;;INVALID PRESCRIPTION ENTRY

 ;;REFILL ON VISIT DATE

 ;;PRESCRIPTION DELETED

 ;;PRESCRIPTION NOT RELEASED

 ;;DRUG NOT BILLABLE

 ;;HMO POLICY

 ;;REFUSES TO SIGN RELEASE (ROI)

 ;;NON-BILLABLE STOP CODE

 ;;RESEARCH VISIT

 ;;BILL PURGED

 ;;NON-BILLABLE CLINIC

 ;;MILITARY SEXUAL TRAUMA

 ;;CREDENTIALING ISSUE

 ;;INSUFFICIENT DOCUMENTATION

 ;;NO DOCUMENTATION

 ;;NON-BILLABLE PROVIDER (RESID.)

 ;;NON-BILLABLE PROVIDER (OTHER)

 ;;OTHER COMPLIANCE

 ;;OUT OF NETWORK (PPO)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBJDB22   7402     printed  Feb 18, 2025@23:49:03                                                                                                                                                                                                     Page 2

IBJDB22   ;ALB/RB - REASONS NOT BILLABLE REPORT (PRINT) ;19-JUN-00

 +1       ;;2.0;INTEGRATED BILLING;**123,159,399**;21-MAR-94;Build 8

 +2       ;

EN        ; - Entry point from IBJDB21.

 +1       ;

 +2       ; - Extract summary data.

 +3        IF $GET(IBXTRACT)

               DO EXTMO(.IB)

               GOTO ENQ

 +4       ;

 +5        SET (IBQ,ECNT,ETOT,SCNT,STOT)=0

           DO NOW^%DTC

           SET IBRUN=$$DAT2^IBOUTL(%)

 +6       ;

 +7        SET IBDIV=""

           IF 'IBSD

               SET VAUTD(0)=""

 +8        FOR 

               SET IBDIV=$ORDER(VAUTD(IBDIV))

               if IBDIV=""

                   QUIT 

               Begin DoDot:1

 +9                FOR IBEP=1:1:4

                       IF IBSEL[IBEP

                           Begin DoDot:2

 +10                           DO @($SELECT(IBRPT="D":"DET",1:"SUM"))

                           End DoDot:2

                           IF IBQ

                               QUIT 

               End DoDot:1

               IF IBQ

                   QUIT 

 +11      ;

 +12       IF IBQ

               GOTO ENQ

 +13      ;

 +14       IF 'IBQ

               IF IBRPT="D"

                   Begin DoDot:1

 +15                   SET IBDIV=""

                       IF 'IBSD

                           SET VAUTD(0)=""

 +16                   FOR 

                           SET IBDIV=$ORDER(VAUTD(IBDIV))

                           if IBDIV=""

                               QUIT 

                           Begin DoDot:2

 +17                           FOR IBEP=1:1:4

                                   IF IBSEL[IBEP

                                       DO SUM

                                       IF IBQ

                                           QUIT 

                           End DoDot:2

                           IF IBQ

                               QUIT 

                   End DoDot:1

 +18      ;

ENQ        KILL %,IB0,IBDH,IBDIV,IBEP,IBEPH,IBN,IBP,IBPAG,IBPT,IBQ,IBRT,IBRUN,IBSORT

 +1        KILL IBT1,IBU,GTOT,ECNT,ETOT,SCNT,STOT

 +2        QUIT 

 +3       ;

DET       ; - Print detailed report.

 +1        IF '$DATA(^TMP("IBJDB2",$JOB,IBDIV,IBEP))

               Begin DoDot:1

 +2                DO HDR

                   if IBQ

                       QUIT 

                   WRITE !!,"No entries for this episode.",!

               End DoDot:1

               DO PAUSE

               QUIT 

 +3        SET IBT1=0

           SET (IBSORT1,IBPT,IB0)=""

 +4        FOR 

               SET IBSORT1=$ORDER(^TMP("IBJDB2",$JOB,IBDIV,IBEP,IBSORT1))

               if IBSORT1=""

                   QUIT 

               Begin DoDot:1

 +5                DO HDR

                   if IBQ

                       QUIT 

 +6                FOR 

                       SET IBPT=$ORDER(^TMP("IBJDB2",$JOB,IBDIV,IBEP,IBSORT1,IBPT))

                       if IBPT=""

                           QUIT 

                       SET IBP=$GET(^(IBPT))

                       Begin DoDot:2

 +7                        IF $Y>(IOSL-8)

                               DO PAUSE

                               if IBQ

                                   QUIT 

                               DO HDR

                               if IBQ

                                   QUIT 

 +8                        DO WPAT

 +9                        FOR 

                               SET IB0=$ORDER(^TMP("IBJDB2",$JOB,IBDIV,IBEP,IBSORT1,IBPT,IB0))

                               if IB0=""

                                   QUIT 

                               SET IBN=$GET(^(IB0))

                               Begin DoDot:3

 +10                               IF $Y>(IOSL-8)

                                       DO PAUSE

                                       if IBQ

                                           QUIT 

                                       DO HDR

                                       if IBQ

                                           QUIT 

                                       DO WPAT

 +11                               WRITE ?45,$$DTE(+IBN),?55,$$DTE($PIECE(IBN,U,2))

 +12                               IF $PIECE(IBN,U,4)'=""

                                       WRITE ?65,$$DTE($PIECE(IBN,U,3)),?76,$EXTRACT($PIECE(IBN,U,4),1,19)

 +13                              IF '$TEST

                                       WRITE ?65,$$DTE($PIECE(IBN,U,2))

                                       WRITE ?76,"POSTMASTER"

 +14                               SET IBU=5

                                   if 12[IBEP

                                       SET IBU=$SELECT(IBSORT="R":6,1:IBU)

 +15                               IF 12[IBEP

                                       WRITE ?97,$EXTRACT($PIECE(IBN,U,IBU),1,25),?124,$JUSTIFY($PIECE(IBN,U,8),8,2),!

 +16                               IF 34[IBEP

                                       IF +$PIECE(IBN,U,11)>0

                                           WRITE ?99,$JUSTIFY($PIECE(IBN,U,8),8,2)

                                           FOR X=2:1:$PIECE($PIECE(IBN,U,11),";",1)+1

                                               WRITE ?114,$PIECE($PIECE(IBN,U,11),";",X)_" "

 +17                               IF 34[IBEP

                                       IF +$PIECE(IBN,U,11)<0

                                           WRITE ?99,$JUSTIFY($PIECE(IBN,U,8),8,2),!

 +18                               IF 34[IBEP

                                       IF +$PIECE(IBN,U,11)>0

                                           WRITE !

 +19                               IF $PIECE(IBN,U,9)]""

                                       WRITE ?15,"Comments: ",$PIECE(IBN,U,9)

                                       if 12'[IBEP

                                           WRITE !

 +20                               IF 12[IBEP

                                       IF +$PIECE(IBN,U,11)>0

                                           IF $PIECE(IBN,U,9)=""

                                               WRITE ?27,"Related Bills: "

                                               FOR X=2:1:$PIECE($PIECE(IBN,U,11),";",1)+1

                                                   WRITE ?41,$PIECE($PIECE(IBN,U,11),";",X)_" "

 +21                               IF 2[IBEP

                                       IF $PIECE(IBN,U,10)'=""

                                           WRITE ?76,"Nx Adm:",?85,$PIECE(IBN,U,10)

 +22                               IF 12[IBEP

                                       IF +$PIECE(IBN,U,11)>0

                                           IF $PIECE(IBN,U,9)'=""

                                               WRITE !,?27,"Related Bills: "

                                               FOR X=2:1:$PIECE($PIECE(IBN,U,11),";",1)+1

                                                   WRITE ?41,$PIECE($PIECE(IBN,U,11),";",X)_" "

 +23                               IF 12[IBEP

                                       WRITE ?97,$EXTRACT($PIECE(IBN,U,$SELECT("PR"[IBSORT:7,1:6)),1,25),!

 +24                               SET SCNT=SCNT+1

                                   SET ECNT=ECNT+1

 +25                               SET STOT=STOT+$PIECE(IBN,U,8)

                                   SET ETOT=ETOT+$PIECE(IBN,U,8)

                               End DoDot:3

                               if IBQ

                                   QUIT 

                       End DoDot:2

                       if IBQ

                           QUIT 

 +26               IF 'IBQ

                       DO TOT2

                       IF $ORDER(^TMP("IBJDB2",$JOB,IBDIV,IBEP,IBSORT1))'=""

                           DO PAUSE

                           QUIT 

               End DoDot:1

               if IBQ

                   QUIT 

 +27       IF 'IBQ

               DO TOT1

               DO PAUSE

 +28      ;

DETQ       QUIT 

 +1       ;

EXTMO(IBSM) ; Extract/transmit data to DM Extract Module

 +1       ; IBSM - Array containing the summary information

 +2       ;

 +3        NEW I,IB,IBI,IBJ,IBLST,IBR,IBRNB,IBSQ,IBTR,IBTP,IBZ,RNBC,RNBN

 +4       ;

 +5        FOR I=1:1

               SET RNBN=$PIECE($TEXT(RNB+I),";;",2,99)

               if RNBN=""

                   QUIT 

               Begin DoDot:1

 +6                SET RNBC=$ORDER(^IBE(356.8,"B",RNBN,0))

                   if 'RNBC

                       QUIT 

 +7                SET IBTR(RNBC)=I

               End DoDot:1

 +8       ;

 +9        SET IBRNB=""

           SET IBLST=$ORDER(^IBE(356.8,999),-1)*2

 +10       FOR IBTP=1:1:4

               Begin DoDot:1

 +11               FOR IBJ=1:1:IBLST,999,1000

                       SET IB(IBTP,IBJ)=$SELECT(IBJ#2:0,1:"0.00")

 +12               FOR 

                       SET IBRNB=$ORDER(IBSM(0,IBTP,IBRNB))

                       if IBRNB=""

                           QUIT 

                       Begin DoDot:2

 +13                       IF '$DATA(IBTR(IBRNB))

                               QUIT 

 +14                       SET IBSQ=$SELECT(IBRNB<999:IBTR(IBRNB)*2-1,1:999)

 +15                       SET IBZ=$GET(IBSM(0,IBTP,IBRNB))

 +16                       SET IB(IBTP,IBSQ)=+IBZ

 +17                       SET IB(IBTP,IBSQ+1)=$FNUMBER(+$PIECE(IBZ,"^",2),"",2)

                       End DoDot:2

 +18               FOR I=1:1:3

                       DO E^IBJDE(21+(IBTP*3)+I,0)

 +19               KILL IB(IBTP)

               End DoDot:1

 +20      ;

 +21       QUIT 

 +22      ;

SUM       ; - Print summary line(s).

 +1        IF '$DATA(IB(IBDIV,IBEP))

               Begin DoDot:1

 +2                DO SUMH

                   WRITE !!?14,"No statistics available."

               End DoDot:1

               DO PAUSE

               QUIT 

 +3        DO SUMH

           if IBQ

               QUIT 

 +4        SET IBRNB=0

           FOR 

               SET IBRNB=$ORDER(IB(IBDIV,IBEP,IBRNB))

               if 'IBRNB

                   QUIT 

               Begin DoDot:1

 +5                SET IBN=IB(IBDIV,IBEP,IBRNB)

 +6                WRITE !?14,$PIECE($GET(^IBE(356.8,IBRNB,0)),U),?48,$JUSTIFY(+IBN,5),?57,$JUSTIFY($PIECE(IBN,U,2),9,2)

 +7                SET $PIECE(GTOT,U)=$PIECE(GTOT,U)+IBN

                   SET $PIECE(GTOT,U,2)=$PIECE(GTOT,U,2)+$PIECE(IBN,U,2)

               End DoDot:1

               if IBQ

                   QUIT 

 +8        DO SUMT

 +9       ;

 +10       QUIT 

 +11      ;

SUMH      ; - Print summary header.

 +1        IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)

               WRITE @IOF,*13

 +2        SET IBPAG=$GET(IBPAG)+1

           WRITE ?68,"Page: ",IBPAG

 +3        SET IBEPH="REASONS NOT BILLABLE SUMMARY/"_IBEPS(IBEP)

 +4        WRITE !!?(80-$LENGTH(IBEPH))\2,IBEPH

 +5        IF IBDIV

               Begin DoDot:1

 +6                SET IBDH="Division: "_$PIECE($GET(^DG(40.8,IBDIV,0)),U)

 +7                WRITE !?(80-$LENGTH(IBDH)\2),IBDH

               End DoDot:1

 +8       ;

 +9        WRITE !?22,"Period : from ",$$DTE(IBBDT)," thru ",$$DTE(IBEDT),!

 +10       WRITE !?24,"Run Date: ",IBRUN

 +11       WRITE !!?46,"No. of",?61,"Total",!?14,"RNB Category",?46,"Entries"

 +12       WRITE ?60,"Amount",!?14,$$DASH(52)

 +13       SET GTOT="0^0"

           SET IBQ=$$STOP^IBOUTL("Reasons Not Billable Summary")

 +14       QUIT 

 +15      ;

SUMT      ; - Print summary totals.

 +1        WRITE !?47,"-------------------"

 +2        WRITE !?33,"Grand Totals:",?47,$JUSTIFY(+GTOT,6),?56,$JUSTIFY($PIECE(GTOT,U,2),10,2)

           DO PAUSE

 +3        QUIT 

 +4       ;

HDR       ; - Write the detailed report header.

 +1        IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)

               WRITE @IOF,*13

 +2        SET IBPAG=$GET(IBPAG)+1

           WRITE "Reasons Not Billable (RNB) Report "

 +3        WRITE ?88,"Run Date: ",IBRUN,?123,"Page: ",$JUSTIFY(IBPAG,3)

 +4        SET X=IBE(IBEP)_" events by "

 +5        IF 1234[IBEP

               Begin DoDot:1

 +6                SET X=X_$SELECT(IBSORT="P":"provider",IBSORT="S":"specialty",1:"RNB category")

 +7                IF $GET(IBSORT1)'=""

                       SET X=X_" ("_IBSORT1_")"

               End DoDot:1

 +8       IF '$TEST

               SET X=X_"RNB category"

 +9        SET X=X_" from "_$$DTE(IBBDT)_" thru "_$$DTE(IBEDT)_" ("_IBD_")"

 +10       IF 12[IBEP

               Begin DoDot:1

 +11               IF IBSORT'="R"

                       Begin DoDot:2

 +12                       SET X=X_" / "_$SELECT(IBSRNB="S":"SPECIFIC",1:"ALL")_" REASONS NOT BILLABLE"

                       End DoDot:2

 +13               IF IBSORT'="P"

                       Begin DoDot:2

 +14                       SET X=X_" / "_$SELECT(IBSPRV="S":"SPECIFIC",1:"ALL")_" PROVIDERS"

                       End DoDot:2

 +15               IF IBSORT'="S"

                       IF IBEP=1

                           Begin DoDot:2

 +16                           SET X=X_" / "_$SELECT(IBSISP="S":"SPECIFIC",1:"ALL")_" SPECIALTIES"

                           End DoDot:2

 +17               IF IBSORT'="S"

                       IF IBEP=2

                           Begin DoDot:2

 +18                           SET X=X_" / "_$SELECT(IBSOSP="S":"SPECIFIC",1:"ALL")_" SPECIALTIES"

                           End DoDot:2

               End DoDot:1

 +19       FOR I=1:1

               WRITE !,$EXTRACT(X,1,132)

               SET X=$EXTRACT(X,133,999)

               IF X=""

                   QUIT 

 +20      ;

 +21       IF IBDIV

               WRITE !,"Division: ",$PIECE($GET(^DG(40.8,IBDIV,0)),U)

 +22       WRITE !!?26,"Last",?32,"Insurance",?45,"Episode   Date      Dte Last"

 +23       IF 12[IBEP

               WRITE ?97,$SELECT("PS"[IBSORT:"RNB Category",1:"Provider")

 +24       WRITE !,"Patient",?26,"4SSN",?32,"Carrier"

 +25       WRITE ?45,"Date      Entered   Edited     Last Edited By"

 +26       IF 12[IBEP

               WRITE ?97,$SELECT("PR"[IBSORT:"Specialty",1:"Provider")

 +27      ;

 +28       IF 34[IBEP

               WRITE ?101,"Amount",?114,"Related Bills",!,$$DASH(IOM),!

 +29      IF '$TEST

               WRITE ?126,"Amount",!,$$DASH(IOM),!

 +30       SET IBQ=$$STOP^IBOUTL("Reasons Not Billable Report")

 +31       QUIT 

 +32      ;

WPAT      ; - Write patient data.

 +1        WRITE $PIECE(IBPT,"@@"),?26,$PIECE(IBPT,"@@",2),?32,$EXTRACT($PIECE(IBP,U),1,12)

 +2        QUIT 

 +3       ;

TOT1      ; - Print episode totals.

 +1        IF 34[IBEP

               WRITE !?97,"----------",!

 +2       IF '$TEST

               WRITE !?122,"----------",!

 +3        IF 34[IBEP

               WRITE ?55

 +4       IF '$TEST

               WRITE ?80

 +5        WRITE "TOTAL FOR EPISODE - Count: ",$JUSTIFY(ECNT,5),"  Amount: ",$JUSTIFY(ETOT,10,2)

 +6        SET (ECNT,ETOT)=0

 +7        QUIT 

 +8       ;

TOT2      ; - Print sub-totals.

 +1        IF 34[IBEP

               WRITE ?98,"---------",!

 +2       IF '$TEST

               WRITE ?123,"---------",!

 +3        IF 34[IBEP

               WRITE ?60

 +4       IF '$TEST

               WRITE ?85

 +5        WRITE "TOTAL EVENTS - Count:  ",$JUSTIFY(SCNT,4),"  Amount:  ",$JUSTIFY(STOT,9,2),!

 +6        SET (SCNT,STOT)=0

 +7        QUIT 

 +8       ;

DASH(X)   ; - Return a dashed line.

 +1        QUIT $TRANSLATE($JUSTIFY("",X)," ","=")

 +2       ;

PAUSE     ; - Page break.

 +1        IF $EXTRACT(IOST,1,2)'="C-"

               QUIT 

 +2        NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y

 +3        FOR IBX=$Y:1:(IOSL-3)

               WRITE !

 +4        SET DIR(0)="E"

           DO ^DIR

           if $DATA(DIRUT)!($DATA(DUOUT))

               SET IBQ=1

 +5        QUIT 

 +6       ;

DTE(X)    ; - Format the date.

 +1        QUIT $SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3),1:"")

 +2       ;

RNB       ; - Reasons Not Billable 

 +1       ;;NOT INSURED

 +2       ;;SC TREATMENT

 +3       ;;AGENT ORANGE

 +4       ;;IONIZING RADIATION

 +5       ;;ENV. CONTAM.

 +6       ;;SERVICE NOT COVERED

 +7       ;;COVERAGE CANCELED