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

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1IBCRHBRB ;ALB/ARH - RATES: UPLOAD RC V1.4 MOVE LAB CODES ; 06-JAN-2002
2 ;;2.0;INTEGRATED BILLING;**169**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; move selected Lab procedure RC V1.4 charges from Physician file to Outpatient Facility file
6 ; although the charges are calculated as Physician charges they usually should be billed on the UB-92
7 ;
8LAB ; move selected RV v1.4 Lab charges from Physician to Facility charge sets
9 N IBXRF,IBOX2,IBOX3,IBPHYS,IBPX2,IBPX3,IBLINE,IBCNT S IBCNT=0
10 ;
11 I $G(^XTMP("IBCR RC SITE","VERSION"))'=1.4 Q
12 ;
13 S IBXRF=$O(^XTMP("IBCR UPLOAD RC ")) I IBXRF'["IBCR UPLOAD RC " Q
14 ;
15 I '$D(ZTQUEUED) W !!,"Moving Lab charges from Physician to Facility Charge Sets ... "
16 ;
17 S IBOX2="Opt Fac",IBOX3=$O(^XTMP(IBXRF,IBOX2,999999999999),-1)
18 ;
19 S IBPHYS="Phys Fee "
20 S IBPX2=IBPHYS F S IBPX2=$O(^XTMP(IBXRF,IBPX2)) Q:IBPX2'[IBPHYS D
21 . S IBPX3="" F S IBPX3=$O(^XTMP(IBXRF,IBPX2,IBPX3)) Q:IBPX3="" D
22 .. S IBLINE=$G(^XTMP(IBXRF,IBPX2,IBPX3)) Q:IBLINE=""
23 .. I '$$MOVE($P(IBLINE,U,1)) Q
24 .. ;
25 .. S IBOX3=IBOX3+1,IBCNT=IBCNT+1
26 .. S $P(^XTMP(IBXRF,IBOX2),U,1)=$P(^XTMP(IBXRF,IBOX2),U,1)+1
27 .. S ^XTMP(IBXRF,IBOX2,IBOX3)=IBLINE
28 .. ;
29 .. S $P(^XTMP(IBXRF,IBPX2),U,1)=$P(^XTMP(IBXRF,IBPX2),U,1)-1
30 .. K ^XTMP(IBXRF,IBPX2,IBPX3)
31 ;
32 I '$D(ZTQUEUED) W IBCNT," charges moved"
33 Q
34 ;
35MOVE(CPT) ; return true if the Lab (8xxxx) code should be moved to the facility charge file
36 ;
37 N IBCPTX,MOVE S MOVE=0
38 I $E($G(CPT))=8,CPT?5N S MOVE=1,IBCPTX=","_$G(CPT)_","
39 I 'MOVE G MOVEQ
40 ;
41 I ",80500,80502,83020,83912,84165,84181,84182,85060,85097,85390,85576,"[IBCPTX S MOVE=0 G MOVEQ
42 I ",86077,86078,86079,86255,86256,86320,86325,86327,86334,87164,87207,"[IBCPTX S MOVE=0 G MOVEQ
43 I ",88141,88291,"[IBCPTX S MOVE=0 G MOVEQ
44 ;
45 I CPT'<88000,CPT'>88130 S MOVE=0 G MOVEQ
46 I CPT'<88160,CPT'>88162 S MOVE=0 G MOVEQ
47 I CPT'<88172,CPT'>88182 S MOVE=0 G MOVEQ
48 I CPT'<88300,CPT'>88372 S MOVE=0 G MOVEQ
49 I CPT'<89060,CPT'>89105 S MOVE=0 G MOVEQ
50 I CPT'<89130,CPT'>89141 S MOVE=0 G MOVEQ
51MOVEQ Q MOVE
Note: See TracBrowser for help on using the repository browser.