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

Last change on this file since 846 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1IBOMTP1 ;ALB/CPM-MEANS TEST BILLING PROFILE (CON'T);10-DEC-91
2 ;;2.0;INTEGRATED BILLING;**15,153,176,183**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified
4 ;
5 N IBLEG
6 ;***
7 ;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
8 ; Begin compilation. Start with billing clocks.
9 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")=""
10 ;
11 ; Get O/P visits from file #399.
12 S X1=IBBDT,X2=-1 D C^%DTC S Y=X
13 F S Y=$O(^DGCR(399,"AOPV",IBDFN,Y)) Q:'Y!(Y>IBEDT) D
14 . S IBDA=0 F S IBDA=$O(^DGCR(399,"AOPV",IBDFN,Y,IBDA)) Q:'IBDA D
15 .. 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)=""
16 ;
17 ; Get the rest of the charges from file #350.
18 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
19 . S IBDA=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D
20 .. Q:'$D(^IB(IBDA,0)) S IBX=^(0)
21 .. Q:$P(IBX,U,8)["ADMISSION"
22 .. I $P(IBX,U,15)<IBBDT!($P(IBX,U,14)>IBEDT) Q
23 .. N Y,Y1
24 .. ; Action type. We don't include LTC actions to the report
25 .. I $P(IBX,U,3) I $$ACTNM^IBOUTL(+$P(IBX,U,3))["LTC " Q ; Exclude LTC action type
26 .. S ^TMP($J,"IBOMTP",+$P(IBX,U,14),"I"_IBDA)=""
27 ;
28 ; Print report.
29 S IBLEG=0 ; Legend not required
30 D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
31 S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBCHGT,IBQUIT)=0
32 S IBPT=$$PT^IBEFUNC(IBDFN)
33 S IBH="Means Test Billing Profile for "_$P(IBPT,U)_" "_$P(IBPT,U,2) D HDR
34 I '$D(^TMP($J,"IBOMTP")) W !,"This patient has no Means Test bills." D PAUSE^IBOUTL G END
35 ; - first, print detail lines
36 S IBD="" F S IBD=$O(^TMP($J,"IBOMTP",IBD)) Q:'IBD D G:IBQUIT END
37 . S IBTY="" F S IBTY=$O(^TMP($J,"IBOMTP",IBD,IBTY)) Q:IBTY="" D Q:IBQUIT
38 .. I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
39 .. W !,$$DAT1^IBOUTL(IBD)
40 .. I IBTY="C" W ?12,"Begin Means Test Billing Clock" Q
41 .. S IBDA=+$E(IBTY,2,99),IBD0=$S($E(IBTY)="M":$G(^DGCR(399,IBDA,0)),1:$G(^IB(IBDA,0))),IBSEQ=0
42 .. I $E(IBTY)="I" S IBSEQ=$P($G(^IBE(350.1,+$P(IBD0,U,3),0)),U,5)
43 .. W ?14,$S($E(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$P(IBD0,U,3)))
44 .. W ?44,$S($E(IBTY)="M":$P(IBD0,U),1:$$STAT())
45 .. I $E(IBTY)="I",$P(IBD0,U,14)'=$P(IBD0,U,15) W ?54,$$DAT1^IBOUTL($P(IBD0,U,15))
46 .. 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)
47 .. E S IBCHG=+$P(IBD0,U,7)
48 .. I IBSEQ=2 S IBCHG=-IBCHG
49 .. I $E(IBTY)="I",$P(IBD0,U,11)="",$P($G(^IBE(350.21,+$P(IBD0,U,5),0)),U,5) S IBCHG=0
50 .. S X=IBCHG,X2="2$",X3=10 D COMMA^%DTC W ?65,X
51 .. I $P(IBD0,U,21) W " *" S IBLEG=1 ;Print legend at the bottom
52 .. S IBCHGT=IBCHGT+IBCHG
53 .. 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")
54 ; - print totals line
55 I ($Y-IBLEG)>(IOSL-5) D LEGEND,PAUSE^IBOUTL G:IBQUIT END D HDR
56 W !?63,"-----------" S X=IBCHGT,X2="2$",X3=12 D COMMA^%DTC W !?63,X
57 D LEGEND,PAUSE^IBOUTL
58 ; - close device and quit
59END K ^TMP($J)
60 ;***
61 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
62 I $D(ZTQUEUED) S ZTREQ="@" Q
63 K IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
64 D ^%ZISC Q
65 ;
66 ;
67HDR ; Print header.
68 S IBLEG=0
69 I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
70 S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
71 W !,"From ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
72 W ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
73 W !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
74 W !,IBLINE,! Q
75 ;
76STAT() ; Display bill number or status
77 N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBD0,U,5),0))
78 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")
79 ;
80HLD(STAT) ; Return an 'on hold' status string
81 Q "Hold "_$S(STAT=20:"Rate",STAT=21:"Rev",1:"Ins")
82 ;
83LEGEND I $G(IBLEG) W !," '*' - Geographic Means Test rates"
84 Q
Note: See TracBrowser for help on using the repository browser.