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

Last change on this file since 648 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1IBATEO ;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
44IBPRICE(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
Note: See TracBrowser for help on using the repository browser.