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