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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
2 ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5PAGE() ; performs page reads and returns 1 if quiting is needed
6 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
7 S DIR(0)="E" D ^DIR
8 Q $D(DIRUT)
9NUM(X,X2,X3) ; calls to format numbers
10 D COMMA^%DTC
11 Q $E(X,1,$L(X)-1)
12UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA
13 N IBX,IBB S IBB="UNIT"
14 I $P(IBA(0),"^",12)["DGPM" D Q
15 . S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1))
16 I $P(IBA(0),"^",12)["PSRX(" D Q
17 . S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12))
18 I $P(IBA(0),"^",12)["RMPR" D Q
19 . S IBD(1,IBO,IBB)="PROSTHETIC"
20 S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
21 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
22 . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U)
23 Q
24TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA
25 N IBB,IBC,IBD
26 S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0)
27 S IBB=$P(IBA(0),"^",12)
28 I IBB["DGPM(" S IBO="INPATIENT" Q
29 I IBB["PSRX(" S IBO="PHARMACY" Q
30 I IBB["RMPR(660," S IBO="PROSTHETICS" Q
31 D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC")
32 D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD")
33 S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10))
34 Q
35DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA
36 N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION"
37 I $P(IBA(0),"^",12)["DGPM" D Q
38 . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18)
39 I $P(IBA(0),"^",12)["PSRX(" D Q
40 . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
41 I $P(IBA(0),"^",12)["RMPR(660," D Q
42 . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)
43 S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
44 S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
45 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
46 . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18)
47 Q
48PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA
49 N IBX,IBB S IBB="UNIT PRICE"
50 I $P(IBA(0),"^",12)["DGPM" D Q
51 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9)
52 I $P(IBA(0),"^",12)["PSRX(" D Q
53 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10)
54 I $P(IBA(0),"^",12)["RMPR(660," D Q
55 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10)
56 S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
57 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
58 . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9)
59 Q
60QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA
61 N IBX,IBB S IBB="QTY"
62 I $P(IBA(0),"^",12)["DGPM" D Q
63 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3)
64 I $P(IBA(0),"^",12)["PSRX(" D Q
65 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3)
66 I $P(IBA(0),"^",12)["RMPR(660," D Q
67 . S IBD(1,IBO,IBB)=$$NUM(1,0,3)
68 S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
69 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
70 . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3)
71 Q
72COPAY(IBA) ; compute copay for iba and return
73 N IBC,IBT,IBCOPAY
74 S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),"."))
75 I IBCOPAY,$P(IBA(0),"^",12)["SCE(" S (IBC,IBT)=0 F S IBT=$O(^IBAT(351.61,"AH",$P(IBA(0),"^",2),$P(IBA(0),"^",4),IBT)) Q:IBT<1 I $P(^IBAT(351.61,IBT,0),"^",12)["SCE(" S IBC=IBC+1
76 I S IBCOPAY=IBCOPAY/IBC
77 Q $$NUM(IBCOPAY,2,7)
78 ;
79VAR(IBA) ; set up required variables
80 N IBX
81 F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX))
82 Q
83PRT(IBIEN) ; main entry for report printing
84 ;
85 N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM
86 ;
87 D VAR(.IBIEN)
88 S DFN=$P(IBIEN(0),"^",2)
89 I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT
90 W ! S IBC=0
91 ;
92 ; print single valued data first
93 S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D
94 . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
95 . X ^IBAT(351.62,IBF1,1)
96 . W IBXDATA,?IBC
97 ;
98 ; compute multiple valued data
99 S IBM=IBC
100 S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D
101 . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
102 . X ^IBAT(351.62,IBF1,1)
103 ;
104 ; print multiple valued data
105 S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" W:IBC'=IBM ! W ?IBM S IBC=IBM D
106 . S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D
107 .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
108 .. S IBF2=^IBAT(351.62,IBF2,0)
109 .. S IBC=IBC+$P(IBF2,"^",2)+1
110 .. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6
111 .. W IBXDATA(IBF,IBO,IBF1),?IBC
112 ;
113 ; clean up
114 X ^IBAT(351.62,999,1)
115 ;
116 Q
117EXPRT(IBIEN) ; main entry for excel printing
118 ;
119 N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR
120 ;
121 D VAR(.IBIEN)
122 S DFN=$P(IBIEN(0),"^",2)
123 ;
124 ; do single if no multiple
125 I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q
126 ;
127 ; compute multiple valued data
128 S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D
129 . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
130 . X ^IBAT(351.62,IBF1,1)
131 ;
132 ; print multiple valued data
133 S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" D EXSING(IBF) D
134 . S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D
135 .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
136 .. S IBF2=^IBAT(351.62,IBF2,0)
137 .. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|"
138 . W !
139 ;
140 ; clean up
141 X ^IBAT(351.62,999,1)
142 ;
143 Q
144STRIP(A,B) ; strips off junk from numbers
145 Q $S($P(B,"^",5):+$TR(A,", "),1:A)
146 ;
147EXSING(IBF) ; print single valued data first
148 S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D
149 . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
150 . X ^IBAT(351.62,IBF1,1)
151 . W $$STRIP(IBXDATA,IBF1(0)),"|"
152 Q
153 ;
154PRTH ; header
155 S IBC=0
156 D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT
157 W !
158 S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D
159 . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
160 . W $P(IBF1(0),"^"),?IBC
161 ;
162 ; multiple part of header
163 S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D
164 . D PRTG(.IBMUL,.IBF,.IBF1,.IBC)
165 . W $P(IBF1(0),"^"),?IBC
166 ;
167 W ! F IBC=1:1:IOM W "-"
168 Q
169PRTG(X,Y,Z,C) ; general printing stuff
170 S Z=0,Z=$O(X(Y,Z))
171 S Z(0)=X(Y,Z)
172 I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6
173 Q
174SEL(B) ; selection of which fields B = default
175 ; sets up variables IBFIELD and IBMUL
176 ; returns max length of output
177 ;
178 N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM
179 S (IBR,IBM)=0
180 ;
181AGAIN S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"")
182 S DIR("?")="Select what fields you want printed. Ranges must start with a valid number."
183 D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0
184 ;
185 ; if default selected set Y
186 S:Y="" Y=$G(B)
187 ;
188 ; validate input
189 I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN
190 F X=1:1 Q:$P(Y,",",X)="" S:'$D(^IBAT(351.62,"AC",$P(Y,",",X))) Y=$P(Y,",",1,X-1)_","_$P(Y,",",X+1,98),X=X-1
191 ;
192 ; setup variables for output
193 F X=1:1 Q:'$P(Y,",",X) S W=+$P($Q(^IBAT(351.62,"AC",$P(Y,",",X))),",",4),Z=^IBAT(351.62,W,0),IBR=$S($P(Z,"^",3):"IBMUL",1:"IBFIELD"),@(IBR_"("_X_","_W_")")=Z,@IBR=$G(@IBR)+$P(Z,"^",2)+1
194 ;
195 Q $G(IBFIELD)+$G(IBMUL)
196 ;
197DISP ; displays fields for selection
198 ;
199 N IBX,IBL,IBI
200 ;
201 ; set up lines
202 S (IBX,IBL)=0 F S IBX=$O(^IBAT(351.62,"AC",IBX)),IBL=IBL+1 Q:IBX<1 S:IBX=40 IBL=1 S IBI=+$P($Q(^IBAT(351.62,"AC",IBX)),",",4),IBL(IBL,$S(IBX<40:0,1:40))=^IBAT(351.62,IBI,0)
203 ;
204 ; display lines
205 W @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed. Fields with an asterisk (*) are fields that are multiples.",!
206 S IBX="" F S IBX=$O(IBL(IBX)) Q:IBX="" W ! S IBI="" F S IBI=$O(IBL(IBX,IBI)) Q:IBI="" W ?IBI,$P(IBL(IBX,IBI),"^",4),?IBI+4,$S($P(IBL(IBX,IBI),"^",3):"*",1:""),$P(IBL(IBX,IBI),"^")
207 ;
208 W !
209 ;
210 Q
Note: See TracBrowser for help on using the repository browser.