IBCF23 ;ALB/ARH - HCFA 1500 19-90 DATA (block 24, procs and charges) ; 12-JUN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;requires IBIFN, IB(0), IB("U"), IB("U1"), returns number of line items in IBFLD(24)
;revenue code array: IBRC("procedure^division^basc flag^bedsection^rev code^charge")=units
;procedure array: IBCP(initial print order)=proc date^procedure^division^basc flag^dx^pos^tos^charge
;procedure array: IBSS("procedure^division^basc flag^dx^pos^tos^charge")=lowest inital print order
;print order array: IBPO(final print order, initial print order)=""
;print array: IBFLD(24,I)=begin date^end date^pos^tos^procedure^dx^charge^units
;
;NOTE (12/1/93): DX IS NO LONGER STORED IN THE 7TH PIESE SO IT IS NO LONGER BEING USED FOR MATCHING THE CPT'S
;THIS MEANS THAT CPT'S MAY BE MATCHED EVEN IF THEY HAVE DIFFERENT ASSOC DX'S
;ALSO NOTICE THAT THE DX IN THE IBFLD ARRAY SHOULD REFER TO THE EXTERNAL REFERENCE NUMBER OF EACH OF THE 4 POSSIBLE ASSOCIATED DX'S
;AND THAT THE DX IN THE OTHER ARRAYS STILL APPLIES TO THE OLD DX, PIECE 7
;
;THIS PROCEDURE NEEDS TO BE UPDATED FOR THE NEW CPT DX'S
;
RVC ; charges array
S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"RC",IBI)) Q:'IBI S IBLN=^(IBI,0) D
. S IBSS="" F IBJ=6,7,0,5,1,2 S IBSS=IBSS_$P(IBLN,U,IBJ)_"^"
. I +IBSS S $P(IBSS,U,1)=$P(IBSS,U,1)_";ICPT("
. S $P(IBSS,U,3)=$S($D(^DGCR(399,"ASC1",+$P(IBLN,U,6),IBIFN,IBI)):1,1:"")
. S IBRC(IBSS)=+$G(IBRC(IBSS))+$P(IBLN,U,3)
;
PRC ; procedure array with charge
S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:'IBI S IBLN=^(IBI,0) D
. S IBPO=$S(+$P(IBLN,U,4):$P(IBLN,U,4),1:IBI+1000),IBSS="",IBPDT=$P(IBLN,U,2)
. F IBJ=1,6,5,0,9,10 S IBSS=IBSS_$P(IBLN,U,IBJ)_"^"
. F IBJ=11:1:14 I $P(IBLN,U,IBJ) S $P(IBSS,U,4)=$P(IBSS,U,4)_$S(IBJ>11:",",1:"")_$G(IBDXI(+$P(IBLN,U,IBJ)))
. ; charges - find charge associated with procedure, if any (match proc,div,basc)
. S IBCHARG="",IBRV=$P(IBSS,U,1,3),IBRV=$O(IBRC(IBRV)) I $P(IBRV,U,1,3)=$P(IBSS,U,1,3),+IBRC(IBRV) D
.. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV)=IBRC(IBRV)-1
. ; charges - find charge associated with procedure, if any (match proc,div)
. I IBCHARG="" S IBRV=$P(IBSS,U,1,2),IBRV=$O(IBRC(IBRV)) I $P(IBRV,U,1,2)=$P(IBSS,U,1,2),+IBRC(IBRV) D
.. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV)=IBRC(IBRV)-1
. S IBSS=IBSS_IBCHARG,IBCP(IBPO)=IBPDT_"^"_IBSS
;
;add charges not associated with a procedure to the first procedure with no charge
S IBPO="" F S IBPO=$O(IBCP(IBPO)) Q:'IBPO I '$P(IBCP(IBPO),U,8) D
. S IBCHARG="",IBRV="^^^" F S IBRV=$O(IBRC(IBRV)) Q:IBRV="" I +IBRC(IBRV) D Q
.. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV)=IBRC(IBRV)-1
. I +IBCHARG S IBCP(IBPO)=IBCP(IBPO)_IBCHARG
;
PO ; print order array w/ charges
;attempt to combine multiple entries of same procedure onto on line item via print order
;if both have print orders defined then they should not be combined onto one line item
;"procedure^division^basc^dx^pos^tos^charge" must all be the same
S IBPO="" F S IBPO=$O(IBCP(IBPO)) Q:'IBPO S IBCP=IBCP(IBPO),IBSS=$P(IBCP,U,2,999) D
. I $D(IBSS(IBSS)) S IBPO1=IBSS(IBSS),IBPO(IBPO1,IBPO)="" Q
. S IBSS(IBSS)=IBPO,IBPO(IBPO,IBPO)=""
;
PRTARR ;print procedure array
S IBREV="",IBPO1="",IBI=0 F S IBPO1=$O(IBPO(IBPO1)) Q:IBPO1="" D I +IBUNIT D B24
. S IBDT1=99999999,IBDT2="",IBUNIT=0,IBCHARG=""
. S IBPO2="" F S IBPO2=$O(IBPO(IBPO1,IBPO2)) Q:IBPO2="" D
.. S IBUNIT=IBUNIT+1,IBSS=IBCP(IBPO2),IBCHARG=$P(IBSS,U,8)
.. S:IBDT1>+IBSS IBDT1=+IBSS S:IBDT2<+IBSS IBDT2=+IBSS
;
;print any charges not associated with a procedure (ie. not enough procedures or procedure not in "CP" level)
S IBRV="" F S IBRV=$O(IBRC(IBRV)) Q:IBRV="" I +IBRC(IBRV) D D B24
. S IBUNIT=+IBRC(IBRV),IBCHARG=$P(IBRV,U,6),IBDT1=+IB("U"),IBDT2=$P(IB("U"),U,2),IBREV=$P(IBRV,U,5)
. S IBSS="^"_$S(+IBRV:$P(IBRV,U,1),1:$P($G(^DGCR(399.1,+$P(IBRV,U,4),0)),U,1))
;
OFFSET ;add offset to print array
I +$P(IB("U1"),U,2) D
. S IBI=IBI+1,$P(IBFLD(24,IBI),U,5)=$P(IB("U1"),U,3),$P(IBFLD(24,IBI),U,7)=-$P(IB("U1"),U,2)
;
S IBFLD(24)=IBI ;count of line items
;
K IBRC,IBCP,IBSS,IBPO,IBPO1,IBPO2,IBLN,IBRV,IBPDT,IBDT1,IBDT2,IBCHARG,IBUNIT,IBREV
Q
;
B24 ; set individual enrties in print array, external format
N IBX S IBI=IBI+1,IBPROC=$P(IBSS,U,2)
S IBFLD(24,IBI)=$$DATE(IBDT1)_"^"_$S(IBDT1=IBDT2:"",1:$$DATE(IBDT2))
S IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_$P($G(^IBE(353.1,+$P(IBSS,U,6),0)),U,1)_"^"_$P($G(^IBE(353.2,+$P(IBSS,U,7),0)),U,1)
I +IBPROC S IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_$P($G(@("^"_$P(IBPROC,";",2)_+IBPROC_",0)")),U,1)
I 'IBPROC S IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_IBPROC,IBFLD(24,IBI_"A")=$P($G(^DGCR(399.2,+IBREV,0)),U,2)
S IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_$P(IBSS,U,5)_"^"_IBCHARG_"^"_IBUNIT
K IBPROC
Q
DATE(X) ;
Q ($E(X,4,5)_" "_$E(X,6,7)_" "_$E(X,2,3))
IBCF23 ;ALB/ARH - HCFA 1500 19-90 DATA (block 24, procs and charges) ; 12-JUN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;requires IBIFN, IB(0), IB("U"), IB("U1"), returns number of line items in IBFLD(24)
+5 ;revenue code array: IBRC("procedure^division^basc flag^bedsection^rev code^charge")=units
+6 ;procedure array: IBCP(initial print order)=proc date^procedure^division^basc flag^dx^pos^tos^charge
+7 ;procedure array: IBSS("procedure^division^basc flag^dx^pos^tos^charge")=lowest inital print order
+8 ;print order array: IBPO(final print order, initial print order)=""
+9 ;print array: IBFLD(24,I)=begin date^end date^pos^tos^procedure^dx^charge^units
+10 ;
+11 ;NOTE (12/1/93): DX IS NO LONGER STORED IN THE 7TH PIESE SO IT IS NO LONGER BEING USED FOR MATCHING THE CPT'S
+12 ;THIS MEANS THAT CPT'S MAY BE MATCHED EVEN IF THEY HAVE DIFFERENT ASSOC DX'S
+13 ;ALSO NOTICE THAT THE DX IN THE IBFLD ARRAY SHOULD REFER TO THE EXTERNAL REFERENCE NUMBER OF EACH OF THE 4 POSSIBLE ASSOCIATED DX'S
+14 ;AND THAT THE DX IN THE OTHER ARRAYS STILL APPLIES TO THE OLD DX, PIECE 7
+15 ;
+16 ;THIS PROCEDURE NEEDS TO BE UPDATED FOR THE NEW CPT DX'S
+17 ;
RVC ; charges array
+1 SET IBI=0
FOR
SET IBI=$ORDER(^DGCR(399,IBIFN,"RC",IBI))
IF 'IBI
QUIT
SET IBLN=^(IBI,0)
Begin DoDot:1
+2 SET IBSS=""
FOR IBJ=6,7,0,5,1,2
SET IBSS=IBSS_$PIECE(IBLN,U,IBJ)_"^"
+3 IF +IBSS
SET $PIECE(IBSS,U,1)=$PIECE(IBSS,U,1)_";ICPT("
+4 SET $PIECE(IBSS,U,3)=$SELECT($DATA(^DGCR(399,"ASC1",+$PIECE(IBLN,U,6),IBIFN,IBI)):1,1:"")
+5 SET IBRC(IBSS)=+$GET(IBRC(IBSS))+$PIECE(IBLN,U,3)
End DoDot:1
+6 ;
PRC ; procedure array with charge
+1 SET IBI=0
FOR
SET IBI=$ORDER(^DGCR(399,IBIFN,"CP",IBI))
IF 'IBI
QUIT
SET IBLN=^(IBI,0)
Begin DoDot:1
+2 SET IBPO=$SELECT(+$PIECE(IBLN,U,4):$PIECE(IBLN,U,4),1:IBI+1000)
SET IBSS=""
SET IBPDT=$PIECE(IBLN,U,2)
+3 FOR IBJ=1,6,5,0,9,10
SET IBSS=IBSS_$PIECE(IBLN,U,IBJ)_"^"
+4 FOR IBJ=11:1:14
IF $PIECE(IBLN,U,IBJ)
SET $PIECE(IBSS,U,4)=$PIECE(IBSS,U,4)_$SELECT(IBJ>11:",",1:"")_$GET(IBDXI(+$PIECE(IBLN,U,IBJ)))
+5 ; charges - find charge associated with procedure, if any (match proc,div,basc)
+6 SET IBCHARG=""
SET IBRV=$PIECE(IBSS,U,1,3)
SET IBRV=$ORDER(IBRC(IBRV))
IF $PIECE(IBRV,U,1,3)=$PIECE(IBSS,U,1,3)
IF +IBRC(IBRV)
Begin DoDot:2
+7 SET IBCHARG=$PIECE(IBRV,U,6)
SET IBRC(IBRV)=IBRC(IBRV)-1
End DoDot:2
+8 ; charges - find charge associated with procedure, if any (match proc,div)
+9 IF IBCHARG=""
SET IBRV=$PIECE(IBSS,U,1,2)
SET IBRV=$ORDER(IBRC(IBRV))
IF $PIECE(IBRV,U,1,2)=$PIECE(IBSS,U,1,2)
IF +IBRC(IBRV)
Begin DoDot:2
+10 SET IBCHARG=$PIECE(IBRV,U,6)
SET IBRC(IBRV)=IBRC(IBRV)-1
End DoDot:2
+11 SET IBSS=IBSS_IBCHARG
SET IBCP(IBPO)=IBPDT_"^"_IBSS
End DoDot:1
+12 ;
+13 ;add charges not associated with a procedure to the first procedure with no charge
+14 SET IBPO=""
FOR
SET IBPO=$ORDER(IBCP(IBPO))
IF 'IBPO
QUIT
IF '$PIECE(IBCP(IBPO),U,8)
Begin DoDot:1
+15 SET IBCHARG=""
SET IBRV="^^^"
FOR
SET IBRV=$ORDER(IBRC(IBRV))
IF IBRV=""
QUIT
IF +IBRC(IBRV)
Begin DoDot:2
+16 SET IBCHARG=$PIECE(IBRV,U,6)
SET IBRC(IBRV)=IBRC(IBRV)-1
End DoDot:2
QUIT
+17 IF +IBCHARG
SET IBCP(IBPO)=IBCP(IBPO)_IBCHARG
End DoDot:1
+18 ;
PO ; print order array w/ charges
+1 ;attempt to combine multiple entries of same procedure onto on line item via print order
+2 ;if both have print orders defined then they should not be combined onto one line item
+3 ;"procedure^division^basc^dx^pos^tos^charge" must all be the same
+4 SET IBPO=""
FOR
SET IBPO=$ORDER(IBCP(IBPO))
IF 'IBPO
QUIT
SET IBCP=IBCP(IBPO)
SET IBSS=$PIECE(IBCP,U,2,999)
Begin DoDot:1
+5 IF $DATA(IBSS(IBSS))
SET IBPO1=IBSS(IBSS)
SET IBPO(IBPO1,IBPO)=""
QUIT
+6 SET IBSS(IBSS)=IBPO
SET IBPO(IBPO,IBPO)=""
End DoDot:1
+7 ;
PRTARR ;print procedure array
+1 SET IBREV=""
SET IBPO1=""
SET IBI=0
FOR
SET IBPO1=$ORDER(IBPO(IBPO1))
IF IBPO1=""
QUIT
Begin DoDot:1
+2 SET IBDT1=99999999
SET IBDT2=""
SET IBUNIT=0
SET IBCHARG=""
+3 SET IBPO2=""
FOR
SET IBPO2=$ORDER(IBPO(IBPO1,IBPO2))
IF IBPO2=""
QUIT
Begin DoDot:2
+4 SET IBUNIT=IBUNIT+1
SET IBSS=IBCP(IBPO2)
SET IBCHARG=$PIECE(IBSS,U,8)
+5 IF IBDT1>+IBSS
SET IBDT1=+IBSS
IF IBDT2<+IBSS
SET IBDT2=+IBSS
End DoDot:2
End DoDot:1
IF +IBUNIT
DO B24
+6 ;
+7 ;print any charges not associated with a procedure (ie. not enough procedures or procedure not in "CP" level)
+8 SET IBRV=""
FOR
SET IBRV=$ORDER(IBRC(IBRV))
IF IBRV=""
QUIT
IF +IBRC(IBRV)
Begin DoDot:1
+9 SET IBUNIT=+IBRC(IBRV)
SET IBCHARG=$PIECE(IBRV,U,6)
SET IBDT1=+IB("U")
SET IBDT2=$PIECE(IB("U"),U,2)
SET IBREV=$PIECE(IBRV,U,5)
+10 SET IBSS="^"_$SELECT(+IBRV:$PIECE(IBRV,U,1),1:$PIECE($GET(^DGCR(399.1,+$PIECE(IBRV,U,4),0)),U,1))
End DoDot:1
DO B24
+11 ;
OFFSET ;add offset to print array
+1 IF +$PIECE(IB("U1"),U,2)
Begin DoDot:1
+2 SET IBI=IBI+1
SET $PIECE(IBFLD(24,IBI),U,5)=$PIECE(IB("U1"),U,3)
SET $PIECE(IBFLD(24,IBI),U,7)=-$PIECE(IB("U1"),U,2)
End DoDot:1
+3 ;
+4 ;count of line items
SET IBFLD(24)=IBI
+5 ;
+6 KILL IBRC,IBCP,IBSS,IBPO,IBPO1,IBPO2,IBLN,IBRV,IBPDT,IBDT1,IBDT2,IBCHARG,IBUNIT,IBREV
+7 QUIT
+8 ;
B24 ; set individual enrties in print array, external format
+1 NEW IBX
SET IBI=IBI+1
SET IBPROC=$PIECE(IBSS,U,2)
+2 SET IBFLD(24,IBI)=$$DATE(IBDT1)_"^"_$SELECT(IBDT1=IBDT2:"",1:$$DATE(IBDT2))
+3 SET IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_$PIECE($GET(^IBE(353.1,+$PIECE(IBSS,U,6),0)),U,1)_"^"_$PIECE($GET(^IBE(353.2,+$PIECE(IBSS,U,7),0)),U,1)
+4 IF +IBPROC
SET IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_$PIECE($GET(@("^"_$PIECE(IBPROC,";",2)_+IBPROC_",0)")),U,1)
+5 IF 'IBPROC
SET IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_IBPROC
SET IBFLD(24,IBI_"A")=$PIECE($GET(^DGCR(399.2,+IBREV,0)),U,2)
+6 SET IBFLD(24,IBI)=IBFLD(24,IBI)_"^"_$PIECE(IBSS,U,5)_"^"_IBCHARG_"^"_IBUNIT
+7 KILL IBPROC
+8 QUIT
DATE(X) ;
+1 QUIT ($EXTRACT(X,4,5)_" "_$EXTRACT(X,6,7)_" "_$EXTRACT(X,2,3))
