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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1IBOTR3 ;ALB/CPM - INSURANCE PAYMENT TREND REPORT - OUTPUT ; 5-JUN-91
2 ;;2.0;INTEGRATED BILLING;**42,80,100,118,128,133**;21-MAR-94
3 ;
4 ;MAP TO DGCROTR3
5 ;
6EN(IBDIV) ; - Entry point from IBOTR2.
7 ;
8 ; - Extract zero totals if no data available.
9 I $G(IBXTRACT),'$D(^TMP($J,"IBOTR",IBDIV)) D G END
10 .S IBUNPD=0 F X=1:1:8 S IBTT(X)=0
11 .D E^IBJDE(8,0)
12 ;
13 I $G(IBXTRACT) G IBX ; Calculate grand totals for extract.
14 ;
15 S IBPAG=0,IBLINE="",$P(IBLINE,"-",IOM)="-",Y=DT D D^DIQ S IBTDT=Y
16 I $D(IBAF) D ADDFLD^IBOTR4
17 I '$D(^TMP($J,"IBOTR",IBDIV)) D S IBCALC=3 D PAUSE G END
18 .S IBX=$S("Bb"'[IBBRT:IBBRT,IBBRN="C":"A",1:"I")
19 .D HDR W !!," NO INFORMATION MATCHES SELECTION CRITERIA."
20 ;
21IBX S IBX="" F S IBX=$O(^TMP($J,"IBOTR",IBDIV,IBX)) Q:IBX="" D Q:IBQUIT
22 .I IBPRNT'="G"!('$G(IBG)) S IBTT="0^0^0^0^0^0^0^0^0^0"
23 .D:'$G(IBXTRACT) HDR Q:IBQUIT D INS
24 ;
25END K IBINS,IBPAG,IBLINE,IBTDT,IBX,IBTT,IBTI,IBCALC,IBBN,IBD,IBDS,IBAFT
26 K IBAMT,IBG,IBI,IBPERC,IBUNPD,X,X1,X2
27 Q
28 ;
29INS ; - Loop through each insurance company or amount.
30 I IBSORT="I" D
31 .S IBINS="" F S IBINS=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS)) Q:IBINS="" D BILLNO Q:IBQUIT
32 E D
33 .S IBAMT="" F S IBAMT=$O(^TMP($J,"IBOTRS",IBDIV,IBX,IBAMT)) Q:IBAMT="" S IBINS="" F S IBINS=$O(^TMP($J,"IBOTRS",IBDIV,IBX,IBAMT,IBINS)) Q:IBINS="" D BILLNO Q:IBQUIT
34 ;
35 ; - Extract grand totals data.
36 I $G(IBXTRACT),'IBQUIT D Q
37 .S IBUNPD=$J($P(IBTT,U,2)-$P(IBTT,U,5),0,2)
38 .F X=1:1:8 S IBTT(X)=$S(19'[X:$J($P(IBTT,U,X),0,2),1:$P(IBTT,U,X))
39 .D E^IBJDE(8,0)
40 ;
41 I 'IBQUIT,'$G(IBG) D GTOT^IBOTR4 ; Write grand totals for report.
42 Q
43 ;
44BILLNO ; - Loop through all bills for an insurance company.
45 I $G(IBXTRACT) G LOOP
46 I $Y>(IOSL-15) S IBCALC=15 D PAUSE Q:IBQUIT D HDR Q:IBQUIT
47 I IBPRNT'="G" S IBDS=0,IBTI="0^0^0^0" D INSADD
48 E I $G(IBG) S IBTT="0^0^0^0^0^0^0^0^0^0" D INSADD
49LOOP S IBBN="" F S IBBN=$O(^TMP($J,"IBOTR",IBDIV,IBX,IBINS,IBBN)) Q:IBBN="" S IBD=^(IBBN) D DETAIL Q:IBQUIT
50 I 'IBQUIT D
51 .I IBPRNT'="G" D SUBTOT^IBOTR4 ; Write insurance co. sub-totals.
52 .E D:$G(IBG) GTOT^IBOTR4 ; Write insurance co. grand totals.
53 Q
54 ;
55DETAIL ; - Write out detail lines.
56 N IBPEN S IBPEN=$S($P(IBBN,"@@",2)["*":0,1:$P(IBD,U,6)-$P(IBD,U,7))
57 G:IBPRNT="S" SUBTOT G:IBPRNT="G" GNDTOT
58 I $Y>(IOSL-7) S IBCALC=7 D PAUSE Q:IBQUIT D HDR Q:IBQUIT D INSADD
59 W !,$P(IBBN,"@@",2),?10,$P(IBBN,"@@"),?34,$$DATE($P(IBD,U,2))
60 W ?44,$$DATE($P(IBD,U,3)),?54,$$DATE($P(IBD,U,4))
61 W ?64,$S($P(IBD,U,5):$$DATE($P(IBD,U,5)),1:$P(IBD,U,5))
62 S X1=$S($P(IBD,U,5):$P(IBD,U,5),1:DT),X2=$P(IBD,U,4) D ^%DTC S IBDS=IBDS+X
63 W ?74,$J(X,4),?79,$J($P(IBD,U,6),11,2),?91,$J($P(IBD,U,7),10,2)
64 W ?102,$J($P(IBD,U,6)-$P(IBD,U,7),11,2),?114,$J(IBPEN,11,2)
65 W ?126,$J($S(+$P(IBD,U,6)=0:0,1:$P(IBD,U,7)/$P(IBD,U,6)*100),6,2)
66 ;
67SUBTOT ; - Update sub-totals.
68 S $P(IBTI,U)=$P(IBTI,U)+1,$P(IBTI,U,2)=$P(IBTI,U,2)+$P(IBD,U,6)
69 S $P(IBTI,U,3)=$P(IBTI,U,3)+$P(IBD,U,7),$P(IBTI,U,4)=$P(IBTI,U,4)+IBPEN
70 ;
71GNDTOT ; - Update grand totals.
72 S $P(IBTT,U)=$P(IBTT,U)+1,$P(IBTT,U,2)=$P(IBTT,U,2)+$P(IBD,U,6)
73 I +$P($P(IBBN,"@@"),"(",2)<65 S $P(IBTT,U,3)=$P(IBTT,U,3)+$P(IBD,U,6),$P(IBTT,U,6)=$P(IBTT,U,6)+$P(IBD,U,7)
74 E S $P(IBTT,U,4)=$P(IBTT,U,4)+$P(IBD,U,6),$P(IBTT,U,7)=$P(IBTT,U,7)+$P(IBD,U,7)
75 S $P(IBTT,U,5)=$P(IBTT,U,5)+$P(IBD,U,7),$P(IBTT,U,8)=$P(IBTT,U,8)+IBPEN
76 I $G(IBCANC),$P(IBD,U,8) S $P(IBTT,U,9)=$P(IBTT,U,9)+1,$P(IBTT,U,10)=$P(IBTT,U,10)+$P(IBD,U,6)
77 Q
78 ;
79HDR ; - Print the report header.
80 S IBPAG=IBPAG+1 W @IOF,IBRTN," PAYMENT TREND REPORT - "
81 W $S(IBX="I":"INPATIENT",IBX="O":"OUTPATIENT",1:"COMBINED INPATIENT AND OUTPATIENT")," BILLING"
82 W ?109,IBTDT," PAGE ",$J(IBPAG,3),!
83 I IBDIV W "For: ",$P($G(^DG(40.8,IBDIV,0)),U)," - "
84 W IBDFN,": ",$$DATE(IBBDT)," - ",$$DATE(IBEDT)
85 I IBPRNT="M" W ?82,"Note: '*' after the Bill No. denotes a CLOSED bill"
86 W:$D(IBAF) !,IBAFT G:IBPRNT="G" HDL
87 W !!,"BILL",?10,"PATIENT",?55,"DATE",?64,"DATE BILL",?75,"#"
88 W ?83,"AMOUNT",?93,"AMOUNT",?106,"AMOUNT",?117,"AMOUNT",?127,"PERC"
89 W !,"NUMBER",?10,"NAME (AGE)",?34,"BILL FROM - TO",?54,"PRINTED"
90 W ?65,"CLOSED",?74,"DAYS",?83,"BILLED",?92,"COLLECTED",?106,"UNPAID"
91 W ?117,"PENDING",?127,"COLL"
92HDL W !,IBLINE
93 I IBPRNT="M" W !?56,"M A I N R E P O R T"
94 I IBPRNT="G" W !?55,"G R A N D T O T A L S",!
95 I IBPRNT="S" W !?49,"S U M M A R Y S T A T I S T I C S"
96 I "OP"[IBSORT W !?30,"S O R T E D B Y A M O U N T ",$S(IBSORT="O":"O W E",1:"P A I")," D - H I G H E S T T O L O W E S T"
97 S IBQUIT=$$STOP^IBOUTL("Trend Report")
98 Q
99 ;
100DATE(IBX) S:IBX]"" IBX=$E(IBX,4,5)_"/"_$E(IBX,6,7)_"/"_$E(IBX,2,3) Q IBX
101 ;
102PAUSE I $E(IOST,1,2)'="C-" Q
103 I IOSL<60 F IBI=$Y:1:(IOSL-IBCALC) W !
104 S DIR(0)="E" D ^DIR K DIR
105 I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
106 Q
107 ;
108INSADD ; - Display Insurance Company name and address.
109 ; Input: IBINS
110 N D,PH,IEN
111 W !!?16,"INSURANCE CARRIER: ",$P(IBINS,"@@")
112 S IEN=$P(IBINS,"@@",2) G:'IEN INSADQ
113 S D=$G(^DIC(36,IEN,.11)),PH=$P($G(^(.13)),U) G:D="" INSADQ
114 W:$P(D,U)]"" !?35,$P(D,U)
115 W:$P(D,U,2)]"" !?35,$P(D,U,2)
116 W:$P(D,U,3)]"" !?35,$P(D,U,3)
117 W:$P(D,U)]""!($P(D,U,2)]"")!($P(D,U,3)]"") !?35
118 W $P(D,U,4) W:$P(D,U,4)]""&($P(D,U,5)]"") ", "
119 W $P($G(^DIC(5,+$P(D,U,5),0)),U)
120 W:$P(D,U,6)]""&($P(D,U,4)]""!($P(D,U,5)]"")) " "
121 W $P(D,U,6) W:PH]"" $J("",8),"Phone: ",PH
122INSADQ W ! Q
Note: See TracBrowser for help on using the repository browser.