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

IBAECP1.m

Go to the documentation of this file. 
  1. IBAECP1 ;WOIFO/AAT - LTC SINGLE PATIENT PROFILE ; 20-FEB-02
  1.  ;;2.0;INTEGRATED BILLING;**176,729**;21-MAR-94;Build 8
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  Q
  1.  ;
  1.  ; Prints report to the current device
  1.  ;
  1.  ; Input:
  1.  ;   IBDFN - Patient IEN
  1.  ;   IBCLK - LTC Copay Billing Clock IEN
  1.  ;   IBDT1 - Beginning date
  1.  ;   IBDT2 - Ending date
  1.  ;   IBOFD - Option: print free (exempt) days list
  1.  ;   IBOEV - Option: print LTC events
  1.  ; Output:
  1.  ;   IBQUIT = 1, if user entered "^" (Devices starting with "C-" only)
  1. REPORT ;
  1.  N IBDT,IBDTE,IBDTH,IBCR,IBDA,IBX,IBAT,IBTMP,IBZ,IBCL
  1.  S IBQUIT=0
  1.  S IBTMP=$NA(^TMP($J,"IBAECP")) ; The node of TMP array
  1.  K @IBTMP
  1.  ;
  1.  ; Marking beginning and ending of each clock within the range.
  1.  ; Not including selected LTC BILLING CLOCK
  1.  S IBDT=0 F  D  Q:'IBDT  Q:IBDT>IBDT2
  1.  . S IBDT=$O(^IBA(351.81,"AE",IBDFN,IBDT)) Q:'IBDT
  1.  . S IBCL=0 F  D  Q:'IBCL
  1.  .. S IBCL=$O(^IBA(351.81,"AE",IBDFN,IBDT,IBCL)) Q:'IBCL
  1.  .. Q:IBCL=IBCLK  ; Don't include the selected clock to the report
  1.  .. S IBZ=$G(^IBA(351.81,IBCL,0)) Q:IBZ=""
  1.  .. I $P(IBZ,U,5)=3 Q  ; Status - FOR CANCELLED
  1.  .. I IBDT'<IBDT1,IBDT'>IBDT2 S @IBTMP@(IBDT,"C")=IBCL ; Mark the beginning of the clock
  1.  .. S IBDTE=$P(+$P(IBZ,U,4),".")
  1.  .. I IBDTE,IBDTE'<IBDT1,IBDTE'>IBDT2 S @IBTMP@(IBDTE,"E")=IBCL ; Mark the ending of the clock
  1.  ;
  1.  ;
  1.  ; Get the charges from file #350.
  1.  S IBDT="" F  S IBDT=$O(^IB("AFDT",IBDFN,IBDT)) Q:'IBDT  D:-IBDT'>IBDT2
  1.  . S IBCR=0 F  S IBCR=$O(^IB("AFDT",IBDFN,IBDT,IBCR)) Q:'IBCR  D
  1.  .. S IBDA=0 F  S IBDA=$O(^IB("AF",IBCR,IBDA)) Q:'IBDA  D
  1.  ...  Q:'$D(^IB(IBDA,0))  S IBX=^(0)
  1.  ...  ;;; Q:$P(IBX,U,8)["ADMISSION" ; Not sure it is needed
  1.  ...  I $P(IBX,U,15)<IBDT1 Q
  1.  ...  I $P(IBX,U,14)>IBDT2 Q
  1.  ...  S IBAT=$P(IBX,U,3) Q:'IBAT  ; Action type is really required
  1.  ...  I $$ACTNM^IBOUTL(IBAT)'["LTC " Q  ; Not an LTC action type
  1.  ...  S @IBTMP@(+$P(IBX,U,14),"I"_IBDA)=""
  1.  ;
  1.  D PRINT
  1.  K @IBTMP ; Kill the global node
  1.  K ^TMP($J,"180DAYS")
  1.  K ^TMP($J,"IBMJINP")
  1.  K ^TMP($J,"IBMJOUT")
  1.  S:$D(ZTQUEUED) ZTREQ="@" ; for Taskman
  1.  Q
  1.  ;
  1. PRINT ; Print report from the temp. global
  1.  N IBLINE,IBPAG,IBTOT,IBTOTM,IBTOTP,IBPT,IBH,IBD,IBTY,IBDA,IBDZ,IBCHG,IBSEQ,X,X2,X3,Y,%,IBCURM,IBCURY,IBCIS
  1.  D NOW^%DTC S IBDTH=$$FMTE^XLFDT($E(%,1,12))
  1.  S IBLINE="",$P(IBLINE,"=",IOM+1)="",(IBPAG,IBTOT,IBTOTM,IBQUIT,IBCHG,IBTOTP)=0
  1.  S IBPT=$$PT^IBEFUNC(IBDFN)
  1.  S IBCIS=0
  1.  S IBH="LTC Billing Profile for "_$P(IBPT,U) D HDR  ; IB*2.0*729
  1.  ;;; D CLKINFO ; Print brief clock info
  1.  I '$D(@IBTMP) W !!,"The patient has no LTC bills within the specified period" D PAUSE(1) Q
  1.  S (IBCURM,IBCURY)=0 ; Current month and year
  1.  ; - first, print detail lines
  1.  S IBD="" F  S IBD=$O(@IBTMP@(IBD)) Q:'IBD  D  Q:IBQUIT
  1.  . S IBTY="" F  S IBTY=$O(@IBTMP@(IBD,IBTY)) Q:IBTY=""  D  Q:IBQUIT
  1.  ..  D CHKSTOP Q:IBQUIT
  1.  ..  I (+$E(IBD,4,5)'=IBCURM)!(+$E(IBD,1,3)'=IBCURY) D MONTOTAL
  1.  ..  I IBTY="C" W !,$$DAT(IBD),?18,"Start another LTC Copay Clock" Q
  1.  ..  I IBTY="E" W !,$$DAT(IBD),?18,"Expire another LTC Copay Clock" Q
  1.  ..  ; If the month has been changed
  1.  ..  I +$E(IBD,4,5)'=IBCURM D PRMON(IBD) S IBTOTM=0 ; Monthly total
  1.  ..  W !,$$DAT(IBD)
  1.  ..  S IBDA=+$E(IBTY,2,99),IBDZ=$G(^IB(IBDA,0)),IBSEQ=0
  1.  ..  I $P(IBDZ,U,14)'=$P(IBDZ,U,15) W ?12,$$DAT($P(IBDZ,U,15))
  1.  ..  S IBSEQ=$P($G(^IBE(350.1,+$P(IBDZ,U,3),0)),U,5)
  1.  ..  W ?24,$$ACTNM^IBOUTL(+$P(IBDZ,U,3))
  1.  ..  W ?54,$$STAT()
  1.  ..  S IBCHG=+$P(IBDZ,U,7)
  1.  ..  I IBSEQ=2 S IBCHG=-IBCHG
  1.  ..  I $P(IBDZ,U,11)="",$P($G(^IBE(350.21,+$P(IBDZ,U,5),0)),U,5) S IBCHG=0
  1.  ..  S X=IBCHG,X2="2$",X3=10 D COMMA^%DTC W ?65,X
  1.  ..  S IBTOT=IBTOT+IBCHG ; Total
  1.  ..  S IBTOTM=IBTOTM+IBCHG ; Monthly total
  1.  ..  I IBSEQ=2!($P(IBDZ,U,11)=""&($P($G(^IBE(350.21,+$P(IBDZ,U,5),0)),U,5))) W !?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,+$P(IBDZ,U,10),0)):$P(^(0),U),1:"UNKNOWN")
  1.  ..  S IBTOTP=1
  1.  Q:IBQUIT
  1.  D MONTOTAL
  1.  D PAUSE(1)
  1.  Q
  1. CHKSTOP I $Y>(IOSL-5) D PAUSE(0) Q:IBQUIT  D HDR
  1.  Q
  1.  ;
  1.  ;
  1.  ; Print month header
  1. PRMON(IBDT) ;
  1.  S IBCURM=+$E(IBDT,4,5)
  1.  S IBCURY=+$E(IBDT,1,3)
  1.  W !,"LTC CHARGES FOR ",$$MONNAM(IBCURM)," ",IBCURY+1700
  1.  ;
  1.  Q
  1.  ;
  1. MONNAM(IBM) ;Name of the month by number
  1.  Q $P("JANUARY;FEBRUARY;MARCH;APRIL;MAY;JUNE;JULY;AUGUST;SEPTEMBER;OCTOBER;NOVEMBER;DECEMBER",";",IBM)
  1.  ;
  1.  ; Totals for the month (and monthly cap)
  1. MONTOTAL N X,X2,X3,IBDTM1,IBDTM2,IBCAP
  1.  Q:'IBTOTP
  1.  D CHKSTOP Q:IBQUIT
  1.  W !?65,"---------"
  1.  D CHKSTOP Q:IBQUIT
  1.  K ^TMP($J,"180DAYS")
  1.  K ^TMP($J,"IBMJINP")
  1.  K ^TMP($J,"IBMJOUT")
  1.  S IBDTM1=IBCURY_$S(IBCURM>10:IBCURM,1:"0"_IBCURM)_"01" ; First day of month
  1.  S IBDTM2=$$LASTDT^IBAECU(IBDTM1) ; Last day of month
  1.  I $$INPINFO^IBAECU2(IBDTM1,IBDTM2,IBDFN,"IBMJINP",1) ;"no inpatient stay"
  1.  I $$OUTPINFO^IBAECU3(IBDTM1,IBDTM2,IBDFN,"IBMJOUT") ;"no outpatient visits"
  1.  S IBCAP=$$CLCK180^IBAECM2(IBDFN,IBDTM1,IBDTM2,"IBMJINP")
  1.  ;
  1.  W !?5,"Monthly LTC Copay Cap: " S X=+IBCAP,X2="2$",X3=12 D COMMA^%DTC W ?25,X
  1.  ; Indicate 1-180 of 180+ flag
  1.  W " (",$S('$P(IBCAP,U,2):"1-180 days",1:"181+ days"),") "
  1.  S X=IBTOTM,X2="2$",X3=12 D COMMA^%DTC W ?63,X
  1.  I IBOEV D EVENTS
  1.  S IBCURM=0 ; Set current month to unknown
  1.  S IBTOTP=0
  1.  W !
  1.  Q
  1.  ;
  1. HDR ; Print header.
  1.  N IBI
  1.  I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
  1.  S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
  1.  W !,"From ",$$DAT(IBDT1)," through ",$$DAT(IBDT2)
  1.  W ?IOM-36,IBDTH,?IOM-9,"Page: ",IBPAG
  1.  I 'IBCIS S IBCIS=1 D CLKINFO ; Print brief clock info
  1.  W !,"BILL DATE   BILL TO     BILL TYPE",?55,"BILL #    TOT CHARGE"
  1.  W ! F IBI=1:1:80 W "-"
  1.  Q
  1.  ;
  1. STAT() ; Display bill number or status
  1.  N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBDZ,U,5),0))
  1.  Q $S($P(IBSTAT,U,6):$$HLD(+$P(IBDZ,U,5)),$P(IBDZ,U,5)=99:"Converted",$P(IBDZ,U,11)]"":$P($P(IBDZ,U,11),"-",2),$P(IBSTAT,U,5):"Cancelled",1:"Pending")
  1.  ;
  1. HLD(STAT) ; Return an 'on hold' status string
  1.  Q "Hold "_$S(STAT=20:"Rate",STAT=21:"Rev",1:"Ins")
  1.  ;
  1. PAUSE(IBEND) ;
  1.  Q:$E(IOST,1,2)'["C-"
  1.  N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y
  1.  W !! ;F IBJ=$Y:1:(IOSL-4) W !
  1.  S DIR(0)="E"
  1.  I $G(IBEND) S DIR("A")="End of the report. Enter RETURN to continue or '^' to exit"
  1.  D ^DIR K DIR I $G(DUOUT) S IBQUIT=1 W @IOF Q
  1.  I $G(IBEND) W @IOF
  1.  Q
  1.  ;
  1. DAT(IBDT) ; Convert FM date to (mm/dd/yy) format.
  1.  Q $$FMTE^XLFDT(IBDT,"2MZ")
  1.  ;
  1.  ;For debugging only - find LTC-related records of the file #350
  1. FNDLTC N IEN,IBX,IBN
  1.  S IEN=0 F  S IEN=$O(^IB(IEN)) Q:'IEN  D
  1.  .  Q:'$D(^IB(IEN,0))  S IBX=^(0)
  1.  .  ;;; Q:$P(IBX,U,8)["ADMISSION" ; Not sure it is needed
  1.  .  S IBN=$$ACTNM^IBOUTL(+$P(IBX,U,3))
  1.  .  I IBN["LTC " W !,IEN,?10,IBN ; Not an LTC action type
  1.  W !,"Ready"
  1.  Q
  1.  ;
  1. CLKINFO ; Output short information about the clock
  1.  N IBZ,IBDT1,IBDT2,IBV,IBC,IBI,IBA,IBN
  1.  S IBZ=$G(^IBA(351.81,IBCLK,0)) I IBZ="" W !,"Corrupted record of LTC clock ",IBCLK Q 
  1.  S IBDT1=$P(IBZ,U,3)
  1.  S IBDT2=$P(IBZ,U,4)
  1.  S IBC=0 ; Counter of free days
  1.  ; Collect an array of free days:
  1.  S IBI=0 F  S IBI=$O(^IBA(351.81,IBCLK,1,IBI)) Q:'IBI  I $P(^(IBI,0),U,2) S IBC=IBC+1,IBA(IBC)=$P(^(0),U,2)
  1.  W !,IBLINE
  1.  W !?2,"LTC Copay Clock Start Date: ",$$DAT(IBDT1)
  1.  W ?50,"Clock Status: ",$$EXTERNAL^DILFD(351.81,.05,"",$P(IBZ,U,5))
  1.  I IBDT2 W !?2,"LTC Copay Clock End Date: ",$S(IBDT2:$$DAT(IBDT2),1:"none")
  1.  D:IBOFD
  1.  . W !?2,"Days Not Subject To LTC Copay:" I 'IBC W " none" Q
  1.  . S IBV=IBC\3 I IBC#3 S IBV=IBV+1
  1.  . F IBI=1:1:IBV D
  1.  ..  S IBN=IBI W !?5,$J(IBN,2),?10,$$FMTE^XLFDT(IBA(IBN))
  1.  ..  S IBN=IBI+IBV I $G(IBA(IBN)) W ?30,$J(IBN,2),?35,$$FMTE^XLFDT(IBA(IBN))
  1.  ..  S IBN=IBI+(2*IBV) I $G(IBA(IBN)) W ?55,$J(IBN,2),?60,$$FMTE^XLFDT(IBA(IBN))
  1.  W !!
  1.  Q
  1.  ;
  1.  ; Print LTC Events
  1.  ; Input:
  1.  ;  IBDFN - Patient DFN
  1.  ;  IBDTM1,IBDTM2 - First/Last days of the month, FM format
  1.  ;  ^TMP($J,"IBMJINP"),^TMP($J,"IBMJOUT") with prepared data
  1.  ; Output:
  1.  ;   Prints LTC Events report section 
  1. EVENTS N IBA,IBMOV,IBNDX,IBDAY,IBSL,IBCR,IBZ,IBZCR,IBENC,IBCNT
  1.  ; Collect data from ^TMP($J) array
  1.  S IBNDX="IBMJINP" ; Inpatient part
  1.  S IBMOV=0 F  S IBMOV=$O(^TMP($J,IBNDX,IBDFN,IBMOV)) Q:'IBMOV  D
  1.  . F IBSL="SD","LD" D
  1.  .. S IBCR=0 ; Current event begining day
  1.  .. S IBDAY=0 F  S IBDAY=$O(^TMP($J,IBNDX,IBDFN,IBMOV,IBSL,IBDAY)) Q:'IBDAY  S IBZ=^(IBDAY) D:$P(IBZ,U)'="M"  ; No means-test events
  1.  ... I 'IBCR S IBCR=IBDAY,IBA(IBCR)=$E(IBDAY,6,7)_U_$E(IBSL)_U_IBZ
  1.  ... ; I IBZCR'="",IBZCR'=IBZ S
  1.  ... Q:($O(^TMP($J,IBNDX,IBDFN,IBMOV,IBSL,IBDAY))-1)=IBDAY
  1.  ... S $P(IBA(IBCR),U)=$E(IBDAY,6,7) ; Days only
  1.  ... S IBCR=0,IBZCR=""
  1.  ;
  1.  S IBNDX="IBMJOUT" ; Outpatient part
  1.  S IBDAY=0 F  S IBDAY=$O(^TMP($J,IBNDX,IBDFN,IBDAY)) Q:'IBDAY  D
  1.  . S IBCNT=0
  1.  . S IBENC=0 F IBENC=$O(^TMP($J,IBNDX,IBDFN,IBDAY,IBENC)) Q:'IBENC  S IBZ=^(IBENC) D:$P(IBZ,U)'="M"  ; No means-test events
  1.  .. S IBA(IBDAY)="O"
  1.  .. S IBCNT=IBCNT+1
  1.  .. S IBA(IBDAY,IBCNT)=IBZ
  1.  ;
  1.  W !?5,"Monthly LTC Events:"
  1.  S IBDAY=0 F  S IBDAY=$O(IBA(IBDAY)) Q:'IBDAY  D  Q:IBQUIT
  1.  . I IBA(IBDAY)="O" D  Q  ; Outpatient events
  1.  .. S IBCNT=0 F  S IBCNT=$O(IBA(IBDAY,IBCNT)) Q:'IBCNT  D  Q:IBQUIT
  1.  ... D CHKSTOP Q:IBQUIT
  1.  ... W !?7,$$DAT(IBDAY),?30,$$ACTNM^IBOUTL($P(IBA(IBDAY,IBCNT),U,4))
  1.  . ; Inpatient events
  1.  . S IBZ=IBA(IBDAY)
  1.  . D CHKSTOP Q:IBQUIT
  1.  . W !?7,$$DAT(IBDAY) I $P(IBZ,U)'=$E(IBDAY,6,7) W " - ",?18,$$DAT($E(IBDAY,1,5)_$P(IBZ,U))
  1.  . I $P(IBZ,U,2)="L" W ?30,"ABSENT DAYS" Q
  1.  . W ?30,$$ACTNM^IBOUTL(+$P(IBZ,U,6))
  1.  Q