IBJDF63.m

IBJDF63 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00

 ;;2.0;INTEGRATED BILLING;**123,618**;21-MAR-94;Build 61

 ;;Per VHA Directive 6402, this routine should not be modified.

 ;

INIT ; - Initialize counters, if necessary.

 ; Quit if division selected for Debtor (doesn't split by division)

 I IBSDV,IBDIV,'$$CATCHK^IBJDF61(IBCAT) Q

 ; Quit if division flag is false when a patient category and requested to

 ;   sort by division

 I IBSDV,'IBDIV,$$CATCHK^IBJDF61(IBCAT) Q

 ; Initialize division counters

 F I=1:1:8 S IB(IBDIV,IBCAT,I)=0

 Q

 ;

EN ; - Compile entry point from IBJDF61.

 ;   Pre-set variables IBA, IBCAT, IBDIV required.

 N I,IB0,IBAGE,IBARD,IBOUT,J

 ;

 ; - Add totals for summary.

 S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.

 S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)

 S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)

 S $P(IB(IBDIV,IBCAT,IB0),U)=+IB(IBDIV,IBCAT,IB0)+1

 S $P(IB(IBDIV,IBCAT,IB0),U,2)=$P(IB(IBDIV,IBCAT,IB0),U,2)+IBOUT

ENQ Q

 ;

PRT ; - Print entry point from IBJDF62.

 ;

 ; - Extract summary data.

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

 ;

 S IBDIV=""

 F  S IBDIV=$O(IB(IBDIV)) Q:IBDIV=""  D SUM(IBDIV)  Q:IBQ

 ;

ENQ1 Q

 ;

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

 ; IBS - Array containing the summary information

 ;

 N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ

 ;

 F IBI=1,2,3 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")

 ;

 F IBCT=6,7,10 D

 . S IBTP=0

 . I IBCT=7 S IBTP=1       ;  Workman's Comp.

 . I IBCT=10 S IBTP=2      ;  NO-Fault Auto Accident

 . I IBCT=6 S IBTP=3       ;  Tort-Feasor

 . S IBSQ=1

 . F IBI=1:1:7 D

 . . S IBZ=$G(IBS(0,IBCT,IBI))

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

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

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

 . . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)

 . . S IBSQ=IBSQ+2

 . S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)

 ;

 F IBR=22:1:24 D E^IBJDE(IBR,0)

 Q

 ;

SUM(IBDIV) ; - Print summary for division.

 ;  Input: IBDIV=Pointer to the division in file #40.8 and pre-set

 ;         variable IBRPT

 N IBDH,IBTYP,I,J,Z,%

 N IBCATNM  ; patch IB*2.0*618

 ;

 S IBCAT=0

 F  S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT  D  Q:IBQ

 . S IBCATNM=$$ARCAT^IBJDF62(IBCAT)  ; patch IB*2.0*618

 . D HDR Q:IBQ

 . S IBTYP=$G(IBCATNM)_" RECEIVABLES"

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

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

 . I IBDIV D

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

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

 . ;

 . W !!

 . ;

 . ; - Calculate totals first.

 . F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,8),U,J)=$P(IB(IBDIV,IBCAT,8),U,J)+$P(IB(IBDIV,IBCAT,I),U,J)

 . ;

 . W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!

 . W "-----------",?31,"-------------",?52,"-------------------------"

 . I 'IB(IBDIV,IBCAT,8) W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),".",!! D PAUSE Q

 . ;

 . ; - Primary loop to write results.

 . S Y=$P(IB(IBDIV,IBCAT,8),U,2) F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D

 . . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,I),6)

 . . W "  (",$J(+IB(IBDIV,IBCAT,I)/+IB(IBDIV,IBCAT,8)*100,0,$S(I=8:0,1:2)),"%)"

 . . S Z=$FN($P(IB(IBDIV,IBCAT,I),U,2),",",2)

 . . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)

 . . W "  (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"

 . . W:I=8 !!

 . ;

 . D PAUSE

 ;

SUMQ Q

 ;

HDR ; - Write the summary report header.

 N X,PD,PDA,PDF,PDL

 ;

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

 S IBPAG=$G(IBPAG)+1

 W "MISCELLANEOUS BILLS FOLLOW-UP SUMMARY REPORT"

 W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN

 S X=""

 I IBRPT="D" D

 . I IBSMN'="A" D

 . . S X="  RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "

 . ; Modified the Patient/Debtor dividing line

 . I IBCAT(IBCAT)>7 S PD="DEBTORS",PDA=IBSDA,PDF=IBSDF,PDL=IBSDL

 . I IBCAT(IBCAT)<8 S PD="PATIENTS",PDA=IBSNA,PDF=IBSNF,PDL=IBSNL

 . I $G(PDA)'="ALL" D

 . . S X=X_"/ "_PD_" FROM '"_$S(PDF="":"FIRST",1:PDF)_"' TO '"

 . . S X=X_$S(PDL="zzzzz":"LAST",1:PDL)_"' "

 . I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "

 S $E(X,1,2)=""

 I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q

 ;

 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

 ;

