IBATEO ;ALB/BGA - TRANSFER PRICING OUTPATIENT TRACKER ; 19-MAR-99
;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
;;Per VHA DIRECTIVE 10-93-142, this routine should not be modified.
;
; Comment- This routine is invoked via the appointment driver ^IBAMTS
; This program checks for check outs and determines if
; the person checking out is a Transfer Pricing Patient
; if TP the routine prices the procedures and files the
; transaction in 351.61
;
; Determine if this encounter has a status of checked out
N IBORG,IBOE,IBEVT,IBEV0,IBERR,IB,IBI,IBDATE,IBRATE,IBPREF,IBPROC
N IBERR,IBQTY,IBATFILE,IBSDHDL,IBPROC,IBSOURCE,IBATIEN,IBOIEN,IBERR2
I '$P($G(^IBE(350.9,1,10)),"^",3) Q ; transfer pricing turned off
S IBSDHDL=0,U="^" F S IBSDHDL=$O(^TMP("SDEVT",$J,IBSDHDL)) Q:'IBSDHDL D
. S IBORG=0 F S IBORG=$O(^TMP("SDEVT",$J,IBSDHDL,IBORG)) Q:'IBORG D
. . S IBOE=0 F S IBOE=$O(^TMP("SDEVT",$J,IBSDHDL,IBORG,"SDOE",IBOE)) Q:'IBOE S IBEVT=$G(^(IBOE,0,"AFTER")),IBEV0=$G(^("BEFORE")) D
. . . Q:$P(IBEVT,U,6) ; do not evaluate sibling encounters
. . . Q:$P(IBEVT,U,12)=8 ; do not evaluate inpatient encounters
. . . ; Check encounter is checked out and is not being tracked in 351.61
. . . ; === NEW Entry
. . . I IBEVT]" ",('$D(^IBAT(351.61,"AD",(IBOE_";SCE(")))),$P(IBEVT,U,12)=2,$$TPP^IBATUTL($P(IBEVT,U,2)) D Q
. . . . K IBPROC,IBERR D IBPRICE(IBOE,IBEVT,.IBPROC,.IBERR)
. . . . Q:$P(IBERR,U)
. . . . ; Pass in (dfn,event date,facility,ibsource,procedure array)
. . . . S IBATFILE=$$OUT^IBATFILE($P(IBEVT,U,2),IBDATE,IBPREF,IBSOURCE,.IBPROC)
. . . . ; Encounter has status of checked out and has an entry in 351.61
. . . . ; and the Encounter has been updated.
. . . I IBEVT]" ",$D(^IBAT(351.61,"AD",(IBOE_";SCE("))),$P(IBEVT,U,12)=2 D Q
. . . . S IBSOURCE=IBOE_";SCE("
. . . . S IBATIEN=$O(^IBAT(351.61,"AD",IBSOURCE,""))
. . . . K IBPROC,IBERR D IBPRICE(IBOE,IBEVT,.IBPROC,.IBERR)
. . . . Q:$P(IBERR,U)
. . . . S IBATFILE=$$UPDATE^IBATFILE(IBATIEN,.IBPROC)
. . . I IBEVT]" ",$D(^IBAT(351.61,"AD",(IBOE_";SCE("))),$P(IBEVT,U,12)'=2 D Q
. . . . I $P(IBEV0,U,12)=2 D Q
. . . . . ; This is the case where I have a check out that has been deleted
. . . . . ; "BEFORE" has a status of checked out the "AFTER" has a status
. . . . . ; of not check out and shows no date for check out process date
. . . . . S IBSOURCE=IBOE_";SCE("
. . . . . S IBATIEN=$O(^IBAT(351.61,"AD",IBSOURCE,""))
. . . . . D CANC^IBATFILE(IBATIEN)
Q
IBPRICE(IBOIEN,IBEVT,IBPROC,IBERR) ;
S IBERR=0
I $G(IBOIEN)<1!($G(IBEVT)<1) S IBERR=1 Q
I '$$TPP^IBATUTL($P(IBEVT,U,2)) S IBERR="1^Not currently a TP patient" Q ; determine if transfer pricing patient
S IBPREF=$$PPF^IBATUTL($P(IBEVT,U,2)) I 'IBPREF S IBERR="1^No pref. facility found" Q
K IB,IBERR2 D GETCPT^SDOE(IBOE,"IB","IBERR2")
I $D(IBERR2) S IBERR="1^No procedures could be found for IBOE="_IBOIEN Q
S IBDATE=$P($P(IBEVT,U),".") I 'IBDATE S IBERR="1^No event date found for IBOE="_IBOIEN Q
S IBSOURCE=IBOE_";SCE("
K IBPROC S IBI=0 F S IBI=$O(IB(IBI)) Q:'IBI D
. S IBRATE=$$OPT^IBATCM($P(IB(IBI),U),IBDATE,IBPREF)
. I '$P(IBRATE,U)!($P(IBRATE,U,4)<1) Q ; could not price the procedure
. S IBRATE=$P(IBRATE,U,4),IBQTY=$P(IB(IBI),U,16)
. S IBPROC($P(IB(IBI),U))=IBQTY_U_IBRATE
I '$D(IBPROC) S IBERR="1^Could not find any procedures for IBOE="_IBOIEN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATEO 3433 printed Sep 23, 2025@19:43:58 Page 2
IBATEO ;ALB/BGA - TRANSFER PRICING OUTPATIENT TRACKER ; 19-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 ;
+4 ; Comment- This routine is invoked via the appointment driver ^IBAMTS
+5 ; This program checks for check outs and determines if
+6 ; the person checking out is a Transfer Pricing Patient
+7 ; if TP the routine prices the procedures and files the
+8 ; transaction in 351.61
+9 ;
+10 ; Determine if this encounter has a status of checked out
+11 NEW IBORG,IBOE,IBEVT,IBEV0,IBERR,IB,IBI,IBDATE,IBRATE,IBPREF,IBPROC
+12 NEW IBERR,IBQTY,IBATFILE,IBSDHDL,IBPROC,IBSOURCE,IBATIEN,IBOIEN,IBERR2
+13 ; transfer pricing turned off
IF '$PIECE($GET(^IBE(350.9,1,10)),"^",3)
QUIT
+14 SET IBSDHDL=0
SET U="^"
FOR
SET IBSDHDL=$ORDER(^TMP("SDEVT",$JOB,IBSDHDL))
if 'IBSDHDL
QUIT
Begin DoDot:1
+15 SET IBORG=0
FOR
SET IBORG=$ORDER(^TMP("SDEVT",$JOB,IBSDHDL,IBORG))
if 'IBORG
QUIT
Begin DoDot:2
+16 SET IBOE=0
FOR
SET IBOE=$ORDER(^TMP("SDEVT",$JOB,IBSDHDL,IBORG,"SDOE",IBOE))
if 'IBOE
QUIT
SET IBEVT=$GET(^(IBOE,0,"AFTER"))
SET IBEV0=$GET(^("BEFORE"))
Begin DoDot:3
+17 ; do not evaluate sibling encounters
if $PIECE(IBEVT,U,6)
QUIT
+18 ; do not evaluate inpatient encounters
if $PIECE(IBEVT,U,12)=8
QUIT
+19 ; Check encounter is checked out and is not being tracked in 351.61
+20 ; === NEW Entry
+21 IF IBEVT]" "
IF ('$DATA(^IBAT(351.61,"AD",(IBOE_";SCE("))))
IF $PIECE(IBEVT,U,12)=2
IF $$TPP^IBATUTL($PIECE(IBEVT,U,2))
Begin DoDot:4
+22 KILL IBPROC,IBERR
DO IBPRICE(IBOE,IBEVT,.IBPROC,.IBERR)
+23 if $PIECE(IBERR,U)
QUIT
+24 ; Pass in (dfn,event date,facility,ibsource,procedure array)
+25 SET IBATFILE=$$OUT^IBATFILE($PIECE(IBEVT,U,2),IBDATE,IBPREF,IBSOURCE,.IBPROC)
+26 ; Encounter has status of checked out and has an entry in 351.61
+27 ; and the Encounter has been updated.
End DoDot:4
QUIT
+28 IF IBEVT]" "
IF $DATA(^IBAT(351.61,"AD",(IBOE_";SCE(")))
IF $PIECE(IBEVT,U,12)=2
Begin DoDot:4
+29 SET IBSOURCE=IBOE_";SCE("
+30 SET IBATIEN=$ORDER(^IBAT(351.61,"AD",IBSOURCE,""))
+31 KILL IBPROC,IBERR
DO IBPRICE(IBOE,IBEVT,.IBPROC,.IBERR)
+32 if $PIECE(IBERR,U)
QUIT
+33 SET IBATFILE=$$UPDATE^IBATFILE(IBATIEN,.IBPROC)
End DoDot:4
QUIT
+34 IF IBEVT]" "
IF $DATA(^IBAT(351.61,"AD",(IBOE_";SCE(")))
IF $PIECE(IBEVT,U,12)'=2
Begin DoDot:4
+35 IF $PIECE(IBEV0,U,12)=2
Begin DoDot:5
+36 ; This is the case where I have a check out that has been deleted
+37 ; "BEFORE" has a status of checked out the "AFTER" has a status
+38 ; of not check out and shows no date for check out process date
+39 SET IBSOURCE=IBOE_";SCE("
+40 SET IBATIEN=$ORDER(^IBAT(351.61,"AD",IBSOURCE,""))
+41 DO CANC^IBATFILE(IBATIEN)
End DoDot:5
QUIT
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+42 QUIT
IBPRICE(IBOIEN,IBEVT,IBPROC,IBERR) ;
+1 SET IBERR=0
+2 IF $GET(IBOIEN)<1!($GET(IBEVT)<1)
SET IBERR=1
QUIT
+3 ; determine if transfer pricing patient
IF '$$TPP^IBATUTL($PIECE(IBEVT,U,2))
SET IBERR="1^Not currently a TP patient"
QUIT
+4 SET IBPREF=$$PPF^IBATUTL($PIECE(IBEVT,U,2))
IF 'IBPREF
SET IBERR="1^No pref. facility found"
QUIT
+5 KILL IB,IBERR2
DO GETCPT^SDOE(IBOE,"IB","IBERR2")
+6 IF $DATA(IBERR2)
SET IBERR="1^No procedures could be found for IBOE="_IBOIEN
QUIT
+7 SET IBDATE=$PIECE($PIECE(IBEVT,U),".")
IF 'IBDATE
SET IBERR="1^No event date found for IBOE="_IBOIEN
QUIT
+8 SET IBSOURCE=IBOE_";SCE("
+9 KILL IBPROC
SET IBI=0
FOR
SET IBI=$ORDER(IB(IBI))
if 'IBI
QUIT
Begin DoDot:1
+10 SET IBRATE=$$OPT^IBATCM($PIECE(IB(IBI),U),IBDATE,IBPREF)
+11 ; could not price the procedure
IF '$PIECE(IBRATE,U)!($PIECE(IBRATE,U,4)<1)
QUIT
+12 SET IBRATE=$PIECE(IBRATE,U,4)
SET IBQTY=$PIECE(IB(IBI),U,16)
+13 SET IBPROC($PIECE(IB(IBI),U))=IBQTY_U_IBRATE
End DoDot:1
+14 IF '$DATA(IBPROC)
SET IBERR="1^Could not find any procedures for IBOE="_IBOIEN
+15 QUIT
