source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU63.m@ 710

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

initial load of FOIAVistA 6/30/08 version
File size: 3.5 KB
Line 
1IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
2 ;;2.0;INTEGRATED BILLING;**21,133,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRU63
6% ; BASC
7 Q:IBIDS(.11)'="i"
8 K ^UTILITY($J,"IB-ASC")
9 S DGRVCOD=$S($P($G(DGINPAR),"^",4):$P(DGINPAR,"^",4),$P($G(^IBE(350.9,1,1)),"^",18):$P(^(1),"^",18),1:"") Q:DGRVCOD=""
10 ;
11BLD S DGASC=0 F S DGASC=$O(^DGCR(399,IBIFN,"CP","ASC",1,DGASC)) Q:'DGASC S DGPROC=$G(^DGCR(399,IBIFN,"CP",DGASC,0)) I DGPROC D
12 .S DGDIV=$P(DGPROC,"^",6),DGDAT=$P(DGPROC,"^",2)
13 .Q:'DGDIV
14 .Q:DGDAT+.9<$$STDATE
15 .S:'$D(^UTILITY($J,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)) ^(+DGDIV)=0
16 .S ^(+DGDIV)=^UTILITY($J,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)+1
17 ;
18STORREV ;build revenue codes in bill
19 I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
20 S DGPROC=0 F S DGPROC=$O(^UTILITY($J,"IB-ASC",DGPROC)) Q:'DGPROC S DGDAT=0 F S DGDAT=$O(^UTILITY($J,"IB-ASC",DGPROC,DGDAT)) Q:'DGDAT S DGDIV=0 F S DGDIV=$O(^UTILITY($J,"IB-ASC",DGPROC,DGDAT,DGDIV)) Q:'DGDIV S DGBSLOS=^(DGDIV) D
21 .S X=DGDAT_"^"_DGDIV_"^"_DGPROC D ^IBAUTL1 S DGAMNT=Y Q:Y<1
22 .S X=DGRVCOD,DGBSI=$O(^DGCR(399.1,"B",DGBILLBS,0))
23 .D FILE
24 .Q
25 K DGDAT,DGPROC,DGDIV,DGRVCOD,DGASC
26 Q
27 ;
28FILE ;
29 S DA(1)=IBIFN
30 D FILE^IBCU62
31 W:'$G(IBAUTO) !,"Adding",?12,$E(00_DGRVCOD,($L(DGRVCOD)-1),($L(DGRVCOD)+1)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBILLBS I +$G(DGPROC) W ?65,$P($$CPT^ICPTCOD(+DGPROC),"^",2)
32 Q
33 ;
34STDATE() ; -start date for basc billing
35 Q $S($P($G(^IBE(350.9,1,1)),"^",24):$P(^(1),"^",24),1:9999999)
36 ;
37RX ;add rx refill charges (adds default rx cpt for cms-1500)
38 ;tries to use ins rx rev code, then site rx rev code finally standard revcode all with $20
39 I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
40 S DGBSLOS=IBCNT
41 S DGBS="PRESCRIPTION",DGBSI=$O(^DGCR(399.1,"B",DGBS,0)) Q:'DGBSI
42 I $$FT^IBCU3(IBIFN)=2 S DGPROC=$P($G(^IBE(350.9,1,1)),"^",30),DGDIV=""
43 S DGRVCOD=$P($G(DGINPAR),"^",10) ; ins rev cd
44 I DGRVCOD="" S DGRVCOD=$P($G(^IBE(350.9,1,1)),"^",28) ; site rev cd
45 I DGRVCOD="" D SETREV^IBCU62 G END ; standard rev cd
46 S DGAMNT=$$CHG(DGBSI,IBIDS(151),DGRVCOD) Q:'DGAMNT S X=DGRVCOD
47 D FILE
48END K DGPROC,DGDIV,DGRVCOD
49 Q
50 ;MAP TO DGCRU61
51 ;
52ALL ;delete all revenue codes that may have been set up automatically
53 ;ie = $d(^IB(399.5,"d",code ifn))
54 K DA S DA(1)=IBIFN,DA=0 I '$G(IBAUTO) W !,"Removing old Revenue Codes."
55 F DGII=0:0 S DA=$O(^DGCR(399,IBIFN,"RC",DA)) Q:DA<1 S X=$G(^DGCR(399,IBIFN,"RC",DA,0)) D
56 . ;remove revenue codes pre-defined for automatic use AND revenue codes for BASC charges (are automatically created)
57 . W:'$G(IBAUTO) "." D DEL
58 Q
59DEL S DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK L ^DGCR(399,IBIFN):1
60 Q
61 ;
62 ;
63CHG(IBSI,IBDT,IBRVCD) ; returns charge for bedsection and date, rev cd optional
64 N IBAMNT,IBACTDT,IBRC,IBDA,IBRT,IBQUIT,X S IBAMNT=0
65 ;
66 S IBACTDT=-(IBDT+.01) F S IBACTDT=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT)) Q:'IBACTDT!+IBAMNT D
67 . S IBRC=+IBRVCD,IBDA=0 F S IBDA=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA)) Q:'IBDA!+IBAMNT D
68 .. S IBRT=$G(^DGCR(399.5,+IBDA,0))
69 .. I $P(IBRT,U,6)["i",+$P(IBRT,U,5) S IBAMNT=$P(IBRT,U,4)
70 ;
71 I 'IBAMNT S IBACTDT=-(IBDT+.01) F S IBACTDT=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT)) Q:'IBACTDT!+IBAMNT D
72 . S IBRC="" F S IBRC=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC)) Q:'IBRC!+IBAMNT D
73 .. S IBDA=0 F S IBDA=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA)) Q:'IBDA!+IBAMNT D
74 ... S IBRT=$G(^DGCR(399.5,+IBDA,0))
75 ... I $P(IBRT,U,6)["i",+$P(IBRT,U,5) S IBAMNT=$P(IBRT,U,4)
76 Q IBAMNT
Note: See TracBrowser for help on using the repository browser.