CAT(X) ; - Determine category to place receivable.

 Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)

 ;

CATN ; - List of category names.

 ;;Less than 30 days old

 ;;31-60 days

 ;;61-90 days

 ;;91-120 days

 ;;121-180 days

 ;;181-365 days

 ;;Over 365 days

 ;;Total

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBJDF63   4759     printed  Mar 13, 2025@21:27:58                                                                                                                                                                                                     Page 2

IBJDF63   ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE/PRINT SUMMARY);15-APR-00

 +1       ;;2.0;INTEGRATED BILLING;**123,618**;21-MAR-94;Build 61

 +2       ;;Per VHA Directive 6402, this routine should not be modified.

 +3       ;

INIT      ; - Initialize counters, if necessary.

 +1       ; Quit if division selected for Debtor (doesn't split by division)

 +2        IF IBSDV

               IF IBDIV

                   IF '$$CATCHK^IBJDF61(IBCAT)

                       QUIT 

 +3       ; Quit if division flag is false when a patient category and requested to

 +4       ;   sort by division

 +5        IF IBSDV

               IF 'IBDIV

                   IF $$CATCHK^IBJDF61(IBCAT)

                       QUIT 

 +6       ; Initialize division counters

 +7        FOR I=1:1:8

               SET IB(IBDIV,IBCAT,I)=0

 +8        QUIT 

 +9       ;

EN        ; - Compile entry point from IBJDF61.

 +1       ;   Pre-set variables IBA, IBCAT, IBDIV required.

 +2        NEW I,IB0,IBAGE,IBARD,IBOUT,J

 +3       ;

 +4       ; - Add totals for summary.

 +5       ; No activation date.

           SET IBARD=$$ACT^IBJDF2(IBA)

           if 'IBARD

               GOTO ENQ

 +6        SET IBOUT=0

           FOR I=1:1:5

               SET IBOUT=IBOUT+$PIECE($GET(^PRCA(430,IBA,7)),U,I)

 +7        SET IBAGE=$$FMDIFF^XLFDT(DT,IBARD)

           SET IB0=$$CAT(IBAGE)

 +8        SET $PIECE(IB(IBDIV,IBCAT,IB0),U)=+IB(IBDIV,IBCAT,IB0)+1

 +9        SET $PIECE(IB(IBDIV,IBCAT,IB0),U,2)=$PIECE(IB(IBDIV,IBCAT,IB0),U,2)+IBOUT

ENQ        QUIT 

 +1       ;

PRT       ; - Print entry point from IBJDF62.

 +1       ;

 +2       ; - Extract summary data.

 +3        IF $GET(IBXTRACT)

               DO EXTMO(.IB)

               GOTO ENQ1

 +4       ;

 +5        SET IBDIV=""

 +6        FOR 

               SET IBDIV=$ORDER(IB(IBDIV))

               if IBDIV=""

                   QUIT 

               DO SUM(IBDIV)

               if IBQ

                   QUIT 

 +7       ;

ENQ1       QUIT 

 +1       ;

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

 +1       ; IBS - Array containing the summary information

 +2       ;

 +3        NEW IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ

 +4       ;

 +5        FOR IBI=1,2,3

               FOR IBJ=1:1:16

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

 +6       ;

 +7        FOR IBCT=6,7,10

               Begin DoDot:1

 +8                SET IBTP=0

 +9       ;  Workman's Comp.

                   IF IBCT=7

                       SET IBTP=1

 +10      ;  NO-Fault Auto Accident

                   IF IBCT=10

                       SET IBTP=2

 +11      ;  Tort-Feasor

                   IF IBCT=6

                       SET IBTP=3

 +12               SET IBSQ=1

 +13               FOR IBI=1:1:7

                       Begin DoDot:2

 +14                       SET IBZ=$GET(IBS(0,IBCT,IBI))

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

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

 +17                       SET IB(IBTP,15)=IB(IBTP,15)+IBZ

 +18                       SET IB(IBTP,16)=IB(IBTP,16)+$PIECE(IBZ,"^",2)

 +19                       SET IBSQ=IBSQ+2

                       End DoDot:2

 +20               SET IB(IBTP,16)=$FNUMBER(IB(IBTP,16),"",2)

               End DoDot:1

 +21      ;

 +22       FOR IBR=22:1:24

               DO E^IBJDE(IBR,0)

 +23       QUIT 

 +24      ;

SUM(IBDIV) ; - Print summary for division.

 +1       ;  Input: IBDIV=Pointer to the division in file #40.8 and pre-set

 +2       ;         variable IBRPT

 +3        NEW IBDH,IBTYP,I,J,Z,%

 +4       ; patch IB*2.0*618

           NEW IBCATNM

 +5       ;

 +6        SET IBCAT=0

 +7        FOR 

               SET IBCAT=$ORDER(IB(IBDIV,IBCAT))

               if 'IBCAT

                   QUIT 

               Begin DoDot:1

 +8       ; patch IB*2.0*618

                   SET IBCATNM=$$ARCAT^IBJDF62(IBCAT)

 +9                DO HDR

                   if IBQ

                       QUIT 

 +10               SET IBTYP=$GET(IBCATNM)_" RECEIVABLES"

 +11               WRITE !!?(80-$LENGTH(IBTYP))\2,IBTYP

 +12               WRITE !?(80-$LENGTH(IBTYP)\2),$$DASH($LENGTH(IBTYP))

 +13               IF IBDIV

                       Begin DoDot:2

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

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

                       End DoDot:2

 +16      ;

 +17               WRITE !!

 +18      ;

 +19      ; - Calculate totals first.

 +20               FOR I=1:1:7

                       FOR J=1,2

                           SET $PIECE(IB(IBDIV,IBCAT,8),U,J)=$PIECE(IB(IBDIV,IBCAT,8),U,J)+$PIECE(IB(IBDIV,IBCAT,I),U,J)

 +21      ;

 +22               WRITE "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!

 +23               WRITE "-----------",?31,"-------------",?52,"-------------------------"

 +24               IF 'IB(IBDIV,IBCAT,8)

                       WRITE !!,"There are no active receivables",$SELECT(IBDIV:" for this division",1:""),".",!!

                       DO PAUSE

                       QUIT 

 +25      ;

 +26      ; - Primary loop to write results.

 +27               SET Y=$PIECE(IB(IBDIV,IBCAT,8),U,2)

                   FOR I=1:1:8

                       SET X=$PIECE($TEXT(CATN+I),";;",2,99)

                       Begin DoDot:2

 +28                       if I=8

                               WRITE !

                           WRITE !,X,?30,$JUSTIFY(+IB(IBDIV,IBCAT,I),6)

 +29                       WRITE "  (",$JUSTIFY(+IB(IBDIV,IBCAT,I)/+IB(IBDIV,IBCAT,8)*100,0,$SELECT(I=8:0,1:2)),"%)"

 +30                       SET Z=$FNUMBER($PIECE(IB(IBDIV,IBCAT,I),U,2),",",2)

 +31                       WRITE ?52,$JUSTIFY($SELECT(I=1!(I=9):"$",1:"")_Z,15)

 +32                       WRITE "  (",$JUSTIFY($SELECT('Y:0,1:$PIECE(IB(IBDIV,IBCAT,I),U,2)/Y*100),0,$SELECT(I=8:0,1:2)),"%)"

 +33                       if I=8

                               WRITE !!

                       End DoDot:2

 +34      ;

 +35               DO PAUSE

               End DoDot:1

               if IBQ

                   QUIT 

 +36      ;

SUMQ       QUIT 

 +1       ;

HDR       ; - Write the summary report header.

 +1        NEW X,PD,PDA,PDF,PDL

 +2       ;

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

               WRITE @IOF,*13

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

 +5        WRITE "MISCELLANEOUS BILLS FOLLOW-UP SUMMARY REPORT"

 +6        WRITE ?71,"Page: ",$JUSTIFY(IBPAG,3),!,"Run Date: ",IBRUN

 +7        SET X=""

 +8        IF IBRPT="D"

               Begin DoDot:1

 +9                IF IBSMN'="A"

                       Begin DoDot:2

 +10                       SET X="  RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "

                       End DoDot:2

 +11      ; Modified the Patient/Debtor dividing line

 +12               IF IBCAT(IBCAT)>7

                       SET PD="DEBTORS"

                       SET PDA=IBSDA

                       SET PDF=IBSDF

                       SET PDL=IBSDL

 +13               IF IBCAT(IBCAT)<8

                       SET PD="PATIENTS"

                       SET PDA=IBSNA

                       SET PDF=IBSNF

                       SET PDL=IBSNL

 +14               IF $GET(PDA)'="ALL"

                       Begin DoDot:2

 +15                       SET X=X_"/ "_PD_" FROM '"_$SELECT(PDF="":"FIRST",1:PDF)_"' TO '"

 +16                       SET X=X_$SELECT(PDL="zzzzz":"LAST",1:PDL)_"' "

                       End DoDot:2

 +17               IF $GET(IBSAM)

                       SET X=X_"/ MINIMUM BALANCE: $"_$FNUMBER(IBSAM,",",2)_" "

               End DoDot:1

 +18       SET $EXTRACT(X,1,2)=""

 +19       IF X'=""

               FOR I=1:1

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

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

                   IF X=""

                       QUIT 

 +20      ;

 +21       QUIT 

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       ;

CAT(X)    ; - Determine category to place receivable.

 +1        QUIT $SELECT($GET(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)

 +2       ;

CATN      ; - List of category names.

 +1       ;;Less than 30 days old

 +2       ;;31-60 days

 +3       ;;61-90 days

 +4       ;;91-120 days

 +5       ;;121-180 days

 +6       ;;181-365 days

 +7       ;;Over 365 days

 +8       ;;Total