IBATEI1 ;ALB/BGA- TRANSFER PRICING BACKGROUND JOB ; 20-MAR-99
;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
;; Per VHA Directive 10-93-142, this routine should not be modified
;
BACKGRD ; This is the back ground job that monitors all the entries in 351.61
; If the entry is complete we check to see if there is a closed entry
; in PTF if there is we price the claim and change the status of
; the entry to priced.
;
; do prosthetics first
D ^IBATER
;
N IBI,IBREC,IBIAT,IBREST,IBPTF,IBTDFN,IBREC,IBDISHG,IBDPM,IBRECN,IBFINDRT,IBTFILE
I '$P($G(^IBE(350.9,1,10)),"^",2) Q ; transfer pricing turned off
S IBREC="^IBAT(351.61,"_"""AF"""_","_"""C"""_")"
F S IBREC=$Q(@IBREC) Q:IBREC=""!($P(IBREC,",",3)'="""C""") D
. S IBIAT=$P($P(IBREC,",",4),")")
. S IBRECN=$G(^IBAT(351.61,IBIAT,0))
. S IBTDFN=$P(IBRECN,U,2)
. S IBPTF=$P($G(^IBAT(351.61,+IBIAT,1)),U,7) Q:'IBPTF ;ien ptf
. S IBDISHG=$P($G(^IBAT(351.61,+IBIAT,1)),U,8) ; ien 405 discharge date Q:'IBIDSHG
. S IBDPM=$P($G(^DGPM(+IBDISHG,0)),U,14) ; pointer to the parent movement
. Q:IBDPM<1 ; No Movement Found
. ; Inorder to price we need to have a closed PTF
. I $P($G(^DGPT(IBPTF,0)),U,6)<1 Q
. ; Pass in PTF=IBPTF ; ien DGPM (parent) ; DFN
. S IBFINDRT=$$FINDRT^IBATEI(IBPTF,IBDPM,IBTDFN)
. Q:'$P(IBFINDRT,U)
. I $P(IBFINDRT,U,3)="B" D Q
. . ; case of bedsection pass in ien 351.61,"0" for drg, the value of bed section charge
. . S IBTFILE=$$INPT^IBATFILE(IBIAT,0,$P(IBFINDRT,U,2),"","","","")
. E D
. . ; pass in ien 351.61,ien drg,drg value,los,high trim,outlier days,outlier rate
. . S IBTFILE=$$INPT^IBATFILE(IBIAT,$P(IBFINDRT,U,3),$P(IBFINDRT,U,2),$P(IBFINDRT,U,4),$P(IBFINDRT,U,5),$P(IBFINDRT,U,6),$P(IBFINDRT,U,7))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATEI1 1751 printed Nov 22, 2024@17:17:49 Page 2
IBATEI1 ;ALB/BGA- TRANSFER PRICING BACKGROUND JOB ; 20-MAR-99
+1 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified
+3 ;
BACKGRD ; This is the back ground job that monitors all the entries in 351.61
+1 ; If the entry is complete we check to see if there is a closed entry
+2 ; in PTF if there is we price the claim and change the status of
+3 ; the entry to priced.
+4 ;
+5 ; do prosthetics first
+6 DO ^IBATER
+7 ;
+8 NEW IBI,IBREC,IBIAT,IBREST,IBPTF,IBTDFN,IBREC,IBDISHG,IBDPM,IBRECN,IBFINDRT,IBTFILE
+9 ; transfer pricing turned off
IF '$PIECE($GET(^IBE(350.9,1,10)),"^",2)
QUIT
+10 SET IBREC="^IBAT(351.61,"_"""AF"""_","_"""C"""_")"
+11 FOR
SET IBREC=$QUERY(@IBREC)
if IBREC=""!($PIECE(IBREC,",",3)'="""C""")
QUIT
Begin DoDot:1
+12 SET IBIAT=$PIECE($PIECE(IBREC,",",4),")")
+13 SET IBRECN=$GET(^IBAT(351.61,IBIAT,0))
+14 SET IBTDFN=$PIECE(IBRECN,U,2)
+15 ;ien ptf
SET IBPTF=$PIECE($GET(^IBAT(351.61,+IBIAT,1)),U,7)
if 'IBPTF
QUIT
+16 ; ien 405 discharge date Q:'IBIDSHG
SET IBDISHG=$PIECE($GET(^IBAT(351.61,+IBIAT,1)),U,8)
+17 ; pointer to the parent movement
SET IBDPM=$PIECE($GET(^DGPM(+IBDISHG,0)),U,14)
+18 ; No Movement Found
if IBDPM<1
QUIT
+19 ; Inorder to price we need to have a closed PTF
+20 IF $PIECE($GET(^DGPT(IBPTF,0)),U,6)<1
QUIT
+21 ; Pass in PTF=IBPTF ; ien DGPM (parent) ; DFN
+22 SET IBFINDRT=$$FINDRT^IBATEI(IBPTF,IBDPM,IBTDFN)
+23 if '$PIECE(IBFINDRT,U)
QUIT
+24 IF $PIECE(IBFINDRT,U,3)="B"
Begin DoDot:2
+25 ; case of bedsection pass in ien 351.61,"0" for drg, the value of bed section charge
+26 SET IBTFILE=$$INPT^IBATFILE(IBIAT,0,$PIECE(IBFINDRT,U,2),"","","","")
End DoDot:2
QUIT
+27 IF '$TEST
Begin DoDot:2
+28 ; pass in ien 351.61,ien drg,drg value,los,high trim,outlier days,outlier rate
+29 SET IBTFILE=$$INPT^IBATFILE(IBIAT,$PIECE(IBFINDRT,U,3),$PIECE(IBFINDRT,U,2),$PIECE(IBFINDRT,U,4),$PIECE(IBFINDRT,U,5),$PIECE(IBFINDRT,U,6),$PIECE(IBFINDRT,U,7))
End DoDot:2
End DoDot:1
+30 QUIT
