IBCF33 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;IBIFN,IBCBILL,IBSTATE required
;find statements to print on bill
S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBCOMM=$G(^DGCR(399,IBIFN,"U1")),IBCBILL=$G(^DGCR(399,IBIFN,0)),IBINPAT=$S($P(IBCBILL,U,5)<3:1,1:0),IBCOL=1
D ^IBCF34
;
I +IBINPAT S IBX=$P(IBSTATE,U,15),IBZ=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE",IBCOL=0 D SET2 S IBZ="" D SET2
;
RV ;rev codes sorted by bedsection
S IBBSN=0,IBBS=0 F S IBBS=$O(^DGCR(399,IBIFN,"RC","ABS",IBBS)) Q:'IBBS D
. S IBRV=0 F S IBRV=$O(^DGCR(399,IBIFN,"RC","ABS",IBBS,IBRV)) Q:'IBRV D
.. S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"RC","ABS",IBBS,IBRV,IBDA)) Q:'IBDA D
... S IBX=$G(^DGCR(399,IBIFN,"RC",IBDA,0))
... S IBZ=$P($G(^DGCR(399.1,+$P(IBX,U,5),0)),U,1) D:IBZ'=IBBSN SET2 S IBBSN=IBZ,IBZ=IBX D SET1
;
;loop through all rev codes, print those with no bedsection
S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I +IBZ,$P(IBZ,U,5)="" D SET1
;
TOTAL ;add totals (print subtotal only if there is an offset)
I +$P(IBCBCOMM,U,2) S IBZ="",$P(IBZ,U,2)="SUBTOTAL",$P(IBZ,U,4)=+$P(IBCBCOMM,U,1) D SET1
;
S IBX=$S(+$P(IBCBCOMM,U,2):4,1:2) D SPACE
S IBZ="" D SET2
I +$P(IBCBCOMM,U,2) S IBZ="",$P(IBZ,U,2)="LESS "_$P(IBCBCOMM,U,3),$P(IBZ,U,4)=+$P(IBCBCOMM,U,2) D SET1 S IBZ="" D SET2
;
S IBZ="001",$P(IBZ,U,2)="TOTAL",$P(IBZ,U,4)=+($P(IBCBCOMM,U,1)-$P(IBCBCOMM,U,2)) D SET1
;
;
CPT ;add addtional procedures
G:$G(IBFL(80))'>6 OPV S IBX=+IBFL(80)-4 D SPACE
S IBZ="" D SET2
S IBZ="ADDITIONAL PROCEDURE CODES:" D SET2
S IBI=6 F S IBI=$O(IBFL(80,IBI)) Q:'IBI D
. S IBX=$P(IBFL(80,IBI),U,2),IBZ=$E(IBX,1,2)_"/"_$E(IBX,3,4)_"/"_$E(IBX,5,6)_$J(" ",5)_$P(IBFL(80,IBI),U,1) D SET2
;
OPV ;add outpatient visit dates
G:'$O(^DGCR(399,IBIFN,"OP",0)) CONT S (IBX,IBY)=0 F S IBX=$O(^DGCR(399,IBIFN,"OP",IBX)) Q:'IBX S IBY=IBY+1
S IBX=IBY/3,IBX=IBX\1+$S(+$P(IBX,".",2):1,1:0)+1 D SPACE
S IBZ="" D SET2 S IBZ="OP VISIT DATE(S) BILLED:"_$J(" ",34-24)
S (IBI,IBJ)=0 F S IBI=$O(^DGCR(399,IBIFN,"OP",IBI)) Q:'IBI D
. S Y=$G(^DGCR(399,IBIFN,"OP",IBI,0)) X ^DD("DD") S IBZ=IBZ_Y_$S($O(^DGCR(399,IBIFN,"OP",IBI)):", ",1:"")
. S IBJ=IBJ+1 I IBJ>2 D SET2 S IBZ=$J(" ",34),IBJ=0
I $L(IBZ)>34 D SET2
;
CONT D ^IBCF331
;
; fill in rest of page
END D FILLPG S $P(^TMP($J,"IBC-RC"),U,2)=0 S IBPG=+$G(^TMP($J,"IBC-RC")),IBX=IBPG/23,IBPG=IBX\1+$S(+$P(IBX,".",2):1,1:0)
K IBZ,IBBSN,IBBS,IBRV,IBDA,IBLN,IBCOL,IBLINES,IBARRAY
Q
;
SPACE ;checks to see if X can fit on page, if not starts new page
Q:'IBX N IBLN,IBY S IBLN=+$G(^TMP($J,"IBC-RC")),IBY=IBLN#23 S:IBY=0&(IBLN'=0) IBY=23 I IBX>(IBLINES-IBY) D FILLPG
Q
;
FILLPG ;fill reast of page with blank lines
N IBI,IBLN,IBZ S IBFILL=1 F IBI=1:1:23 S IBLN=+$G(^TMP($J,"IBC-RC")) Q:'(IBLN#23) S IBZ="" D SET2 Q:IBFILL=2
K IBFILL Q
;
SET1 ; add rev codes to array: rev cd ^ rev cd st abbrev. ^ CPT CODE ^ unit charge ^ units ^ total
;formats for output into specific column blocks 42-48
N IBX,IBY,IBLN D NEXTLN S IBY=""
;set up rev cd item with approprite output values, non-rev cd entries should already be in external form
I +IBZ S IBX=$G(^DGCR(399.2,+IBZ,0)) Q:IBX="" S IBY=$P(IBX,U,1)_U_$P(IBX,U,2)_U_$P($G(^ICPT(+$P(IBZ,U,6),0)),U,1)_U_$P(IBZ,U,2)_U_$P(IBZ,U,3)_U_$P(IBZ,U,4)
I IBY="" S IBY=$P(IBZ,U,1)_U_$P(IBZ,U,2)_U_U_U_$P(IBZ,U,3)_U_$P(IBZ,U,4)
S IBLN=+$G(^TMP($J,"IBC-RC"))+1,^TMP($J,"IBC-RC",IBLN)=1_U_IBY,^TMP($J,"IBC-RC")=IBLN I '(IBLN#23) S IBLINES=23
Q
;
SET2 ;set free text into block 42 array
N IBLN D NEXTLN S IBCOL=$S('IBCOL:2,1:3)
S IBLN=+$G(^TMP($J,"IBC-RC"))+1 I IBLN#23=1,$G(IBFILL) S IBFILL=2 Q
S ^TMP($J,"IBC-RC",IBLN)=IBCOL_U_IBZ,^TMP($J,"IBC-RC")=IBLN I '(IBLN#23) S IBLINES=23
Q
;
NEXTLN ;checks counter for next line, resets if necessary,
;ie. if the line # indicated by the next line # var. has already been used then this increments the next line # var.
S IBLN=+$G(^TMP($J,"IBC-RC"))+1 I $D(^TMP($J,"IBC-RC",IBLN)) S ^TMP($J,"IBC-RC")=IBLN S:'(IBLN#23) IBLINES=23 G NEXTLN
Q
IBCF33 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;IBIFN,IBCBILL,IBSTATE required
+5 ;find statements to print on bill
+6 SET IBSTATE=$GET(^DGCR(399,IBIFN,"U"))
SET IBCBCOMM=$GET(^DGCR(399,IBIFN,"U1"))
SET IBCBILL=$GET(^DGCR(399,IBIFN,0))
SET IBINPAT=$SELECT($PIECE(IBCBILL,U,5)<3:1,1:0)
SET IBCOL=1
+7 DO ^IBCF34
+8 ;
+9 IF +IBINPAT
SET IBX=$PIECE(IBSTATE,U,15)
SET IBZ=+IBX_" DAY"_$SELECT(IBX'=1:"S",1:"")_" INPATIENT CARE"
SET IBCOL=0
DO SET2
SET IBZ=""
DO SET2
+10 ;
RV ;rev codes sorted by bedsection
+1 SET IBBSN=0
SET IBBS=0
FOR
SET IBBS=$ORDER(^DGCR(399,IBIFN,"RC","ABS",IBBS))
IF 'IBBS
QUIT
Begin DoDot:1
+2 SET IBRV=0
FOR
SET IBRV=$ORDER(^DGCR(399,IBIFN,"RC","ABS",IBBS,IBRV))
IF 'IBRV
QUIT
Begin DoDot:2
+3 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399,IBIFN,"RC","ABS",IBBS,IBRV,IBDA))
IF 'IBDA
QUIT
Begin DoDot:3
+4 SET IBX=$GET(^DGCR(399,IBIFN,"RC",IBDA,0))
+5 SET IBZ=$PIECE($GET(^DGCR(399.1,+$PIECE(IBX,U,5),0)),U,1)
IF IBZ'=IBBSN
DO SET2
SET IBBSN=IBZ
SET IBZ=IBX
DO SET1
End DoDot:3
End DoDot:2
End DoDot:1
+6 ;
+7 ;loop through all rev codes, print those with no bedsection
+8 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399,IBIFN,"RC",IBDA))
IF 'IBDA
QUIT
SET IBZ=$GET(^(IBDA,0))
IF +IBZ
IF $PIECE(IBZ,U,5)=""
DO SET1
+9 ;
TOTAL ;add totals (print subtotal only if there is an offset)
+1 IF +$PIECE(IBCBCOMM,U,2)
SET IBZ=""
SET $PIECE(IBZ,U,2)="SUBTOTAL"
SET $PIECE(IBZ,U,4)=+$PIECE(IBCBCOMM,U,1)
DO SET1
+2 ;
+3 SET IBX=$SELECT(+$PIECE(IBCBCOMM,U,2):4,1:2)
DO SPACE
+4 SET IBZ=""
DO SET2
+5 IF +$PIECE(IBCBCOMM,U,2)
SET IBZ=""
SET $PIECE(IBZ,U,2)="LESS "_$PIECE(IBCBCOMM,U,3)
SET $PIECE(IBZ,U,4)=+$PIECE(IBCBCOMM,U,2)
DO SET1
SET IBZ=""
DO SET2
+6 ;
+7 SET IBZ="001"
SET $PIECE(IBZ,U,2)="TOTAL"
SET $PIECE(IBZ,U,4)=+($PIECE(IBCBCOMM,U,1)-$PIECE(IBCBCOMM,U,2))
DO SET1
+8 ;
+9 ;
CPT ;add addtional procedures
+1 IF $GET(IBFL(80))'>6
GOTO OPV
SET IBX=+IBFL(80)-4
DO SPACE
+2 SET IBZ=""
DO SET2
+3 SET IBZ="ADDITIONAL PROCEDURE CODES:"
DO SET2
+4 SET IBI=6
FOR
SET IBI=$ORDER(IBFL(80,IBI))
IF 'IBI
QUIT
Begin DoDot:1
+5 SET IBX=$PIECE(IBFL(80,IBI),U,2)
SET IBZ=$EXTRACT(IBX,1,2)_"/"_$EXTRACT(IBX,3,4)_"/"_$EXTRACT(IBX,5,6)_$JUSTIFY(" ",5)_$PIECE(IBFL(80,IBI),U,1)
DO SET2
End DoDot:1
+6 ;
OPV ;add outpatient visit dates
+1 IF '$ORDER(^DGCR(399,IBIFN,"OP",0))
GOTO CONT
SET (IBX,IBY)=0
FOR
SET IBX=$ORDER(^DGCR(399,IBIFN,"OP",IBX))
IF 'IBX
QUIT
SET IBY=IBY+1
+2 SET IBX=IBY/3
SET IBX=IBX\1+$SELECT(+$PIECE(IBX,".",2):1,1:0)+1
DO SPACE
+3 SET IBZ=""
DO SET2
SET IBZ="OP VISIT DATE(S) BILLED:"_$JUSTIFY(" ",34-24)
+4 SET (IBI,IBJ)=0
FOR
SET IBI=$ORDER(^DGCR(399,IBIFN,"OP",IBI))
IF 'IBI
QUIT
Begin DoDot:1
+5 SET Y=$GET(^DGCR(399,IBIFN,"OP",IBI,0))
XECUTE ^DD("DD")
SET IBZ=IBZ_Y_$SELECT($ORDER(^DGCR(399,IBIFN,"OP",IBI)):", ",1:"")
+6 SET IBJ=IBJ+1
IF IBJ>2
DO SET2
SET IBZ=$JUSTIFY(" ",34)
SET IBJ=0
End DoDot:1
+7 IF $LENGTH(IBZ)>34
DO SET2
+8 ;
CONT DO ^IBCF331
+1 ;
+2 ; fill in rest of page
END DO FILLPG
SET $PIECE(^TMP($JOB,"IBC-RC"),U,2)=0
SET IBPG=+$GET(^TMP($JOB,"IBC-RC"))
SET IBX=IBPG/23
SET IBPG=IBX\1+$SELECT(+$PIECE(IBX,".",2):1,1:0)
+1 KILL IBZ,IBBSN,IBBS,IBRV,IBDA,IBLN,IBCOL,IBLINES,IBARRAY
+2 QUIT
+3 ;
SPACE ;checks to see if X can fit on page, if not starts new page
+1 IF 'IBX
QUIT
NEW IBLN,IBY
SET IBLN=+$GET(^TMP($JOB,"IBC-RC"))
SET IBY=IBLN#23
IF IBY=0&(IBLN'=0)
SET IBY=23
IF IBX>(IBLINES-IBY)
DO FILLPG
+2 QUIT
+3 ;
FILLPG ;fill reast of page with blank lines
+1 NEW IBI,IBLN,IBZ
SET IBFILL=1
FOR IBI=1:1:23
SET IBLN=+$GET(^TMP($JOB,"IBC-RC"))
IF '(IBLN#23)
QUIT
SET IBZ=""
DO SET2
IF IBFILL=2
QUIT
+2 KILL IBFILL
QUIT
+3 ;
SET1 ; add rev codes to array: rev cd ^ rev cd st abbrev. ^ CPT CODE ^ unit charge ^ units ^ total
+1 ;formats for output into specific column blocks 42-48
+2 NEW IBX,IBY,IBLN
DO NEXTLN
SET IBY=""
+3 ;set up rev cd item with approprite output values, non-rev cd entries should already be in external form
+4 IF +IBZ
SET IBX=$GET(^DGCR(399.2,+IBZ,0))
IF IBX=""
QUIT
SET IBY=$PIECE(IBX,U,1)_U_$PIECE(IBX,U,2)_U_$PIECE($GET(^ICPT(+$PIECE(IBZ,U,6),0)),U,1)_U_$PIECE(IBZ,U,2)_U_$PIECE(IBZ,U,3)_U_$PIECE(IBZ,U,4)
+5 IF IBY=""
SET IBY=$PIECE(IBZ,U,1)_U_$PIECE(IBZ,U,2)_U_U_U_$PIECE(IBZ,U,3)_U_$PIECE(IBZ,U,4)
+6 SET IBLN=+$GET(^TMP($JOB,"IBC-RC"))+1
SET ^TMP($JOB,"IBC-RC",IBLN)=1_U_IBY
SET ^TMP($JOB,"IBC-RC")=IBLN
IF '(IBLN#23)
SET IBLINES=23
+7 QUIT
+8 ;
SET2 ;set free text into block 42 array
+1 NEW IBLN
DO NEXTLN
SET IBCOL=$SELECT('IBCOL:2,1:3)
+2 SET IBLN=+$GET(^TMP($JOB,"IBC-RC"))+1
IF IBLN#23=1
IF $GET(IBFILL)
SET IBFILL=2
QUIT
+3 SET ^TMP($JOB,"IBC-RC",IBLN)=IBCOL_U_IBZ
SET ^TMP($JOB,"IBC-RC")=IBLN
IF '(IBLN#23)
SET IBLINES=23
+4 QUIT
+5 ;
NEXTLN ;checks counter for next line, resets if necessary,
+1 ;ie. if the line # indicated by the next line # var. has already been used then this increments the next line # var.
+2 SET IBLN=+$GET(^TMP($JOB,"IBC-RC"))+1
IF $DATA(^TMP($JOB,"IBC-RC",IBLN))
SET ^TMP($JOB,"IBC-RC")=IBLN
IF '(IBLN#23)
SET IBLINES=23
GOTO NEXTLN
+3 QUIT
