- 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
