source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBOMTP1.m@ 1397

IBOMTP1 ;ALB/CPM-MEANS TEST BILLING PROFILE (CON'T);10-DEC-91
 ;;2.0;INTEGRATED BILLING;**15,153,176,183**;21-MAR-94
 ;; Per VHA Directive 10-93-142, this routine should not be modified
 ;
 N IBLEG
 ;***
 ;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)=""
 ;
 ; Get the rest of the charges from file #350.
 S Y="" F  S Y=$O(^IB("AFDT",IBDFN,Y)) Q:'Y  I -Y'>IBEDT S Y1=0 F  S Y1=$O(^IB("AFDT",IBDFN,Y,Y1)) Q:'Y1  D
 . S IBDA=0 F  S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA  D
 ..  Q:'$D(^IB(IBDA,0))  S IBX=^(0)
 ..  Q:$P(IBX,U,8)["ADMISSION"
 ..  I $P(IBX,U,15)<IBBDT!($P(IBX,U,14)>IBEDT) 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)=""
 ;
 ; 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)_"  "_$P(IBPT,U,2) D HDR
 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