source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATEO.m@ 1464

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