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

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1IBCRBG2 ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT CONT) ; 01-OCT-03
2 ;;2.0;INTEGRATED BILLING;**245,175,332,364**;21-MAR-94;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5INPTRSET(IBIFN,CS) ; reset Inpatient data due to bedsection Tort 03 and Other Type of Care RC v2.0
6 ; (based on INPTPTF since that deals with timeframe and end of bill)
7 N IBRC S IBRC=1 I +$G(CS),$E($G(^IBE(363.1,+CS,0)),1,2)'="RC" S IBRC=0
8 ;
9 D INPTBS(IBIFN,IBRC)
10 D INPTOTH(IBIFN,IBRC)
11 Q
12 ;
13INPTBS(IBIFN,RC) ; with output from INPTPTF^IBCRBG, reset bedsections due to changes with Tort 03 and RC
14 ; - Some Specialties are changed to PRRTP bedsection (beginning with Tort 03)
15 ; - Some Specialties are changed to ICU bedsection for RC only (beginning with RC v2.0)
16 ; - Nursing Home Care and Observation bedsections are not billable with RC DRG (per diem) so remove DRG
17 ; (based on INPTPTF since that deals with timeframe and end of bill)
18 ;
19 N IBDT,IBLN,IBSPCLTY,IBNLN,IBNBS,IBNDRG,IBCGTY
20 ;
21 S IBDT=0 F S IBDT=$O(^TMP($J,"IBCRC-INDT",IBDT)) Q:'IBDT D
22 . S IBLN=$G(^TMP($J,"IBCRC-INDT",IBDT)) Q:'IBLN
23 . S IBSPCLTY=$P(IBLN,U,6) Q:'IBSPCLTY
24 . ;
25 . S IBNLN=IBLN
26 . S IBNBS=$$BSUPD(IBSPCLTY,IBDT,+$G(RC)) I +IBNBS S $P(IBNLN,U,2)=+IBNBS
27 . S IBNDRG=$$NODRG(IBSPCLTY) I +IBNDRG S $P(IBNLN,U,4)=""
28 . I 'IBNBS,'IBNDRG Q
29 . S ^TMP($J,"IBCRC-INDT",IBDT)=IBNLN
30 Q
31 ;
32INPTOTH(IBIFN,RC) ; with output from INPTPTF^IBCRBG, reset Other type of care and Tort 03 changes
33 ; - If type of care is Other then bedsection is replaced and DRG deleted (began with RC v2.0)
34 ; (based on INPTPTF since that deals with timeframe and end of bill)
35 ;
36 N IBOT,IBOTLN,IBBS,IBDT1,IBDT2,IBDT,IBLN,IBNLN Q:'$G(RC)
37 I +$G(IBIFN) S IBOT=0 F S IBOT=$O(^DGCR(399,IBIFN,"OT",IBOT)) Q:'IBOT D
38 . S IBOTLN=$G(^DGCR(399,IBIFN,"OT",IBOT,0)) Q:'IBOTLN
39 . S IBDT1=+$P(IBOTLN,U,2) Q:'IBDT1 S IBDT2=+$P(IBOTLN,U,3) Q:'IBDT2
40 . S IBBS=+IBOTLN Q:'IBOTLN
41 . ;
42 . S IBDT=IBDT1-.1 F S IBDT=$O(^TMP($J,"IBCRC-INDT",IBDT)) Q:('IBDT)!(IBDT'<IBDT2) D
43 .. S IBLN=$G(^TMP($J,"IBCRC-INDT",IBDT)) Q:'IBLN
44 .. I IBDT<$$RC20 Q
45 .. ;
46 .. S IBNLN=IBLN
47 .. S $P(IBNLN,U,2)=+IBBS,$P(IBNLN,U,4)=""
48 .. S ^TMP($J,"IBCRC-INDT",IBDT)=IBNLN
49 Q
50 ;
51 ;
52BSUPD(SPCLTY,DATE,RC) ; return updated bedsection name for specialty passed in (42.4 ifn)
53 ; beginning with TORT 2003 some specialties were moved to new PRRTP bedsection
54 ; beginning with RC v2.0 some specialties were moved to a new ICU bedsection, only applies to RC charges
55 N IBX,IBY,IBZ S (IBZ,IBX)="",SPCLTY=","_+$G(SPCLTY)_",",DATE=$S(+$G(DATE):(DATE\1),1:DT)
56 I DATE'<$$TORT03,",25,26,27,28,29,38,39,"[SPCLTY S IBX="PRRTP"
57 I +$G(RC),DATE'<$$RC20,",12,13,16,17,63,"[SPCLTY S IBX="ICU"
58 I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX
59 Q IBZ
60 ;
61TORT03() ; return effective date of TORT 2003, date when PRRTP bedsection specialties changed
62 Q 3040107
63 ;
64RC20() ; return effective date of RC v2.0, date when ICU bedsection specialties changed
65 Q 3031219
66 ;
67NODRG(SPCLTY) ; return specialty ifn followed by bedsection name if the specialty should not be charged a DRG charge
68 N IBX,IBS S IBX=0,IBS=","_+$G(SPCLTY)_","
69 I ",80,81,96,42,43,44,45,46,64,66,67,68,69,95,100,101,102,"[IBS S IBX=+SPCLTY_"^Nursing Home Care"
70 I ",18,23,24,36,41,65,94,"[IBS S IBX=+SPCLTY_"^Observation"
71 Q IBX
Note: See TracBrowser for help on using the repository browser.