IBAGMR1 ;WOIFO/AAT-GMT SINGLE PATIENT REPORT;12-JUL-02
;;2.0;INTEGRATED BILLING;**183**;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
; IBBDT - Beginning date
; IBEDT - Ending date
; Output:
; IBQUIT = 1, if user entered "^" (Devices starting with "C-" only)
REPORT ;
N IBDT,IBDTE,IBDTH,IBCR,IBDA,IBAT,IBTMP,IBZ,IBCL,IBDTBF,IBDTBT
S IBQUIT=0
S IBTMP=$NA(^TMP($J,"IBAGMR")) ; The node of TMP array
K @IBTMP
;
; Marking beginning and ending of each clock within the range.
S IBDT="" F D Q:'IBDT Q:(-IBDT)<IBBDT
. S IBDT=$O(^IBE(351,"AIVDT",IBDFN,IBDT)) Q:'IBDT
. S IBCL=0 F D Q:'IBCL
.. S IBCL=$O(^IBE(351,"AIVDT",IBDFN,IBDT,IBCL)) Q:'IBCL
.. S IBZ=$G(^IBE(351,IBCL,0)) Q:IBZ=""
.. I $P(IBZ,U,4)=3 Q ; Status - CANCELLED
.. I (-IBDT)'<IBBDT,(-IBDT)'>IBEDT S @IBTMP@(-IBDT,"C")=IBCL ; Mark the beginning of the clock
.. ;S IBDTE=$P(+$P(IBZ,U,10),".") ;Expiration date
.. ;I IBDTE,IBDTE'<IBBDT,IBDTE'>IBEDT S @IBTMP@(IBDTE,"E")=IBCL ; Mark the ending of the clock
;
; Get the charges from file #350.
; IBDT here - Parent Event Date
S IBDT=-(IBEDT+.00001) F S IBDT=$O(^IB("AFDT",IBDFN,IBDT)) Q:'IBDT D
. 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
... S IBZ=$G(^IB(IBDA,0)) I 'IBZ Q
... Q:$P(IBZ,U,8)["ADMISSION"
... ; Bill 'To' and 'From' dates
... S IBDTBF=$P(IBZ,U,14),IBDTBT=$P(IBZ,U,15) S:IBDTBT="" IBDTBT=IBDTBF
... I IBDTBT<IBBDT Q
... I IBDTBF>IBEDT Q
... S IBAT=$P(IBZ,U,3) Q:'IBAT ; Action type is really required
... I $$ACTNM^IBOUTL(IBAT)["LTC " Q ; Exclude LTC action type
... S @IBTMP@(+$P(IBZ,U,14),"I"_IBDA)=IBZ
;
D PRINT
K @IBTMP ; Kill the temporary global node
S:$D(ZTQUEUED) ZTREQ="@" ; for Taskman
Q
;
PRINT ; Print report from the temp. global
N IBLINE,IBPAG,IBTOT,IBTOTS,IBPT,IBH,IBD,IBTY,IBDA,IBZ,IBCHG,IBSAV,IBSEQ,IBGMT,X,X2,X3,Y,%,IBCIS
D NOW^%DTC S IBDTH=$$FMTE^XLFDT($E(%,1,12))
S IBLINE="",$P(IBLINE,"=",IOM+1)="",(IBPAG,IBTOT,IBTOTS,IBQUIT,IBCHG)=0
S IBPT=$$PT^IBEFUNC(IBDFN)
S IBCIS=0
S IBH="GMT Single Patient Report for "_$P(IBPT,U)_" "_$P(IBPT,U,2) D HDR
I '$D(@IBTMP) W !!,"The patient has no MT/GMT bills within the specified period" D PAUSE(1) Q
; - 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 IBTY="C" W !,$$DAT(IBD),?10,"Begin Means Test Billing Clock" K @IBTMP@(IBD,"E") Q
.. I IBTY="E" W !,$$DAT(IBD),?10,"Expire Means Test Billing Clock" Q
.. W !,$$DAT(IBD)
.. S IBDA=+$E(IBTY,2,99),IBZ=$G(^IB(IBDA,0)),IBSEQ=0
.. S IBAT=+$P(IBZ,U,3)
.. I $P(IBZ,U,14)'=$P(IBZ,U,15) W ?10,$$DAT($P(IBZ,U,15))
.. S IBSEQ=$P($G(^IBE(350.1,+$P(IBZ,U,3),0)),U,5)
.. W ?20,$E($$ACTNM^IBOUTL(+$P(IBZ,U,3)),1,25)
.. W ?46,$$STAT()
.. S IBCHG=+$P(IBZ,U,7)
.. S IBGMT=$P(IBZ,U,21)
.. I IBSEQ=2 S IBCHG=-IBCHG I 'IBGMT S IBGMT=$P($G(^IB(+$P(IBZ,U,9),0)),U,21)
.. ; The Charge provide GMT Savings if it has GMT RELATED field set to "1"
.. S IBSAV=$S(IBGMT:IBCHG*4,1:0) ;GMT Savings
.. I $P(IBZ,U,11)="",$P($G(^IBE(350.21,+$P(IBZ,U,5),0)),U,5) S (IBCHG,IBSAV)=0
.. W ?56,$$FORMAT(IBCHG,10) W:IBSAV ?68,$$FORMAT(IBSAV,10)
.. S IBTOT=IBTOT+IBCHG ; Total
.. S IBTOTS=IBTOTS+IBSAV ; Savings total
.. I IBSEQ=2!($P(IBZ,U,11)=""&($P($G(^IBE(350.21,+$P(IBZ,U,5),0)),U,5))) W !?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,+$P(IBZ,U,10),0)):$P(^(0),U),1:"UNKNOWN")
Q:IBQUIT
I IBTOT D TOTALS
D PAUSE(1)
Q
;Number format
FORMAT(IBNUM,IBDIG,IBFRM) ;
N X,X1,X2,X3
S X=IBNUM,X2=$G(IBFRM,"2$"),X3=IBDIG
D COMMA^%DTC
Q X
;
CHKSTOP I $Y>(IOSL-5) D PAUSE(0) Q:IBQUIT D HDR
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(IBBDT)," through ",$$DAT(IBEDT)
W ?IOM-36,IBDTH,?IOM-9,"Page: ",IBPAG
W !,"BILL FROM BILL TO BILL TYPE",?46,"BILL # TOT CHRG TOT GMT DIFF"
W ! F IBI=1:1:80 W "-"
Q
;
TOTALS N IBI,X
W !,?56 F IBI=1:1:22 W "-"
W !,?54,$$FORMAT(IBTOT,12),?66,$$FORMAT(IBTOTS,12)
Q
;
STAT() ; Display bill number or status
N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBZ,U,5),0))
Q $S($P(IBSTAT,U,6):$$HLD(+$P(IBZ,U,5)),$P(IBZ,U,5)=99:"Converted",$P(IBZ,U,11)]"":$P($P(IBZ,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")
;
; Action Billing Group
BILGR(IBACT) ; Input pointer to Action Type File #350.1
; Output - Billing Group
N IBNEW
S IBNEW=$P($G(^IBE(350.1,+IBACT,0)),U,9) ;New action type
Q +$S($P($G(^IBE(350.1,+IBNEW,0)),U,11):$P(^(0),U,11),1:$P($G(^IBE(350.1,+IBACT,0)),U,11))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAGMR1 5322 printed Apr 09, 2024@21:30:31 Page 2
IBAGMR1 ;WOIFO/AAT-GMT SINGLE PATIENT REPORT;12-JUL-02
+1 ;;2.0;INTEGRATED BILLING;**183**;21-MAR-94
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified
+3 QUIT
+4 ;
+5 ; Prints report to the current device
+6 ;
+7 ; Input:
+8 ; IBDFN - Patient IEN
+9 ; IBBDT - Beginning date
+10 ; IBEDT - Ending date
+11 ; Output:
+12 ; IBQUIT = 1, if user entered "^" (Devices starting with "C-" only)
REPORT ;
+1 NEW IBDT,IBDTE,IBDTH,IBCR,IBDA,IBAT,IBTMP,IBZ,IBCL,IBDTBF,IBDTBT
+2 SET IBQUIT=0
+3 ; The node of TMP array
SET IBTMP=$NAME(^TMP($JOB,"IBAGMR"))
+4 KILL @IBTMP
+5 ;
+6 ; Marking beginning and ending of each clock within the range.
+7 SET IBDT=""
FOR
Begin DoDot:1
+8 SET IBDT=$ORDER(^IBE(351,"AIVDT",IBDFN,IBDT))
if 'IBDT
QUIT
+9 SET IBCL=0
FOR
Begin DoDot:2
+10 SET IBCL=$ORDER(^IBE(351,"AIVDT",IBDFN,IBDT,IBCL))
if 'IBCL
QUIT
+11 SET IBZ=$GET(^IBE(351,IBCL,0))
if IBZ=""
QUIT
+12 ; Status - CANCELLED
IF $PIECE(IBZ,U,4)=3
QUIT
+13 ; Mark the beginning of the clock
IF (-IBDT)'<IBBDT
IF (-IBDT)'>IBEDT
SET @IBTMP@(-IBDT,"C")=IBCL
+14 ;S IBDTE=$P(+$P(IBZ,U,10),".") ;Expiration date
+15 ;I IBDTE,IBDTE'<IBBDT,IBDTE'>IBEDT S @IBTMP@(IBDTE,"E")=IBCL ; Mark the ending of the clock
End DoDot:2
if 'IBCL
QUIT
End DoDot:1
if 'IBDT
QUIT
if (-IBDT)<IBBDT
QUIT
+16 ;
+17 ; Get the charges from file #350.
+18 ; IBDT here - Parent Event Date
+19 SET IBDT=-(IBEDT+.00001)
FOR
SET IBDT=$ORDER(^IB("AFDT",IBDFN,IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+20 SET IBCR=0
FOR
SET IBCR=$ORDER(^IB("AFDT",IBDFN,IBDT,IBCR))
if 'IBCR
QUIT
Begin DoDot:2
+21 SET IBDA=0
FOR
SET IBDA=$ORDER(^IB("AF",IBCR,IBDA))
if 'IBDA
QUIT
Begin DoDot:3
+22 SET IBZ=$GET(^IB(IBDA,0))
IF 'IBZ
QUIT
+23 if $PIECE(IBZ,U,8)["ADMISSION"
QUIT
+24 ; Bill 'To' and 'From' dates
+25 SET IBDTBF=$PIECE(IBZ,U,14)
SET IBDTBT=$PIECE(IBZ,U,15)
if IBDTBT=""
SET IBDTBT=IBDTBF
+26 IF IBDTBT<IBBDT
QUIT
+27 IF IBDTBF>IBEDT
QUIT
+28 ; Action type is really required
SET IBAT=$PIECE(IBZ,U,3)
if 'IBAT
QUIT
+29 ; Exclude LTC action type
IF $$ACTNM^IBOUTL(IBAT)["LTC "
QUIT
+30 SET @IBTMP@(+$PIECE(IBZ,U,14),"I"_IBDA)=IBZ
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 DO PRINT
+33 ; Kill the temporary global node
KILL @IBTMP
+34 ; for Taskman
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+35 QUIT
+36 ;
PRINT ; Print report from the temp. global
+1 NEW IBLINE,IBPAG,IBTOT,IBTOTS,IBPT,IBH,IBD,IBTY,IBDA,IBZ,IBCHG,IBSAV,IBSEQ,IBGMT,X,X2,X3,Y,%,IBCIS
+2 DO NOW^%DTC
SET IBDTH=$$FMTE^XLFDT($EXTRACT(%,1,12))
+3 SET IBLINE=""
SET $PIECE(IBLINE,"=",IOM+1)=""
SET (IBPAG,IBTOT,IBTOTS,IBQUIT,IBCHG)=0
+4 SET IBPT=$$PT^IBEFUNC(IBDFN)
+5 SET IBCIS=0
+6 SET IBH="GMT Single Patient Report for "_$PIECE(IBPT,U)_" "_$PIECE(IBPT,U,2)
DO HDR
+7 IF '$DATA(@IBTMP)
WRITE !!,"The patient has no MT/GMT bills within the specified period"
DO PAUSE(1)
QUIT
+8 ; - first, print detail lines
+9 SET IBD=""
FOR
SET IBD=$ORDER(@IBTMP@(IBD))
if 'IBD
QUIT
Begin DoDot:1
+10 SET IBTY=""
FOR
SET IBTY=$ORDER(@IBTMP@(IBD,IBTY))
if IBTY=""
QUIT
Begin DoDot:2
+11 DO CHKSTOP
if IBQUIT
QUIT
+12 IF IBTY="C"
WRITE !,$$DAT(IBD),?10,"Begin Means Test Billing Clock"
KILL @IBTMP@(IBD,"E")
QUIT
+13 IF IBTY="E"
WRITE !,$$DAT(IBD),?10,"Expire Means Test Billing Clock"
QUIT
+14 WRITE !,$$DAT(IBD)
+15 SET IBDA=+$EXTRACT(IBTY,2,99)
SET IBZ=$GET(^IB(IBDA,0))
SET IBSEQ=0
+16 SET IBAT=+$PIECE(IBZ,U,3)
+17 IF $PIECE(IBZ,U,14)'=$PIECE(IBZ,U,15)
WRITE ?10,$$DAT($PIECE(IBZ,U,15))
+18 SET IBSEQ=$PIECE($GET(^IBE(350.1,+$PIECE(IBZ,U,3),0)),U,5)
+19 WRITE ?20,$EXTRACT($$ACTNM^IBOUTL(+$PIECE(IBZ,U,3)),1,25)
+20 WRITE ?46,$$STAT()
+21 SET IBCHG=+$PIECE(IBZ,U,7)
+22 SET IBGMT=$PIECE(IBZ,U,21)
+23 IF IBSEQ=2
SET IBCHG=-IBCHG
IF 'IBGMT
SET IBGMT=$PIECE($GET(^IB(+$PIECE(IBZ,U,9),0)),U,21)
+24 ; The Charge provide GMT Savings if it has GMT RELATED field set to "1"
+25 ;GMT Savings
SET IBSAV=$SELECT(IBGMT:IBCHG*4,1:0)
+26 IF $PIECE(IBZ,U,11)=""
IF $PIECE($GET(^IBE(350.21,+$PIECE(IBZ,U,5),0)),U,5)
SET (IBCHG,IBSAV)=0
+27 WRITE ?56,$$FORMAT(IBCHG,10)
if IBSAV
WRITE ?68,$$FORMAT(IBSAV,10)
+28 ; Total
SET IBTOT=IBTOT+IBCHG
+29 ; Savings total
SET IBTOTS=IBTOTS+IBSAV
+30 IF IBSEQ=2!($PIECE(IBZ,U,11)=""&($PIECE($GET(^IBE(350.21,+$PIECE(IBZ,U,5),0)),U,5)))
WRITE !?5,"Charge Removal Reason: ",$SELECT($DATA(^IBE(350.3,+$PIECE(IBZ,U,10),0)):$PIECE(^(0),U),1:"UNKNOWN")
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+31 if IBQUIT
QUIT
+32 IF IBTOT
DO TOTALS
+33 DO PAUSE(1)
+34 QUIT
+35 ;Number format
FORMAT(IBNUM,IBDIG,IBFRM) ;
+1 NEW X,X1,X2,X3
+2 SET X=IBNUM
SET X2=$GET(IBFRM,"2$")
SET X3=IBDIG
+3 DO COMMA^%DTC
+4 QUIT X
+5 ;
CHKSTOP IF $Y>(IOSL-5)
DO PAUSE(0)
if IBQUIT
QUIT
DO HDR
+1 QUIT
+2 ;
+3 ;
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(IBBDT)," through ",$$DAT(IBEDT)
+5 WRITE ?IOM-36,IBDTH,?IOM-9,"Page: ",IBPAG
+6 WRITE !,"BILL FROM BILL TO BILL TYPE",?46,"BILL # TOT CHRG TOT GMT DIFF"
+7 WRITE !
FOR IBI=1:1:80
WRITE "-"
+8 QUIT
+9 ;
TOTALS NEW IBI,X
+1 WRITE !,?56
FOR IBI=1:1:22
WRITE "-"
+2 WRITE !,?54,$$FORMAT(IBTOT,12),?66,$$FORMAT(IBTOTS,12)
+3 QUIT
+4 ;
STAT() ; Display bill number or status
+1 NEW IBSTAT
SET IBSTAT=$GET(^IBE(350.21,+$PIECE(IBZ,U,5),0))
+2 QUIT $SELECT($PIECE(IBSTAT,U,6):$$HLD(+$PIECE(IBZ,U,5)),$PIECE(IBZ,U,5)=99:"Converted",$PIECE(IBZ,U,11)]"":$PIECE($PIECE(IBZ,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 ; Action Billing Group
BILGR(IBACT) ; Input pointer to Action Type File #350.1
+1 ; Output - Billing Group
+2 NEW IBNEW
+3 ;New action type
SET IBNEW=$PIECE($GET(^IBE(350.1,+IBACT,0)),U,9)
+4 QUIT +$SELECT($PIECE($GET(^IBE(350.1,+IBNEW,0)),U,11):$PIECE(^(0),U,11),1:$PIECE($GET(^IBE(350.1,+IBACT,0)),U,11))
