- 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 Mar 13, 2025@21:12:36 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
