IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine is called by the nightly back ground job. It will go
; through the prosthetics file (660) and look for transfer pricing
; transactions that it has not previously found. It looks for T-30
; through T based upon the delivery date. File 660 - dbia #373
;
EN ;
I '$P($G(^IBE(350.9,1,10)),"^",5) Q ; transfer pricing turned off
;
N IBDT,IBDA
;
; date range t-30 to t
S IBDT=$$FMADD^XLFDT(DT,-30)
;
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
;
Q
;
CHECK ; check if transfer pricing and not already added
;
N IBDATA,IBDATA1,IBDFN
;
; already in file
I $O(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0)) Q
;
; valid tp patient
S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" S IBDATA1=$G(^RMPR(660,+IBDA,1))
S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN Q:'$$TPP^IBATUTL(IBDFN)
;
; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
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
;
; now if inpt, must be in 351.67
I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA1,"^",4))) Q
;
Q:'$P(IBDATA,"^",16) ; no total cost, at least yet
;
FILE ; ok transaction needs to be filled in tp files
;
S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATER 1699 printed Sep 23, 2025@19:44 Page 2
IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
+1 ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine is called by the nightly back ground job. It will go
+5 ; through the prosthetics file (660) and look for transfer pricing
+6 ; transactions that it has not previously found. It looks for T-30
+7 ; through T based upon the delivery date. File 660 - dbia #373
+8 ;
EN ;
+1 ; transfer pricing turned off
IF '$PIECE($GET(^IBE(350.9,1,10)),"^",5)
QUIT
+2 ;
+3 NEW IBDT,IBDA
+4 ;
+5 ; date range t-30 to t
+6 SET IBDT=$$FMADD^XLFDT(DT,-30)
+7 ;
+8 FOR
SET IBDT=$ORDER(^RMPR(660,"CT",IBDT))
if 'IBDT!(IBDT>DT)
QUIT
SET IBDA=""
FOR
SET IBDA=$ORDER(^RMPR(660,"CT",IBDT,IBDA))
if 'IBDA
QUIT
DO CHECK
+9 ;
+10 QUIT
+11 ;
CHECK ; check if transfer pricing and not already added
+1 ;
+2 NEW IBDATA,IBDATA1,IBDFN
+3 ;
+4 ; already in file
+5 IF $ORDER(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0))
QUIT
+6 ;
+7 ; valid tp patient
+8 SET IBDATA=$GET(^RMPR(660,+IBDA,0))
if IBDATA=""
QUIT
SET IBDATA1=$GET(^RMPR(660,+IBDA,1))
+9 SET IBDFN=$PIECE(IBDATA,"^",2)
if 'IBDFN
QUIT
if '$$TPP^IBATUTL(IBDFN)
QUIT
+10 ;
+11 ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
+12 IF $SELECT('$DATA(^RMPR(660,IBDA,"AM")):1,$PIECE(IBDATA,"^",9)="":1,$PIECE(IBDATA,"^",12)="":1,$PIECE(IBDATA1,"^",4)="":1,$PIECE(IBDATA,"^",14)="V":1,$PIECE(IBDATA,"^",15)="*":1,1:0)
QUIT
+13 ;
+14 ; now if inpt, must be in 351.67
+15 IF $PIECE(^RMPR(660,IBDA,"AM"),"^",3)'=1
IF $PIECE(^("AM"),"^",3)'=4
IF '$DATA(^IBAT(351.67,"B",$PIECE(IBDATA1,"^",4)))
QUIT
+16 ;
+17 ; no total cost, at least yet
if '$PIECE(IBDATA,"^",16)
QUIT
+18 ;
FILE ; ok transaction needs to be filled in tp files
+1 ;
+2 SET IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$PIECE(IBDATA,"^",16))
+3 ;
+4 QUIT
