- 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 Feb 18, 2025@23:34:09 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
