IBCRHBRB ;ALB/ARH - RATES: UPLOAD RC V1.4 MOVE LAB CODES ; 06-JAN-2002
;;2.0;INTEGRATED BILLING;**169**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; move selected Lab procedure RC V1.4 charges from Physician file to Outpatient Facility file
; although the charges are calculated as Physician charges they usually should be billed on the UB-92
;
LAB ; move selected RV v1.4 Lab charges from Physician to Facility charge sets
N IBXRF,IBOX2,IBOX3,IBPHYS,IBPX2,IBPX3,IBLINE,IBCNT S IBCNT=0
;
I $G(^XTMP("IBCR RC SITE","VERSION"))'=1.4 Q
;
S IBXRF=$O(^XTMP("IBCR UPLOAD RC ")) I IBXRF'["IBCR UPLOAD RC " Q
;
I '$D(ZTQUEUED) W !!,"Moving Lab charges from Physician to Facility Charge Sets ... "
;
S IBOX2="Opt Fac",IBOX3=$O(^XTMP(IBXRF,IBOX2,999999999999),-1)
;
S IBPHYS="Phys Fee "
S IBPX2=IBPHYS F S IBPX2=$O(^XTMP(IBXRF,IBPX2)) Q:IBPX2'[IBPHYS D
. S IBPX3="" F S IBPX3=$O(^XTMP(IBXRF,IBPX2,IBPX3)) Q:IBPX3="" D
.. S IBLINE=$G(^XTMP(IBXRF,IBPX2,IBPX3)) Q:IBLINE=""
.. I '$$MOVE($P(IBLINE,U,1)) Q
.. ;
.. S IBOX3=IBOX3+1,IBCNT=IBCNT+1
.. S $P(^XTMP(IBXRF,IBOX2),U,1)=$P(^XTMP(IBXRF,IBOX2),U,1)+1
.. S ^XTMP(IBXRF,IBOX2,IBOX3)=IBLINE
.. ;
.. S $P(^XTMP(IBXRF,IBPX2),U,1)=$P(^XTMP(IBXRF,IBPX2),U,1)-1
.. K ^XTMP(IBXRF,IBPX2,IBPX3)
;
I '$D(ZTQUEUED) W IBCNT," charges moved"
Q
;
MOVE(CPT) ; return true if the Lab (8xxxx) code should be moved to the facility charge file
;
N IBCPTX,MOVE S MOVE=0
I $E($G(CPT))=8,CPT?5N S MOVE=1,IBCPTX=","_$G(CPT)_","
I 'MOVE G MOVEQ
;
I ",80500,80502,83020,83912,84165,84181,84182,85060,85097,85390,85576,"[IBCPTX S MOVE=0 G MOVEQ
I ",86077,86078,86079,86255,86256,86320,86325,86327,86334,87164,87207,"[IBCPTX S MOVE=0 G MOVEQ
I ",88141,88291,"[IBCPTX S MOVE=0 G MOVEQ
;
I CPT'<88000,CPT'>88130 S MOVE=0 G MOVEQ
I CPT'<88160,CPT'>88162 S MOVE=0 G MOVEQ
I CPT'<88172,CPT'>88182 S MOVE=0 G MOVEQ
I CPT'<88300,CPT'>88372 S MOVE=0 G MOVEQ
I CPT'<89060,CPT'>89105 S MOVE=0 G MOVEQ
I CPT'<89130,CPT'>89141 S MOVE=0 G MOVEQ
MOVEQ Q MOVE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBRB 2097 printed Apr 09, 2024@21:36:39 Page 2
IBCRHBRB ;ALB/ARH - RATES: UPLOAD RC V1.4 MOVE LAB CODES ; 06-JAN-2002
+1 ;;2.0;INTEGRATED BILLING;**169**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; move selected Lab procedure RC V1.4 charges from Physician file to Outpatient Facility file
+5 ; although the charges are calculated as Physician charges they usually should be billed on the UB-92
+6 ;
LAB ; move selected RV v1.4 Lab charges from Physician to Facility charge sets
+1 NEW IBXRF,IBOX2,IBOX3,IBPHYS,IBPX2,IBPX3,IBLINE,IBCNT
SET IBCNT=0
+2 ;
+3 IF $GET(^XTMP("IBCR RC SITE","VERSION"))'=1.4
QUIT
+4 ;
+5 SET IBXRF=$ORDER(^XTMP("IBCR UPLOAD RC "))
IF IBXRF'["IBCR UPLOAD RC "
QUIT
+6 ;
+7 IF '$DATA(ZTQUEUED)
WRITE !!,"Moving Lab charges from Physician to Facility Charge Sets ... "
+8 ;
+9 SET IBOX2="Opt Fac"
SET IBOX3=$ORDER(^XTMP(IBXRF,IBOX2,999999999999),-1)
+10 ;
+11 SET IBPHYS="Phys Fee "
+12 SET IBPX2=IBPHYS
FOR
SET IBPX2=$ORDER(^XTMP(IBXRF,IBPX2))
if IBPX2'[IBPHYS
QUIT
Begin DoDot:1
+13 SET IBPX3=""
FOR
SET IBPX3=$ORDER(^XTMP(IBXRF,IBPX2,IBPX3))
if IBPX3=""
QUIT
Begin DoDot:2
+14 SET IBLINE=$GET(^XTMP(IBXRF,IBPX2,IBPX3))
if IBLINE=""
QUIT
+15 IF '$$MOVE($PIECE(IBLINE,U,1))
QUIT
+16 ;
+17 SET IBOX3=IBOX3+1
SET IBCNT=IBCNT+1
+18 SET $PIECE(^XTMP(IBXRF,IBOX2),U,1)=$PIECE(^XTMP(IBXRF,IBOX2),U,1)+1
+19 SET ^XTMP(IBXRF,IBOX2,IBOX3)=IBLINE
+20 ;
+21 SET $PIECE(^XTMP(IBXRF,IBPX2),U,1)=$PIECE(^XTMP(IBXRF,IBPX2),U,1)-1
+22 KILL ^XTMP(IBXRF,IBPX2,IBPX3)
End DoDot:2
End DoDot:1
+23 ;
+24 IF '$DATA(ZTQUEUED)
WRITE IBCNT," charges moved"
+25 QUIT
+26 ;
MOVE(CPT) ; return true if the Lab (8xxxx) code should be moved to the facility charge file
+1 ;
+2 NEW IBCPTX,MOVE
SET MOVE=0
+3 IF $EXTRACT($GET(CPT))=8
IF CPT?5N
SET MOVE=1
SET IBCPTX=","_$GET(CPT)_","
+4 IF 'MOVE
GOTO MOVEQ
+5 ;
+6 IF ",80500,80502,83020,83912,84165,84181,84182,85060,85097,85390,85576,"[IBCPTX
SET MOVE=0
GOTO MOVEQ
+7 IF ",86077,86078,86079,86255,86256,86320,86325,86327,86334,87164,87207,"[IBCPTX
SET MOVE=0
GOTO MOVEQ
+8 IF ",88141,88291,"[IBCPTX
SET MOVE=0
GOTO MOVEQ
+9 ;
+10 IF CPT'<88000
IF CPT'>88130
SET MOVE=0
GOTO MOVEQ
+11 IF CPT'<88160
IF CPT'>88162
SET MOVE=0
GOTO MOVEQ
+12 IF CPT'<88172
IF CPT'>88182
SET MOVE=0
GOTO MOVEQ
+13 IF CPT'<88300
IF CPT'>88372
SET MOVE=0
GOTO MOVEQ
+14 IF CPT'<89060
IF CPT'>89105
SET MOVE=0
GOTO MOVEQ
+15 IF CPT'<89130
IF CPT'>89141
SET MOVE=0
GOTO MOVEQ
MOVEQ QUIT MOVE
