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