IBECEAU5 ;ALB/BGA - Cancel/Edit/Add CALC Observation COPAY ; 17-MAY-2000
;;2.0;INTEGRATED BILLING;**132,153,156,167,247,663**;21-MAR-94;Build 27
;;Per VHA Directive 6402, this routine should not be modified.
;
; Find the IB action type and outpatient copay rate for an inpatient Observation
;
OBS ; Called from EN^IBAMTD when adding an Inpatient Observation Copay
;
; Check to see if you have a clock
I '$G(IBCLDA) S IBCLDT=$P(IBADMDT,".") D CLADD^IBAUTL3 G:IBY<1 END
; Calculate Outpatient COPAY Charge return IBATYP,IBCHG,IBDESC,IBRTED
; setting IBTYPE=2 to designate all observation is specialty care
S (IBDT,IBADMDT)=$P(IBADMDT,"."),IBX="O",IBTYPE=2 D CHRG G:IBY<1 END
; Set the SOFTLINK field = Admission Movment:405
S IBSL="405:"_IBA,IBUNIT=1,(IBFR,IBEVDT)=IBADMDT,IBTO=$P(IBDISDT,"."),IBEVDA="*"
; Add the charge to ^IB set IBN= new charge's IEN
D ADD^IBECEAU3 G:IBY<1 END
; Pass the charge to AR set IBTRAN and IBIL
S IBDUZ=DUZ D IBFLR^IBAMTS1
END K IBFR,IBTO,IBTYPE
Q
;
CHRG ; Called from OPT^IBECEA33 when adding a obs copay from CANCEL/EDIT/ADD
;
; Input: Optional if no IBDT than default to DT
; Output: IBATYP, IBCHG, IBDESC, IBRTED
;
I '$D(IBDT) S IBDT=DT
D TYPE^IBAUTL2 ; Sets IBCHRG=Outpat Copay $ and IBRTED=effective DT of rate
Q:'IBCHG ; Error occurred sets IBY in TYPE^IBAUTL2
S IBBS=$$MCCRUTL^IBCRU1("OBSERVATION CARE",5)
S IBATYP=$P($G(^DGCR(399.1,+IBBS,0)),"^",7) I 'IBATYP S IBY="-1^IB008" Q
I $D(^IBE(350.1,+IBATYP,20)) X ^(20) ; sets IBDESC
Q
;
CLSF(DGMVP) ;
; This Subroutine evaluates an Inpatient Admission for an Observation Speciality
; where the patient has claimed exposure. The Special Inpatient Billing
; case record is evaluated to detemine the status of the disposition
; the results are than displayed on the Outpatient Events Reports
;
N DGIEN,DG0,IBDISP,IBOUT,IBREAS,IBTYP
Q:'DGMVP!('$D(^IBE(351.2,"AC",DGMVP))) ; no special case record on file
S DGIEN=0,DGIEN=$O(^IBE(351.2,"AC",DGMVP,DGIEN)) Q:'DGIEN
S DG0=$G(^IBE(351.2,DGIEN,0)) ; Special Inpatient Billing Case Record
Q:$P(DG0,U,8)&('$P(DG0,U,7)) ; Case disposed care not related to Condition
S IBTYP=$P(DG0,U,3)
S IBTYP=$$UCCL^IBAMTI(IBTYP) S:IBTYP="SPECIAL" IBTYP="SPECIAL CASE"
S IBOUT="* Patient Claims EPISODE OF CARE related to: "_IBTYP
I '$P(DG0,U,8) S IBDISP="** STATUS - Case has not been DISPOSITIONED" D PRINT Q
I $P(DG0,U,8),$P(DG0,U,7) D
. S IBDISP="** Case has been DIPOSITIONED and Care is NOT BILLABLE"
. S IBREAS=$G(^IBE(351.2,DGIEN,1,0))
. D PRINT
Q
;
PRINT ;
I IBLINE>55 D HDR^IBOVOP2 W !,IBFLD1,!?5,IBFLD2
I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR^IBOVOP2 W !,IBFLD1,!?5,IBFLD2
W !!,?5,IBOUT
W:$G(IBDISP)]"" !,?5,IBDISP ; Writes the status of the disposition
I $G(IBREAS)]"" D
. W !,?5,"Reason Not Billable: ",$E(IBREAS,1,55) ; Writes Reason Not Billed
Q
;
FEE ; This Subroutine permits a Clerk to add a DG FEE SERVICE (OPT)
; when the value of the fee for service is less than the normal
; Outpatient Copayment.
;
Q:'$G(IBAFEE)!('$G(IBCHG))
; Reset ibdesc="DG FEE SERVICE (OPT) NEW", ibatyp=57
; before adding entry from ADD^IBECEAU3 to ^IB
S IBATYP=IBAFEE I $D(^IBE(350.1,+IBATYP,20)) X ^(20)
N DIR,X,Y,DIRUT
S DIR(0)="350,.07",DIR("A")="Charge Amount"
S DIR("B")=$S(IBCHG?1N.N1"."1N:IBCHG_0,1:IBCHG)
S DIR("T")=180,DIR("?")=" "
S DIR("?",1)=" *** The Fee for Service can not be LESS than $1.00 or"
S DIR("?",2)=" *** GREATER than $"_$S(IBCHG?1N.N1"."1N:IBCHG_0,1:IBCHG)_"."
D ^DIR I $G(DIRUT) S IBY=-1 Q
I $G(Y)>50.8!($G(Y)<1) D G FEE
. W !,?10,"*** The Fee for Service can not be GREATER than $"_$S(IBCHG?1N.N1"."1N:IBCHG_0,1:IBCHG)
. W !,?10,"*** AND must be GREATER than $.99==> Please try Again"
S:$G(Y) IBCHG=Y
Q
;
IBOVOP(IBDATE) ;
; This Subroutine expands the functions of the Outpatient Events Report
; by adding Inpatient Observation Admissions/Discharges to the the report.
; Find Admissions or Discharges Associated with Inpatient Observation
; Specialities and Load them into ^TMP("IBOVOP",$J) to be printed
; by ^IBOVOP the Outpatient Events Report.
;
Q:'$G(IBDATE)
N DGPM0,DGMVP,IBDATE1,IBDFN,IBI,IBENDDT,IBSPEC
N IBFLD1,IBFLD2,IBFLD3,IBFLD4,IBFLD5,IBSUB3,IBSUB4,IBSUB5,IBSUB6
S IBDATE1=$P(IBDATE,"."),IBI=($P(IBDATE,".")-1)+.99999
S IBENDDT=IBDATE1+.9999
F S IBI=$O(^DGPM("B",IBI)) Q:'IBI!(IBI>IBENDDT) D
. S DGMVP=0 F S DGMVP=$O(^DGPM("B",IBI,DGMVP)) Q:'DGMVP D
. . S DGPM0=$G(^DGPM(DGMVP,0)) Q:$P(DGPM0,U,2)'=1
. . S IBTYP=$P(DGPM0,U,2) ; 1=Admission
. . S IBSPEC=$$MVT^DGPMOBS(DGMVP) Q:+IBSPEC<1 ; quite not OBS
. . S IBDFN=$P(DGPM0,U,3) Q:'IBDFN
. . Q:$$BILST^DGMTUB(IBDFN)<($P(+DGPM0,".")) ; quite not MT billable
. . S IBSUB3=$$FLD1^IBOVOP1(IBDFN) Q:IBSUB3="" ; subscript 3 PT name
. . S IBSUB4="OBS ADMIS"
. . S IBSUB5=$$FLD3^IBOVOP1(+DGPM0) Q:IBSUB5=""
. . S IBSUB6=0
. . S IBFLD1=$E($P(IBSPEC,U,3),U,30) ; Treating Speciality
. . S IBFLD2=""
. . S IBFLD3=$S($P(DGPM0,U,17):"DISCHARGED",1:"ADMISSION")
. . S IBFLD4=IBDFN,IBFLD5="",IBFLD6=DGMVP
. . ; Set the Global for the Outpatient Event Report
. . S ^TMP("IBOVOP",$J,IBSUB3,IBSUB4,IBSUB5,IBSUB6)=IBFLD1_U_IBFLD2_U_IBFLD3_U_IBFLD4_U_IBFLD5_U_IBFLD6
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEAU5 5302 printed Sep 23, 2025@19:57:51 Page 2
IBECEAU5 ;ALB/BGA - Cancel/Edit/Add CALC Observation COPAY ; 17-MAY-2000
+1 ;;2.0;INTEGRATED BILLING;**132,153,156,167,247,663**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Find the IB action type and outpatient copay rate for an inpatient Observation
+5 ;
OBS ; Called from EN^IBAMTD when adding an Inpatient Observation Copay
+1 ;
+2 ; Check to see if you have a clock
+3 IF '$GET(IBCLDA)
SET IBCLDT=$PIECE(IBADMDT,".")
DO CLADD^IBAUTL3
if IBY<1
GOTO END
+4 ; Calculate Outpatient COPAY Charge return IBATYP,IBCHG,IBDESC,IBRTED
+5 ; setting IBTYPE=2 to designate all observation is specialty care
+6 SET (IBDT,IBADMDT)=$PIECE(IBADMDT,".")
SET IBX="O"
SET IBTYPE=2
DO CHRG
if IBY<1
GOTO END
+7 ; Set the SOFTLINK field = Admission Movment:405
+8 SET IBSL="405:"_IBA
SET IBUNIT=1
SET (IBFR,IBEVDT)=IBADMDT
SET IBTO=$PIECE(IBDISDT,".")
SET IBEVDA="*"
+9 ; Add the charge to ^IB set IBN= new charge's IEN
+10 DO ADD^IBECEAU3
if IBY<1
GOTO END
+11 ; Pass the charge to AR set IBTRAN and IBIL
+12 SET IBDUZ=DUZ
DO IBFLR^IBAMTS1
END KILL IBFR,IBTO,IBTYPE
+1 QUIT
+2 ;
CHRG ; Called from OPT^IBECEA33 when adding a obs copay from CANCEL/EDIT/ADD
+1 ;
+2 ; Input: Optional if no IBDT than default to DT
+3 ; Output: IBATYP, IBCHG, IBDESC, IBRTED
+4 ;
+5 IF '$DATA(IBDT)
SET IBDT=DT
+6 ; Sets IBCHRG=Outpat Copay $ and IBRTED=effective DT of rate
DO TYPE^IBAUTL2
+7 ; Error occurred sets IBY in TYPE^IBAUTL2
if 'IBCHG
QUIT
+8 SET IBBS=$$MCCRUTL^IBCRU1("OBSERVATION CARE",5)
+9 SET IBATYP=$PIECE($GET(^DGCR(399.1,+IBBS,0)),"^",7)
IF 'IBATYP
SET IBY="-1^IB008"
QUIT
+10 ; sets IBDESC
IF $DATA(^IBE(350.1,+IBATYP,20))
XECUTE ^(20)
+11 QUIT
+12 ;
CLSF(DGMVP) ;
+1 ; This Subroutine evaluates an Inpatient Admission for an Observation Speciality
+2 ; where the patient has claimed exposure. The Special Inpatient Billing
+3 ; case record is evaluated to detemine the status of the disposition
+4 ; the results are than displayed on the Outpatient Events Reports
+5 ;
+6 NEW DGIEN,DG0,IBDISP,IBOUT,IBREAS,IBTYP
+7 ; no special case record on file
if 'DGMVP!('$DATA(^IBE(351.2,"AC",DGMVP)))
QUIT
+8 SET DGIEN=0
SET DGIEN=$ORDER(^IBE(351.2,"AC",DGMVP,DGIEN))
if 'DGIEN
QUIT
+9 ; Special Inpatient Billing Case Record
SET DG0=$GET(^IBE(351.2,DGIEN,0))
+10 ; Case disposed care not related to Condition
if $PIECE(DG0,U,8)&('$PIECE(DG0,U,7))
QUIT
+11 SET IBTYP=$PIECE(DG0,U,3)
+12 SET IBTYP=$$UCCL^IBAMTI(IBTYP)
if IBTYP="SPECIAL"
SET IBTYP="SPECIAL CASE"
+13 SET IBOUT="* Patient Claims EPISODE OF CARE related to: "_IBTYP
+14 IF '$PIECE(DG0,U,8)
SET IBDISP="** STATUS - Case has not been DISPOSITIONED"
DO PRINT
QUIT
+15 IF $PIECE(DG0,U,8)
IF $PIECE(DG0,U,7)
Begin DoDot:1
+16 SET IBDISP="** Case has been DIPOSITIONED and Care is NOT BILLABLE"
+17 SET IBREAS=$GET(^IBE(351.2,DGIEN,1,0))
+18 DO PRINT
End DoDot:1
+19 QUIT
+20 ;
PRINT ;
+1 IF IBLINE>55
DO HDR^IBOVOP2
WRITE !,IBFLD1,!?5,IBFLD2
+2 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR^IBOVOP2
WRITE !,IBFLD1,!?5,IBFLD2
+3 WRITE !!,?5,IBOUT
+4 ; Writes the status of the disposition
if $GET(IBDISP)]""
WRITE !,?5,IBDISP
+5 IF $GET(IBREAS)]""
Begin DoDot:1
+6 ; Writes Reason Not Billed
WRITE !,?5,"Reason Not Billable: ",$EXTRACT(IBREAS,1,55)
End DoDot:1
+7 QUIT
+8 ;
FEE ; This Subroutine permits a Clerk to add a DG FEE SERVICE (OPT)
+1 ; when the value of the fee for service is less than the normal
+2 ; Outpatient Copayment.
+3 ;
+4 if '$GET(IBAFEE)!('$GET(IBCHG))
QUIT
+5 ; Reset ibdesc="DG FEE SERVICE (OPT) NEW", ibatyp=57
+6 ; before adding entry from ADD^IBECEAU3 to ^IB
+7 SET IBATYP=IBAFEE
IF $DATA(^IBE(350.1,+IBATYP,20))
XECUTE ^(20)
+8 NEW DIR,X,Y,DIRUT
+9 SET DIR(0)="350,.07"
SET DIR("A")="Charge Amount"
+10 SET DIR("B")=$SELECT(IBCHG?1N.N1"."1N:IBCHG_0,1:IBCHG)
+11 SET DIR("T")=180
SET DIR("?")=" "
+12 SET DIR("?",1)=" *** The Fee for Service can not be LESS than $1.00 or"
+13 SET DIR("?",2)=" *** GREATER than $"_$SELECT(IBCHG?1N.N1"."1N:IBCHG_0,1:IBCHG)_"."
+14 DO ^DIR
IF $GET(DIRUT)
SET IBY=-1
QUIT
+15 IF $GET(Y)>50.8!($GET(Y)<1)
Begin DoDot:1
+16 WRITE !,?10,"*** The Fee for Service can not be GREATER than $"_$SELECT(IBCHG?1N.N1"."1N:IBCHG_0,1:IBCHG)
+17 WRITE !,?10,"*** AND must be GREATER than $.99==> Please try Again"
End DoDot:1
GOTO FEE
+18 if $GET(Y)
SET IBCHG=Y
+19 QUIT
+20 ;
IBOVOP(IBDATE) ;
+1 ; This Subroutine expands the functions of the Outpatient Events Report
+2 ; by adding Inpatient Observation Admissions/Discharges to the the report.
+3 ; Find Admissions or Discharges Associated with Inpatient Observation
+4 ; Specialities and Load them into ^TMP("IBOVOP",$J) to be printed
+5 ; by ^IBOVOP the Outpatient Events Report.
+6 ;
+7 if '$GET(IBDATE)
QUIT
+8 NEW DGPM0,DGMVP,IBDATE1,IBDFN,IBI,IBENDDT,IBSPEC
+9 NEW IBFLD1,IBFLD2,IBFLD3,IBFLD4,IBFLD5,IBSUB3,IBSUB4,IBSUB5,IBSUB6
+10 SET IBDATE1=$PIECE(IBDATE,".")
SET IBI=($PIECE(IBDATE,".")-1)+.99999
+11 SET IBENDDT=IBDATE1+.9999
+12 FOR
SET IBI=$ORDER(^DGPM("B",IBI))
if 'IBI!(IBI>IBENDDT)
QUIT
Begin DoDot:1
+13 SET DGMVP=0
FOR
SET DGMVP=$ORDER(^DGPM("B",IBI,DGMVP))
if 'DGMVP
QUIT
Begin DoDot:2
+14 SET DGPM0=$GET(^DGPM(DGMVP,0))
if $PIECE(DGPM0,U,2)'=1
QUIT
+15 ; 1=Admission
SET IBTYP=$PIECE(DGPM0,U,2)
+16 ; quite not OBS
SET IBSPEC=$$MVT^DGPMOBS(DGMVP)
if +IBSPEC<1
QUIT
+17 SET IBDFN=$PIECE(DGPM0,U,3)
if 'IBDFN
QUIT
+18 ; quite not MT billable
if $$BILST^DGMTUB(IBDFN)<($PIECE(+DGPM0,"."))
QUIT
+19 ; subscript 3 PT name
SET IBSUB3=$$FLD1^IBOVOP1(IBDFN)
if IBSUB3=""
QUIT
+20 SET IBSUB4="OBS ADMIS"
+21 SET IBSUB5=$$FLD3^IBOVOP1(+DGPM0)
if IBSUB5=""
QUIT
+22 SET IBSUB6=0
+23 ; Treating Speciality
SET IBFLD1=$EXTRACT($PIECE(IBSPEC,U,3),U,30)
+24 SET IBFLD2=""
+25 SET IBFLD3=$SELECT($PIECE(DGPM0,U,17):"DISCHARGED",1:"ADMISSION")
+26 SET IBFLD4=IBDFN
SET IBFLD5=""
SET IBFLD6=DGMVP
+27 ; Set the Global for the Outpatient Event Report
+28 SET ^TMP("IBOVOP",$JOB,IBSUB3,IBSUB4,IBSUB5,IBSUB6)=IBFLD1_U_IBFLD2_U_IBFLD3_U_IBFLD4_U_IBFLD5_U_IBFLD6
End DoDot:2
End DoDot:1
+29 QUIT
