Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBJDF53

IBJDF53.m

Go to the documentation of this file. 
  1. IBJDF53 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (SUMMARY);15-APR-00
  1.  ;;2.0;INTEGRATED BILLING;**123,185,240,618**;21-MAR-94;Build 61
  1.  ;;Per VHA Directive 6402, this routine should not be modified.
  1.  ;
  1. INIT ; - Initialize counters, if necessary.
  1.  ;   Pre-set variables  IBCAT, IBDIV, IBSEL1 required.
  1.  N I,IB0
  1.  I '$D(IB(IBDIV,IBCAT)) D
  1.  . F IB0=1:1:4 I IBSEL1[IB0 F I=1:1:8 S IB(IBDIV,IBCAT,IB0,I)=0
  1.  ;
  1.  Q
  1.  ;
  1. EN ; - Compile entry point from IBJDF51.
  1.  ;   Pre-set variables IB(, IBA, IBCAT, IBDIV, IBSEL1, IBTYP required.
  1.  N I,IB0,IBAGE,IBARD,IBOUT
  1.  ;
  1.  ; - Add totals for summary.
  1.  S IBARD=$$ACT^IBJDF2(IBA) G:'IBARD ENQ ; No activation date.
  1.  S IBOUT=0 F I=1:1:5 S IBOUT=IBOUT+$P($G(^PRCA(430,IBA,7)),U,I)
  1.  S IBAGE=$$FMDIFF^XLFDT(DT,IBARD),IB0=$$CAT(IBAGE)
  1.  F I=IBTYP,4 I IBSEL1[I D
  1.  . S $P(IB(IBDIV,IBCAT,I,IB0),U)=+IB(IBDIV,IBCAT,I,IB0)+1
  1.  . S $P(IB(IBDIV,IBCAT,I,IB0),U,2)=$P(IB(IBDIV,IBCAT,I,IB0),U,2)+IBOUT
  1.  ;
  1. ENQ Q
  1.  ;
  1. PRT ; - Print entry point from IBJDF52.
  1.  N IBDIV
  1.  ;
  1.  ; - Extract summary data.
  1.  I $G(IBXTRACT) D EXTMO(.IB) G ENQ1
  1.  ;
  1.  S IBDIV=""
  1.  F  S IBDIV=$O(IB(IBDIV)) Q:IBDIV=""  D
  1.  . S IBCAT=0
  1.  . F  S IBCAT=$O(IB(IBDIV,IBCAT)) Q:'IBCAT  D SUM(.IBCAT) Q:IBQ
  1.  ;
  1. ENQ1 Q
  1.  ;
  1. EXTMO(IBS) ; Extract/transmit data to DM Extract Module
  1.  ; IBS - Array containing the summary information
  1.  ;
  1.  N IB,IBCT,IBI,IBJ,IBR,IBSQ,IBTP,IBZ
  1.  ;
  1.  F IBI=1:1:6 F IBJ=1:1:16 S IB(IBI,IBJ)=$S(IBJ#2:0,1:"0.00")
  1.  ;
  1.  S IBCT=""
  1.  F  S IBCT=$O(IBS(0,IBCT)) Q:IBCT=""  D
  1.  . S IBTP=0
  1.  . I IBCT=31 S IBTP=1      ;  TRICARE Patient
  1.  . I IBCT=19 Q             ;  Sharing Agreements (NOT EXTRACTED)
  1.  . I IBCT=30 S IBTP=2      ;  TRICARE
  1.  . I IBCT=75 S IBTP=2      ;  TRICARE DES  IB*2.0*618
  1.  . I IBCT=76 S IBTP=2      ;  TRICARE SCI  IB*2.0*618
  1.  . I IBCT=77 S IBTP=2      ;  TRICARE TBI  IB*2.0*618
  1.  . I IBCT=78 S IBTP=2      ;  TRICARE BLIND  IB*2.0*618
  1.  . I IBCT=79 S IBTP=2      ;  TRICARE DENTAL  IB*2.0*618
  1.  . I IBCT=80 S IBTP=2      ;  TRICARE PHARMACY  IB*2.0*618
  1.  . I IBCT=32 S IBTP=3      ;  TRICARE THIRD PARTY
  1.  . I IBCT=28 S IBTP=4      ;  CHAMPVA
  1.  . I IBCT=29 S IBTP=5      ;  CHAMPVA THRID PARTY
  1.  . S IBSQ=1
  1.  . F IBI=1:1:7 D
  1.  . . S IBZ=$G(IBS(0,IBCT,4,IBI))
  1.  . . S IB(IBTP,IBSQ)=+IBZ
  1.  . . S IB(IBTP,IBSQ+1)=$FN(+$P(IBZ,"^",2),"",2)
  1.  . . S IB(IBTP,15)=IB(IBTP,15)+IBZ
  1.  . . S IB(IBTP,16)=IB(IBTP,16)+$P(IBZ,"^",2)
  1.  . . S IBSQ=IBSQ+2
  1.  . S IB(IBTP,16)=$FN(IB(IBTP,16),"",2)
  1.  ;
  1.  F IBR=17:1:21 D E^IBJDE(IBR,0)
  1.  Q
  1.  ;
  1. SUM(IBCAT) ; - Print summary for AR category.
  1.  ;  Input: IBCAT=AR category pointer to file #430.2, and pre-set
  1.  ;         variables IBDIV and IBRPT
  1.  N IBDH,IBTYP,IBTYPH,I,J
  1.  N IBCATNM  ; patch IB*2.0*618
  1.  ;
  1.  S (IBFLG,IBTYP)=0 D HDR
  1.  F  S IBTYP=$O(IB(IBDIV,IBCAT,IBTYP)) Q:'IBTYP  D  Q:IBQ
  1.  . S IBCATNM=$$ARCAT^IBJDF62(IBCAT)  ; patch IB*2.0*618
  1.  . I $Y>(IOSL-16) D HDR Q:IBQ
  1.  . S IBTYPH=$G(IBCATNM)_" RECEIVABLES ("_$G(IBTPR(IBTYP))_")"
  1.  . W !!!?(80-$L(IBTYPH))\2,IBTYPH
  1.  . W !?(80-$L(IBTYPH)\2),$$DASH($L(IBTYPH))
  1.  . I IBDIV D
  1.  . . S IBDH="Division: "_$P($G(^DG(40.8,IBDIV,0)),U)
  1.  . . W !?(80-$L(IBDH)\2),IBDH
  1.  . W !!
  1.  . ;
  1.  . ; - Calculate totals first.
  1.  . F I=1:1:7 F J=1,2 S $P(IB(IBDIV,IBCAT,IBTYP,8),U,J)=$P(IB(IBDIV,IBCAT,IBTYP,8),U,J)+$P(IB(IBDIV,IBCAT,IBTYP,I),U,J)
  1.  . ;
  1.  . W "AR Category",?31,"# Receivables",?52,"Total Outstanding Balance",!
  1.  . W "-----------",?31,"-------------",?52,"-------------------------"
  1.  . I 'IB(IBDIV,IBCAT,IBTYP,8) D  D PAUSE Q
  1.  . . W !!,"There are no active receivables",$S(IBDIV:" for this division",1:""),"."
  1.  . . S IBFLG=1
  1.  . ;
  1.  . ; - Primary loop to write results.
  1.  . S Y=$P(IB(IBDIV,IBCAT,IBTYP,8),U,2)
  1.  . F I=1:1:8 S X=$P($T(CATN+I),";;",2,99) D
  1.  . . W:I=8 ! W !,X,?30,$J(+IB(IBDIV,IBCAT,IBTYP,I),6)
  1.  . . W "  (",$J(+IB(IBDIV,IBCAT,IBTYP,I)/+IB(IBDIV,IBCAT,IBTYP,8)*100,0,$S(I=8:0,1:2)),"%)"
  1.  . . S Z=$FN($P(IB(IBDIV,IBCAT,IBTYP,I),U,2),",",2)
  1.  . . W ?52,$J($S(I=1!(I=9):"$",1:"")_Z,15)
  1.  . . W "  (",$J($S('Y:0,1:$P(IB(IBDIV,IBCAT,IBTYP,I),U,2)/Y*100),0,$S(I=8:0,1:2)),"%)"
  1.  . ;
  1.  . D PAUSE
  1.  ;
  1. SUMQ Q
  1.  ;
  1. HDR ; - Write the summary report header.
  1.  N X
  1.  ;
  1.  I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
  1.  S IBPAG=$G(IBPAG)+1
  1.  W "CHAMPVA/TRICARE FOLLOW-UP SUMMARY REPORT"
  1.  W ?71,"Page: ",$J(IBPAG,3),!,"Run Date: ",IBRUN
  1.  S X=""
  1.  I IBRPT="D" D
  1.  . I IBSMN'="A" D
  1.  . . S X="  RECEIVABLES OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
  1.  . I $G(IBSNA)'="ALL" D
  1.  . . S X=X_"/ PATIENTS FROM '"_$S(IBSNF="":"FIRST",1:IBSNF)_"' TO '"
  1.  . . S X=X_$S(IBSNL="zzzzz":"LAST",1:IBSNL)_"' "
  1.  . I $G(IBSAM) S X=X_"/ MINIMUM BALANCE: $"_$FN(IBSAM,",",2)_" "
  1.  S $E(X,1,2)=""
  1.  I X'="" F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
  1.  ;
  1.  Q
  1.  ;
  1. DASH(X) ; - Return a dashed line.
  1.  Q $TR($J("",X)," ","=")
  1.  ;
  1. PAUSE ; - Page break.
  1.  I $E(IOST,1,2)'="C-" Q
  1.  N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
  1.  F IBX=$Y:1:(IOSL-3) W !
  1.  S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
  1.  Q
  1.  ;
  1. CAT(X) ; - Determine category to place receivable.
  1.  Q $S($G(X)<31:1,X<61:2,X<91:3,X<121:4,X<181:5,X<366:6,1:7)
  1.  ;
  1. CATN ; - List of category names.
  1.  ;;Less than 30 days old
  1.  ;;31-60 days
  1.  ;;61-90 days
  1.  ;;91-120 days
  1.  ;;121-180 days
  1.  ;;181-365 days
  1.  ;;Over 365 days
  1.  ;;Total