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

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

revised back to 6/30/08 version
File size: 8.1 KB
Line 
1IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING ; 22-JAN-1999
2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn
5 Q:'$G(DA) 0
6 I $D(^IBAT(351.6,DA,0)) Q DA
7 N DO,DD,DIC,X,DINUM
8 S DIC="^IBAT(351.6,",DIC(0)="",X=DA,DINUM=DA
9 S DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($G(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$S($D(IBOVER):";.1////"_+IBOVER,1:"")
10 D FILE^DICN
11 Q $S(Y>0:Y,1:0)
12UPPPF(DA,PPF) ; updates a patient's enrolled facility
13 I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q
14 N DIE,DR
15 S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE
16 Q
17ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions
18 ; IBADMDT=admission date, IBPREF=enrolled facility
19 ; IBSOURCE=source (movement ien;DGPM(
20 I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
21 Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE)
22DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges
23 ; DA=transaction ien in 351.61, IBDISDT=discharge date
24 ; IBPTF=ptf pointer, IBDISM=discharge movement pointer
25 I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0
26 N DIE,DR
27 S DIE="^IBAT(351.61,"
28 S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM
29 L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
30 D ^DIE L -^IBAT(351.61,DA)
31 Q DA
32DISC(DA) ; - deletes discharge data
33 ; DA=transaction ien in 351.61
34 N DIE,DR Q:'$G(DA) 0
35 S DIE="^IBAT(351.61,"
36 S DR=".05////E;.1///@;1.08///@"
37 L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
38 D ^DIE L -^IBAT(351.61,DA)
39 Q DA
40INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt
41 ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer
42 ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days
43 ; IBOUT=outlier days,IBOUTR=outlier rate
44 I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0
45 N DIE,X,Y,DR
46 S DIE="^IBAT(351.61,",DA=IBIEN
47 S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT
48 S:$G(IBDRG) DR=DR_";1.01///"_IBDRG
49 S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA
50 S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR
51 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
52 D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D
53 . S DR=";.05////P;.13////"_DT D ^DIE
54 L -^IBAT(351.61,IBIEN)
55 Q IBIEN
56OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data
57 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
58 ; IBSOURCE=source (outpatient encounter ien;SCE(
59 ; IBPROC=procedures (by ref in array)
60 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
61 N IBIEN,IBX,Y,IBPRICE
62 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
63 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
64 S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
65 I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
66 S DIE="^IBAT(351.61,",DA=IBIEN
67 S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
68 D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
69 Q IBIEN
70UPDATE(IBIEN,IBPROC) ; -- updates procedures
71 ; IBIEN=351.61 ien, IBPROC=procedures by ref like above
72 Q:'$G(IBIEN) 0
73 N IBX,IBPRICE,DIE,DA,DR,X,Y
74 S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4)
75 ; if approved, cancel and create a new one
76 I $P(IBIEN(0),"^",5)="A" D Q IBIEN
77 . S IBIEN=$$CANC(IBIEN)
78 . S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC)
79 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
80 ; first clean out procedures there
81 S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK
82 S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
83 I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
84 S DIE="^IBAT(351.61,",DA=IBIEN
85 S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
86 D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
87 Q IBIEN
88RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data
89 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
90 ; IBSOURCE=source (prescription ien;PSRX(;refill #
91 ; IBDRUG=ien from drug file
92 ; IBQTY=quantity of drug, IBCOST=drug cost
93 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0
94 N IBIEN
95 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
96 S DIE="^IBAT(351.61,",DA=IBIEN
97 S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C")
98 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
99 D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
100 L -^IBAT(351.61,IBIEN)
101 Q IBIEN
102 ;
103RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data
104 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
105 ; IBSOURCE=source (prost ien;RMPR(660,
106 ; IBPROS=ien from file 661
107 ; IBCOST=item cost
108 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) Q 0
109 N IBIEN
110 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
111 S DIE="^IBAT(351.61,",DA=IBIEN
112 S DR=".1////"_+IBEDT_";4.04////"_+IBPROS_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
113 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
114 D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
115 L -^IBAT(351.61,IBIEN)
116 Q IBIEN
117 ;
118CANC(DA) ; - used to cancel any transaction
119 N DIE,DR,X,Y Q:'$G(DA)
120 S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE
121 Q
122DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx)
123 N DIK,DR,X,Y,Z Q:'$G(DA)
124 S Z=$G(^IBAT(351.61,DA,0)) Q:'Z
125 Q:$P(Z,"^",12)["SCE("
126 S DIK="^IBAT(351.61," D ^DIK
127 Q
128NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien
129 N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR
130 S IBSITE=$$SITE^IBATUTL
131 L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked"
132 L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked"
133 S IBIEN=$P(^IBAT(351.61,0),"^",3)+1
134 F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN))
135 S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61
136 S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE"
137 D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction"
138 S DIE="^IBAT(351.6,",DA=+DFN
139 S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT
140 I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))<IBEDT D ^DIE
141 L -(^IBAT(351.61,0),^IBAT(351.6,DFN))
142 Q IBIEN
143PROC(IBIEN,IBPROC,IBPRICE) ; files procedures
144 N X,Y
145 S Y=1,IBX=0 F S IBX=$O(IBPROC(IBX)) Q:IBX=""!(+Y<1) D
146 . N DIC,X,DA,DD,DO
147 . S DIC="^IBAT(351.61,"_IBIEN_",3,",DIC(0)="L"
148 . S X=IBX,DA(1)=IBIEN
149 . ;S DIC("P")=$P(^DD(351.61,3,0),"^",2) ; no longer required with fm22
150 . S DIC("DR")=".02////"_$P(IBPROC(IBX),"^")
151 . I $P(IBPROC(IBX),"^",2) S DIC("DR")=DIC("DR")_";.03////"_$P(IBPROC(IBX),"^",2)
152 . E S IBPRICE=1
153 . D FILE^DICN
154 I +Y<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
155 Q IBIEN
156DX(IBIEN,IBPTF) ; - files dx info
157 Q IBIEN
158 N IBX,Y S Y=1,IBX="" F S IBX=$O(IBDX(IBX)) Q:IBX=""!(+Y<1) D
159 . N DD,DO,DIC,DINUM,X
160 . S DIC="^IBAT(351.61,"_IBIEN_",2,",DIC(0)="",X=$P(IBDX(IBX),"^")
161 . ;S DA(1)=IBIEN,DIC("P")=$P(^DD(351.61,2,0),"^",2) D FILE^DICN
162 . ; no longer required with fm22
163 . S DA(1)=IBIEN D FILE^DICN
164 Q $S(+Y<1:"0^Unable to file diagnosis's",1:IBIEN)
165 ;
166INIT ; called to possibly initialize the 351.6 file if not done
167 N IBS,ZTRTN,ZTDESC,ZTIO,ZTSK,X,Y
168 ;
169 Q:$O(^IBAT(351.6,0)) ; already populated
170 ;
171 ; is Transfer Pricing active or not for any
172 S IBS=$G(^IBE(350.9,1,10))
173 I '$P(IBS,"^",2),'$P(IBS,"^",3),'$P(IBS,"^",4),'$P(IBS,"^",5) Q
174 ;
175 ; queue off job
176 W !!,"It appears you have never used Transfer Pricing before. I need to populate",!,"the Transfer Pricing patient file. Please select a date/time to do this.",!
177 S ZTRTN="ADDTP^IBATFILE",ZTDESC="Initializing Transfer Pricing Patient File",ZTIO="" D ^%ZTLOAD
178 I $G(ZTSK) W !,"Task Queued #",ZTSK
179 ;
180 Q
181ADDTP ; Add Transfer Pricing patients to file #351.6
182 ;
183 N DFN,IBADM,IBDFN,IBPREF,IBADMDT,IBX
184 ;
185 S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN D
186 .;
187 .S IBDFN=$$TPP^IBATUTL(DFN)
188 .Q:'IBDFN
189 .;
190 .; - see if they are admitted
191 .S IBADM=$G(^DPT(DFN,.105))
192 .I IBADM D
193 ..S IBPREF=+$P($G(^IBAT(351.6,DFN,0)),"^",3)
194 ..S IBADMDT=+$G(^DGPM(IBADM,0))
195 ..S IBX=$$ADM(DFN,IBADMDT,IBPREF,IBADM_";DGPM(")
196 ;
197 Q
Note: See TracBrowser for help on using the repository browser.