IBOMTP1 ;ALB/CPM - MEANS TEST BILLING PROFILE (CON'T);10-DEC-91
;;2.0;INTEGRATED BILLING;**15,153,176,183,651,656,678,747**;21-MAR-94;Build 2
;; Per VHA Directive 10-93-142, this routine should not be modified
;
N IBLEG,IBCHK
;***
;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
; Begin compilation. Start with billing clocks.
S Y=-(IBEDT+.1),X=0 F Q:-Y<IBBDT S Y=$O(^IBE(351,"AIVDT",IBDFN,Y)) Q:'Y F S X=$O(^IBE(351,"AIVDT",IBDFN,Y,X)) Q:'X S:$P($G(^IBE(351,X,0)),U,4)'=3 ^TMP($J,"IBOMTP",-Y,"C")=""
;
; Get O/P visits from file #399.
S X1=IBBDT,X2=-1 D C^%DTC S Y=X
F S Y=$O(^DGCR(399,"AOPV",IBDFN,Y)) Q:'Y!(Y>IBEDT) D
. S IBDA=0 F S IBDA=$O(^DGCR(399,"AOPV",IBDFN,Y,IBDA)) Q:'IBDA D
.. I $D(^DGCR(399,+IBDA,0)),'$P($G(^("S")),U,16),$P($G(^DGCR(399.3,+$P(^(0),U,7),0)),U)["MEANS" S ^TMP($J,"IBOMTP",Y,"M"_IBDA)=""
;
;IB*2.0*678 - add seconds to IBEDT (IBEDTP1) and use that for the End Date range
S IBEDTP1=IBEDT+.999999
; Get the rest of the charges from file #350.
S Y="" F S Y=$O(^IB("AFDT",IBDFN,Y)) Q:'Y I -Y'>IBEDTP1 S Y1=0 F S Y1=$O(^IB("AFDT",IBDFN,Y,Y1)) Q:'Y1 D
. S (IBDA,IBCHK)=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D
.. Q:'$D(^IB(IBDA,0))
.. S IBX=^IB(IBDA,0)
.. Q:$P(IBX,U,8)["ADMISSION"
.. I $P(IBX,U,15)<IBBDT!($P(IBX,U,14)>IBEDTP1) Q
.. N Y,Y1
.. ; Action type. We don't include LTC actions to the report
.. I $P(IBX,U,3) I $$ACTNM^IBOUTL(+$P(IBX,U,3))["LTC " Q ; Exclude LTC action type
.. S ^TMP($J,"IBOMTP",+$P(IBX,U,14),"I"_IBDA)="",IBCHK=1
. Q:IBCHK ;If an entry already found its not a pharmacy RX
. S IBX=$G(^IB(Y1,0))
. S IBATYP=$P(IBX,U,3),IBBLG=$$GET1^DIQ(350.1,IBATYP_",",.11,"I")
. I IBBLG=5 D ;Is this an RX copay
.. I $P(IBX,U,15)<IBBDT!($P(IBX,U,14)>IBEDTP1) Q ;Check to ensure the visit is in the correct search range
.. S ^TMP($J,"IBOMTP",+$P(IBX,U,14),"I"_Y1)="" ;Store in reporting array.
;
; Print report.
S IBLEG=0 ; Legend not required
D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBCHGT,IBQUIT)=0
S IBPT=$$PT^IBEFUNC(IBDFN)
S IBH="Means Test Billing Profile for "_$P(IBPT,U) D HDR ; IB*2.0*747
I '$D(^TMP($J,"IBOMTP")) W !,"This patient has no Means Test bills." D PAUSE^IBOUTL G END
; - first, print detail lines
S IBD="" F S IBD=$O(^TMP($J,"IBOMTP",IBD)) Q:'IBD D G:IBQUIT END
. S IBTY="" F S IBTY=$O(^TMP($J,"IBOMTP",IBD,IBTY)) Q:IBTY="" D Q:IBQUIT
.. I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
.. W !,$$DAT1^IBOUTL(IBD)
.. I IBTY="C" W ?12,"Begin Means Test Billing Clock" Q
.. S IBDA=+$E(IBTY,2,99),IBD0=$S($E(IBTY)="M":$G(^DGCR(399,IBDA,0)),1:$G(^IB(IBDA,0))),IBSEQ=0
.. I $E(IBTY)="I" S IBSEQ=$P($G(^IBE(350.1,+$P(IBD0,U,3),0)),U,5)
.. W ?14,$S($E(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$P(IBD0,U,3)))
.. W ?44,$S($E(IBTY)="M":$P(IBD0,U),1:$$STAT())
.. I $E(IBTY)="I",$P(IBD0,U,14)'=$P(IBD0,U,15) W ?54,$$DAT1^IBOUTL($P(IBD0,U,15))
.. I $E(IBTY)="M" S X=+$O(^DGCR(399,IBDA,"RC","B",500,0)),IBCHG=+$P($G(^DGCR(399,IBDA,"RC",X,0)),U,2)
.. E S IBCHG=+$P(IBD0,U,7)
.. I IBSEQ=2 S IBCHG=-IBCHG
.. I $E(IBTY)="I",$P(IBD0,U,11)="",$P($G(^IBE(350.21,+$P(IBD0,U,5),0)),U,5) S IBCHG=0
.. S X=IBCHG,X2="2$",X3=10 D COMMA^%DTC W ?65,X
.. I $P(IBD0,U,21) W " *" S IBLEG=1 ;Print legend at the bottom
.. S IBCHGT=IBCHGT+IBCHG
.. I IBSEQ=2!($P(IBD0,U,11)=""&($P($G(^IBE(350.21,+$P(IBD0,U,5),0)),U,5))) W !?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,+$P(IBD0,U,10),0)):$P(^(0),U),1:"UNKNOWN")
; - print totals line
I ($Y-IBLEG)>(IOSL-5) D LEGEND,PAUSE^IBOUTL G:IBQUIT END D HDR
W !?63,"-----------" S X=IBCHGT,X2="2$",X3=12 D COMMA^%DTC W !?63,X
D LEGEND,PAUSE^IBOUTL
; - close device and quit
END K ^TMP($J)
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
I $D(ZTQUEUED) S ZTREQ="@" Q
K IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
D ^%ZISC Q
;
;
HDR ; Print header.
S IBLEG=0
I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
W !,"From ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
W ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
W !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
W !,IBLINE,! Q
;
STAT() ; Display bill number or status
N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBD0,U,5),0))
Q $S($P(IBSTAT,U,6):$$HLD(+$P(IBD0,U,5)),$P(IBD0,U,5)=99:"Converted",$P(IBD0,U,11)]"":$P($P(IBD0,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")
;
LEGEND I $G(IBLEG) W !," '*' - Geographic Means Test rates"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOMTP1 4782 printed Dec 13, 2024@02:25:57 Page 2
IBOMTP1 ;ALB/CPM - MEANS TEST BILLING PROFILE (CON'T);10-DEC-91
+1 ;;2.0;INTEGRATED BILLING;**15,153,176,183,651,656,678,747**;21-MAR-94;Build 2
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified
+3 ;
+4 NEW IBLEG,IBCHK
+5 ;***
+6 ;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
+7 ; Begin compilation. Start with billing clocks.
+8 SET Y=-(IBEDT+.1)
SET X=0
FOR
if -Y<IBBDT
QUIT
SET Y=$ORDER(^IBE(351,"AIVDT",IBDFN,Y))
if 'Y
QUIT
FOR
SET X=$ORDER(^IBE(351,"AIVDT",IBDFN,Y,X))
if 'X
QUIT
if $PIECE($GET(^IBE(351,X,0)),U,4)'=3
SET ^TMP($JOB,"IBOMTP",-Y,"C")=""
+9 ;
+10 ; Get O/P visits from file #399.
+11 SET X1=IBBDT
SET X2=-1
DO C^%DTC
SET Y=X
+12 FOR
SET Y=$ORDER(^DGCR(399,"AOPV",IBDFN,Y))
if 'Y!(Y>IBEDT)
QUIT
Begin DoDot:1
+13 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399,"AOPV",IBDFN,Y,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+14 IF $DATA(^DGCR(399,+IBDA,0))
IF '$PIECE($GET(^("S")),U,16)
IF $PIECE($GET(^DGCR(399.3,+$PIECE(^(0),U,7),0)),U)["MEANS"
SET ^TMP($JOB,"IBOMTP",Y,"M"_IBDA)=""
End DoDot:2
End DoDot:1
+15 ;
+16 ;IB*2.0*678 - add seconds to IBEDT (IBEDTP1) and use that for the End Date range
+17 SET IBEDTP1=IBEDT+.999999
+18 ; Get the rest of the charges from file #350.
+19 SET Y=""
FOR
SET Y=$ORDER(^IB("AFDT",IBDFN,Y))
if 'Y
QUIT
IF -Y'>IBEDTP1
SET Y1=0
FOR
SET Y1=$ORDER(^IB("AFDT",IBDFN,Y,Y1))
if 'Y1
QUIT
Begin DoDot:1
+20 SET (IBDA,IBCHK)=0
FOR
SET IBDA=$ORDER(^IB("AF",Y1,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+21 if '$DATA(^IB(IBDA,0))
QUIT
+22 SET IBX=^IB(IBDA,0)
+23 if $PIECE(IBX,U,8)["ADMISSION"
QUIT
+24 IF $PIECE(IBX,U,15)<IBBDT!($PIECE(IBX,U,14)>IBEDTP1)
QUIT
+25 NEW Y,Y1
+26 ; Action type. We don't include LTC actions to the report
+27 ; Exclude LTC action type
IF $PIECE(IBX,U,3)
IF $$ACTNM^IBOUTL(+$PIECE(IBX,U,3))["LTC "
QUIT
+28 SET ^TMP($JOB,"IBOMTP",+$PIECE(IBX,U,14),"I"_IBDA)=""
SET IBCHK=1
End DoDot:2
+29 ;If an entry already found its not a pharmacy RX
if IBCHK
QUIT
+30 SET IBX=$GET(^IB(Y1,0))
+31 SET IBATYP=$PIECE(IBX,U,3)
SET IBBLG=$$GET1^DIQ(350.1,IBATYP_",",.11,"I")
+32 ;Is this an RX copay
IF IBBLG=5
Begin DoDot:2
+33 ;Check to ensure the visit is in the correct search range
IF $PIECE(IBX,U,15)<IBBDT!($PIECE(IBX,U,14)>IBEDTP1)
QUIT
+34 ;Store in reporting array.
SET ^TMP($JOB,"IBOMTP",+$PIECE(IBX,U,14),"I"_Y1)=""
End DoDot:2
End DoDot:1
+35 ;
+36 ; Print report.
+37 ; Legend not required
SET IBLEG=0
+38 DO NOW^%DTC
SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+39 SET IBLINE=""
SET $PIECE(IBLINE,"-",IOM+1)=""
SET (IBPAG,IBCHGT,IBQUIT)=0
+40 SET IBPT=$$PT^IBEFUNC(IBDFN)
+41 ; IB*2.0*747
SET IBH="Means Test Billing Profile for "_$PIECE(IBPT,U)
DO HDR
+42 IF '$DATA(^TMP($JOB,"IBOMTP"))
WRITE !,"This patient has no Means Test bills."
DO PAUSE^IBOUTL
GOTO END
+43 ; - first, print detail lines
+44 SET IBD=""
FOR
SET IBD=$ORDER(^TMP($JOB,"IBOMTP",IBD))
if 'IBD
QUIT
Begin DoDot:1
+45 SET IBTY=""
FOR
SET IBTY=$ORDER(^TMP($JOB,"IBOMTP",IBD,IBTY))
if IBTY=""
QUIT
Begin DoDot:2
+46 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR
+47 WRITE !,$$DAT1^IBOUTL(IBD)
+48 IF IBTY="C"
WRITE ?12,"Begin Means Test Billing Clock"
QUIT
+49 SET IBDA=+$EXTRACT(IBTY,2,99)
SET IBD0=$SELECT($EXTRACT(IBTY)="M":$GET(^DGCR(399,IBDA,0)),1:$GET(^IB(IBDA,0)))
SET IBSEQ=0
+50 IF $EXTRACT(IBTY)="I"
SET IBSEQ=$PIECE($GET(^IBE(350.1,+$PIECE(IBD0,U,3),0)),U,5)
+51 WRITE ?14,$SELECT($EXTRACT(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$PIECE(IBD0,U,3)))
+52 WRITE ?44,$SELECT($EXTRACT(IBTY)="M":$PIECE(IBD0,U),1:$$STAT())
+53 IF $EXTRACT(IBTY)="I"
IF $PIECE(IBD0,U,14)'=$PIECE(IBD0,U,15)
WRITE ?54,$$DAT1^IBOUTL($PIECE(IBD0,U,15))
+54 IF $EXTRACT(IBTY)="M"
SET X=+$ORDER(^DGCR(399,IBDA,"RC","B",500,0))
SET IBCHG=+$PIECE($GET(^DGCR(399,IBDA,"RC",X,0)),U,2)
+55 IF '$TEST
SET IBCHG=+$PIECE(IBD0,U,7)
+56 IF IBSEQ=2
SET IBCHG=-IBCHG
+57 IF $EXTRACT(IBTY)="I"
IF $PIECE(IBD0,U,11)=""
IF $PIECE($GET(^IBE(350.21,+$PIECE(IBD0,U,5),0)),U,5)
SET IBCHG=0
+58 SET X=IBCHG
SET X2="2$"
SET X3=10
DO COMMA^%DTC
WRITE ?65,X
+59 ;Print legend at the bottom
IF $PIECE(IBD0,U,21)
WRITE " *"
SET IBLEG=1
+60 SET IBCHGT=IBCHGT+IBCHG
+61 IF IBSEQ=2!($PIECE(IBD0,U,11)=""&($PIECE($GET(^IBE(350.21,+$PIECE(IBD0,U,5),0)),U,5)))
WRITE !?5,"Charge Removal Reason: ",$SELECT($DATA(^IBE(350.3,+$PIECE(IBD0,U,10),0)):$PIECE(^(0),U),1:"UNKNOWN")
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
GOTO END
+62 ; - print totals line
+63 IF ($Y-IBLEG)>(IOSL-5)
DO LEGEND
DO PAUSE^IBOUTL
if IBQUIT
GOTO END
DO HDR
+64 WRITE !?63,"-----------"
SET X=IBCHGT
SET X2="2$"
SET X3=12
DO COMMA^%DTC
WRITE !?63,X
+65 DO LEGEND
DO PAUSE^IBOUTL
+66 ; - close device and quit
END KILL ^TMP($JOB)
+1 ;***
+2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+4 KILL IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
+5 DO ^%ZISC
QUIT
+6 ;
+7 ;
HDR ; Print header.
+1 SET IBLEG=0
+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 ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
+5 WRITE ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
+6 WRITE !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
+7 WRITE !,IBLINE,!
QUIT
+8 ;
STAT() ; Display bill number or status
+1 NEW IBSTAT
SET IBSTAT=$GET(^IBE(350.21,+$PIECE(IBD0,U,5),0))
+2 QUIT $SELECT($PIECE(IBSTAT,U,6):$$HLD(+$PIECE(IBD0,U,5)),$PIECE(IBD0,U,5)=99:"Converted",$PIECE(IBD0,U,11)]"":$PIECE($PIECE(IBD0,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 ;
LEGEND IF $GET(IBLEG)
WRITE !," '*' - Geographic Means Test rates"
+1 QUIT
