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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1IBEFUNC1 ;ALB/ARH - CPT BILLING EXTRINSIC FUNCTIONS ; 11/27/91
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;created front-ends for extrinsic functions for use until all versions of file man can use them
6FCC ;
7 S IBCHGX=$$CPTCHG($S('$D(IBCDX):"",1:IBCDX),$S('$D(IBDIVX):"",1:IBDIVX),$S('$D(IBDTX):"",1:IBDTX))
8 Q
9 ;
10CPTCHG(CODE,DIV,DATE) ;ambulatory procedure billing charge on a date
11 ;assumes current date if none passed in (to disallow guessing on division pass in +DIV)
12 ;assumes first active division if (DIV=""!'$D(DIV)) passed in
13 ;returns - the charge if code is valid and active in Billing on DATE
14 ; - "" if unable to calc charge or there was none
15 ; division or rate group inactive on date or not defined in file
16 N X,%,%H,%I,Y
17 S Y=-1 G:'$D(CODE) ENDCHG
18 S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
19 S:'$D(DIV) DIV="" I DIV="" S DIV=$$MCDIV(DIV,DATE)
20 I +$$CPTBSTAT(CODE,DATE) S X=DATE_"^"_DIV_"^"_+CODE D RATE^IBAUTL1
21ENDCHG Q $S(Y<0:"",1:Y)
22 ;
23FCBS ;
24 S IBSTX=$$CPTBSTAT($S('$D(IBCDX):"",1:IBCDX),$S('$D(IBDTX):"",1:IBDTX))
25 Q
26 ;
27CPTBSTAT(CODE,DATE) ;ambulatory procedure billing status on a date
28 ;assumes current date if none passed in
29 ;returns - "" if CODE had never been a billing code on/before DATE given or DATE before BASC start date
30 ; - 0^INACTIVE if CODE billing inactive on DATE given or rate group inactive on DATE
31 ; - 1^ACTIVE if CODE billing active on DATE given
32 N LN,ST,%,%H,%I,X
33 S ST="" I '$D(CODE) G ENDST
34 S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
35 I $$STDATE^IBCU63>DATE G ENDST
36 I $D(^IBE(350.4,+$O(^(+$O(^IBE(350.4,"AIVDT",+CODE,-(DATE+1))),0)),0)) S LN=^(0),ST=+$P(LN,"^",4)
37 I ST,$P($G(^IBE(350.2,+$P(LN,"^",3),0)),"^",2)>DATE S ST=""
38 S ST=ST_$S(ST'="":"^"_$P($P($P(^DD(350.4,.04,0),"^",3),ST_":",2),";",1),1:"")
39ENDST Q ST
40 ;
41FCR ;
42 S IBRGX=$$CPTRG($S('$D(IBCDX):"",1:IBCDX),$S('$D(IBDTX):"",1:IBDTX))
43 Q
44 ;
45CPTRG(CPT,DATE) ;find the rate group for the CPT on the given date
46 ;assumes current date if none passed in
47 ;returns - a rate group name
48 ; - "" if no rate group listed for date, or CPT or DATE is ""
49 N RATE,%,%H,%I,X
50 G:'$D(CPT) ENDRG
51 S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
52 I $D(^IBE(350.4,+$O(^(+$O(^IBE(350.4,"AIVDT",+CPT,-(DATE+1))),0)),0)) S RATE=$P($P($G(^IBE(350.1,+$P(^(0),"^",3),0)),"^",1)," ",2,999)
53ENDRG Q $S($D(RATE):RATE,1:"")
54 ;
55FMCD ;
56 S IBDIVX=$$MCDIV($S('$D(IBDIVX):"",1:IBDIVX),$S('$D(IBDTX):"",1:IBDTX))
57 Q
58 ;
59MCDIV(DIV,DATE) ;find the medical center division
60 ; if DATE is not defined then assumes current date
61 ;returns - DIV passed in, if its status is active for date given
62 ; - first active division found, if DIV was inactive or ""
63 ; - if all divisions are inactive for the given date, returns ""
64 N I,NDIV,INACT,%,%H,%I,X S DIV=$G(DIV)
65 ;I '$D(DIV) S DIV="" G ENDIV
66 S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
67 S NDIV=+$O(^(+$O(^IBE(350.5,"AIVDT",+DIV,-(DATE+1))),0))
68 I '$P($G(^IBE(350.5,NDIV,0)),"^",4) S DIV="" F I=1:1 S DIV=$O(^IBE(350.5,"AIVDT",DIV)) Q:DIV=""!('$D(INACT(+DIV))&($P($G(^IBE(350.5,+$O(^(+$O(^IBE(350.5,"AIVDT",+DIV,-(DATE+1))),0)),0)),"^",4))) S INACT(DIV)=""
69ENDIV Q DIV
70 ;
71RC(D0,D1,DATE) ;find BASC charge for particular revenue code entry (399,42)
72 ;input: D0 = bill ifn, D1 = revenue code sub-file IFN
73 ; if DATE not passed then assums STATEMENT FROM date of bill
74 ;returns: dollar amount if rev code has an active BASC CPT, otherwise ""
75 N X,Y,DA S X="",DATE=$P($G(DATE),".") I DATE'?7N S DATE=+$G(^DGCR(399,D0,"U"))
76 S Y=$G(^DGCR(399,D0,"RC",D1,0)) I +$P(Y,U,6),+$P(Y,U,7) S X=+$$CPTCHG^IBEFUNC1(+$P(Y,U,6),+$P(Y,U,7),DATE)
77 Q X
78 ;
79CP(D0,D1) ;find BASC charge for particular procedure entry (399,304)
80 ;input: D0 = bill IFN, D1 = procedure code sub-file IFN
81 ;returns: dollar amount if CPT is BASC active, otherwise ""
82 N X,Y,DA S X="",Y=$G(^DGCR(399,D0,"CP",D1,0)) I $P(Y,U,1)[";ICPT(",+$P(Y,U,2),+$P(Y,U,6) S X=$$CPTCHG^IBEFUNC1(+Y,+$P(Y,U,6),+$P(Y,U,2))
83 Q X
Note: See TracBrowser for help on using the repository browser.