| 1 | IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; This routine is called by the nightly back ground job. It will go
|
|---|
| 6 | ; through the prosthetics file (660) and look for transfer pricing
|
|---|
| 7 | ; transactions that it has not previously found. It looks for T-30
|
|---|
| 8 | ; through T based upon the delivery date. File 660 - dbia #373
|
|---|
| 9 | ;
|
|---|
| 10 | EN ;
|
|---|
| 11 | I '$P($G(^IBE(350.9,1,10)),"^",5) Q ; transfer pricing turned off
|
|---|
| 12 | ;
|
|---|
| 13 | N IBDT,IBDA
|
|---|
| 14 | ;
|
|---|
| 15 | ; date range t-30 to t
|
|---|
| 16 | S IBDT=$$FMADD^XLFDT(DT,-30)
|
|---|
| 17 | ;
|
|---|
| 18 | F S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>DT) S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D CHECK
|
|---|
| 19 | ;
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | CHECK ; check if transfer pricing and not already added
|
|---|
| 23 | ;
|
|---|
| 24 | N IBDATA,IBDATA1,IBDFN
|
|---|
| 25 | ;
|
|---|
| 26 | ; already in file
|
|---|
| 27 | I $O(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0)) Q
|
|---|
| 28 | ;
|
|---|
| 29 | ; valid tp patient
|
|---|
| 30 | S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" S IBDATA1=$G(^RMPR(660,+IBDA,1))
|
|---|
| 31 | S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN Q:'$$TPP^IBATUTL(IBDFN)
|
|---|
| 32 | ;
|
|---|
| 33 | ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
|
|---|
| 34 | I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
|
|---|
| 35 | ;
|
|---|
| 36 | ; now if inpt, must be in 351.67
|
|---|
| 37 | I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA1,"^",4))) Q
|
|---|
| 38 | ;
|
|---|
| 39 | Q:'$P(IBDATA,"^",16) ; no total cost, at least yet
|
|---|
| 40 | ;
|
|---|
| 41 | FILE ; ok transaction needs to be filled in tp files
|
|---|
| 42 | ;
|
|---|
| 43 | S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
|
|---|
| 44 | ;
|
|---|
| 45 | Q
|
|---|
