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

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1IBATO ;LL/ELZ - TRANSFER PRICING REPORTS ; 18-DEC-98
2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ENW ; produces a workload report
6 N IBHEAD,IBMARG,IBFIELD,IBMUL
7 S IBHEAD="Transfer Pricing Workload Report "
8 D DISP^IBATO1
9 S IBMARG=$$SEL^IBATO1("70,60,61,50,51,53,52") Q:'IBMARG
10 D START
11 Q
12ENP ; produces a patient detail report
13 N IBHEAD,IBMARG,IBFIELD,IBMUL
14 S IBHEAD="Transfer Pricing Patient Report "
15 D DISP^IBATO1
16 S IBMARG=$$SEL^IBATO1("1,2,40,41,60,50,52,53") Q:'IBMARG
17 D START
18 Q
19ENEX ; excel formatted report
20 N IBHEAD,IBMARG,IBFIELD,IBMUL,IBEX,IBQUIT
21 S IBEX=1,IBQUIT=0
22 W !!,"This will produce a report that can be exported into an excel spread sheet."
23 W !,"If you select any fields with an asterisk (*) then the report will contain"
24 W !,"fields which are multiples. Multiple fields will cause dollar amounts to"
25 W !,"repeat for each multiple line!",! Q:$$PAGE
26 D DISP^IBATO1
27 S IBMARG=$$SEL^IBATO1() Q:'IBMARG
28 D START
29 Q
30ENS ; produces a summary report
31 N IBHEAD
32 S IBHEAD="Transfer Pricing Summary Report "
33START ;
34 N IBBDT,IBEDT,IBFAC,IBXREF,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
35 ;
36 ; status for sorting
37 W !,"Select how you want this report to sort by for a date range."
38 S DIR(0)="S^E:EVENT DATE;P:PRICED DATE"
39 S DIR("A")="Select Sort"
40 D ^DIR Q:$D(DIRUT) S IBXREF=$S(Y="E":"AG",1:"AE")
41 S IBHEAD=$S(Y="E":"Event ",1:"Priced ")_$G(IBHEAD)
42 ;
43 Q:$$FAC^IBATUTL Q:$$SLDR^IBATUTL
44 Q:$$DEV("Transfer Pricing Report","DQ")
45 ;
46DQ ; queued entry point
47 N IBPAGE,IBDT,IBVISN,IBIEN,IBLOC,IBTYPE,IBTMP,IBCOPAY,IBCOUNT,IBQUIT
48 N IBSAVE,IBX,IBLINE,IBLAST
49 U IO K ^TMP("IBATO",$J)
50 S (IBQUIT,IBPAGE,IBSAVE,IBLAST)=0,IBDT=$$FMADD^XLFDT(IBBDT,-1)_.99999
51 S IBLINE="" F IBX=1:1:80 S IBLINE=IBLINE_"-"
52 F S IBDT=$O(^IBAT(351.61,IBXREF,IBDT)) Q:IBDT<1!(IBDT>IBEDT) S IBIEN=0 F S IBIEN=$O(^IBAT(351.61,IBXREF,IBDT,IBIEN)) Q:IBIEN<1 D
53 . S IBIEN(0)=$G(^IBAT(351.61,IBIEN,0))
54 . Q:$P(IBIEN(0),"^",5)="X"!('$P(IBIEN(0),"^",11))
55 . S IBVISN=+$$VISN^IBATUTL($P(IBIEN(0),"^",11))
56 . S IBLOC=$P(IBIEN(0),"^",11)
57 . S IBTYPE=$P($P(IBIEN(0),"^",12),";",2)
58 . I $D(IBFAC)'=0,$D(IBFAC(IBVISN,"C",$P(IBIEN(0),"^",11)))=0 Q
59 . S ^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE,IBIEN)=IBIEN(0)
60 ;
61 ;use excel format for printing
62 I $G(IBEX) D K ^TMP("IBATO",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
63 . N A,B,C,D
64 . ;
65 . ;first print header
66 . S A=0 F S A=$O(IBFIELD(A)) Q:A<1 S B=0 F S B=$O(IBFIELD(A,B)) Q:B<1 W $P(IBFIELD(A,B),"^"),"|"
67 . S A=0 F S A=$O(IBMUL(A)) Q:A<1 S B=0 F S B=$O(IBMUL(A,B)) Q:B<1 W $P(IBMUL(A,B),"^"),"|"
68 . W !
69 . ;
70 . ;now onto printing excel
71 . S A=0 F S A=$O(^TMP("IBATO",$J,A)) Q:A<1 S B=0 F S B=$O(^TMP("IBATO",$J,A,B)) Q:B<1 S C=0 F S C=$O(^TMP("IBATO",$J,A,B,C)) Q:C="" S D=0 F S D=$O(^TMP("IBATO",$J,A,B,C,D)) Q:D<1 D EXPRT^IBATO1(D)
72 ;
73 ; start all other printing
74 S IBVISN=0
75 F S IBVISN=$O(^TMP("IBATO",$J,IBVISN)) Q:IBVISN<1!IBQUIT D
76 . D ZERO(.IBVISN)
77 . S IBLOC=0
78 . F S IBLOC=$O(^TMP("IBATO",$J,IBVISN,IBLOC)) Q:IBLOC<1!IBQUIT D
79 .. D ZERO(.IBLOC)
80 .. S IBTYPE=""
81 .. F S IBTYPE=$O(^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE)) Q:IBTYPE=""!IBQUIT D
82 ... S IBIEN=0
83 ... F S IBIEN=$O(^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE,IBIEN)) Q:IBIEN<1!IBQUIT D
84 .... S IBIEN(0)=^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE,IBIEN)
85 .... S IBIEN(6)=$G(^IBAT(351.61,IBIEN,6))
86 .... S IBCOPAY=$$COPAY^IBATUTL($P(IBIEN(0),"^",2),$P(IBIEN(0),"^",12),$P($P(IBIEN(0),"^",9),"."),$P($P(IBIEN(0),"^",10),"."))
87 .... I IBCOPAY,IBTYPE="SCE(" S (IBCOUNT,IBTMP)=0 F S IBTMP=$O(^IBAT(351.61,"AH",$P(IBIEN(0),"^",2),$P(IBIEN(0),"^",4),IBTMP)) Q:IBTMP<1 I $P(^IBAT(351.61,IBTMP,0),"^",12)["SCE(" S IBCOUNT=IBCOUNT+1
88 .... I S IBCOPAY=IBCOPAY/IBCOUNT
89 .... S IBIEN(6)="1^"_$P(IBIEN(6),"^",1,2)_"^"_IBCOPAY_"^"_($P(IBIEN(6),"^",2)-IBCOPAY)
90 .... D:$D(IBMARG) PRT^IBATO1(IBIEN)
91 .... D SUM(.IBLOC,.IBTYPE,IBIEN(6)),SUM(.IBVISN,.IBTYPE,IBIEN(6))
92 .. D:'IBQUIT TOTAL(.IBLOC)
93 .. D:'IBQUIT PRINT(.IBLOC)
94 . D:'IBQUIT TOTAL(.IBVISN)
95 . D:'IBQUIT PRINT(.IBVISN):$D(IBFAC)=0!($D(IBFAC(IBVISN))=11)
96 I $E(IOST,1,2)="C-" I $$PAGE
97 K ^TMP("IBATO",$J)
98 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
99 Q
100TOTAL(X) ; totals up types in subscripted X
101 N IBP,IBX
102 F IBX="DGPM(","SCE(","PSRX(","RMPR(660," F IBP=1:1:5 S $P(X("TOTAL"),"^",IBP)=$P(X("TOTAL"),"^",IBP)+$P(X(IBX),"^",IBP)
103 Q
104SUM(X,Z,Y) ; adds up amounts for type in X
105 N IBP
106 F IBP=1:1:5 S $P(X(Z),"^",IBP)=$P(X(Z),"^",IBP)+$P(Y,"^",IBP)
107 Q
108ZERO(X) ; zeros out variables
109 N IBP
110 F IBP="DGPM(","PSRX(","SCE(","RMPR(660,","TOTAL" S X(IBP)=0
111 Q
112PRINT(IBPRT) ; prints out report sum from what is passed
113 N IBP
114 D HEAD(IBPRT)
115 F IBP="DGPM(","SCE(","PSRX(","RMPR(660,","TOTAL" Q:IBQUIT D
116 . W !!,$S(IBP="DGPM(":"INPATIENT",IBP="SCE(":"OUTPATIENT",IBP="PSRX(":"PHARMACY",IBP="RMPR(660,":"PROSTHETICS",1:"TOTAL")
117 . W ":",?27,"COUNT: ",$$NUM($P(IBPRT(IBP),"^"),0)
118 . W:IBP="DGPM(" !,?20,"OUTLIER DAYS: ",$$NUM($P(IBPRT(IBP),"^",2),0)
119 . W !,?20,"TOTAL AMOUNT: ",$$NUM($P(IBPRT(IBP),"^",3))
120 Q
121DEV(ZTDESC,ZTRTN) ; device handler for reports
122 ; needs task description and entry point returns 1 if queued or pop
123 N %ZIS,ZTSAVE,POP,ZTSK
124 I $D(IBMARG) W !,?5,"*** Requires a margin of at least ",IBMARG," ***"
125 S %ZIS="MQ" D ^%ZIS Q:POP 1
126 I $D(IO("Q")) D Q 1
127 . S ZTRTN=ZTRTN_"^IBATO",ZTSAVE("IB*")=""
128 . D ^%ZTLOAD,HOME^%ZIS K IO("Q") W !,"Task# ",ZTSK
129 Q 0
130HEAD(X) ;
131 N Z
132 I IBPAGE,$E(IOST,1,2)="C-" I $$PAGE S IBQUIT=1 Q
133 S IBPAGE=IBPAGE+1
134 W @IOF,!,IBHEAD,$$FMTE^XLFDT(IBBDT,"5D")," to ",$$FMTE^XLFDT(IBEDT,"5D"),?IOM-10,"Page: ",IBPAGE
135 W ! F Z=1:1:IOM W "-"
136 W !,"LOCATION: "_$P($$INST^IBATUTL(X),"^")
137 Q
138PAGE() ; performs page reads and returns 1 if quitting is needed
139 Q:IBQUIT 1
140 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
141 S DIR(0)="E" D ^DIR
142 Q $D(DIRUT)
143NUM(X,X2,X3) ; calls to format numbers
144 D COMMA^%DTC
145 Q X
Note: See TracBrowser for help on using the repository browser.