IBAUTL2 ;ALB/CPM-MEANS TEST BILLING UTILITIES ;30-AUG-91
;;2.0;INTEGRATED BILLING;**52,153,167,187,183**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CHFIND ; Find open charge for a billable event
; Input: IBEVDA, IBX (C=copay/P=per diem)
; Output: IBCH*DA=0/ien of charge also IBCH* if IBCH*DA>0
N J,X S J=0
F S J=$O(^IB("ACT",IBEVDA,J)) Q:'J S X=$G(^IB(J,0)) I X]"",(($P(X,"^",8)["CO-PAY"&(IBX="C"))!($P(X,"^",8)["PER DIEM"&(IBX="P"))) Q:$P(X,"^",5)=1
S:J IBCHTOTL=$P(X,"^",7),IBCHFR=$P(X,"^",14),IBCHTO=$P(X,"^",15)
S @("IBCH"_IBX_"DA")=+J Q
;
CHADD ; Add a new IB Action in #350
D ADD^IBAUTL I Y<1 S IBY=Y G CHADDQ
S $P(^IB(IBN,0),"^",2,16)=DFN_"^"_IBATYP_"^"_IBSL_"^1^1^"_IBCHG_"^"_IBDESC_"^"_IBN_"^^^^"_IBFAC_"^"_IBDT_"^"_IBDT_"^"_IBEVDA
I $G(IBGMTR) S $P(^IB(IBN,0),"^",21)=1 ; GMT RELATED field #.21
D NOW^%DTC S $P(^IB(IBN,1),"^")=DUZ,$P(^(1),"^",3,4)=DUZ_"^"_%
S DIK="^IB(",DA=IBN D IX1^DIK K DIK,DA
;I $G(IBJOB)=1 S ^TMP($J,"IBAMTC","I",DFN,IBN)=""
CHADDQ Q
;
CHUPD ; Update an IB Action charge
; Input: IBCHTOTL, IBCHFR, IBDT, IBX(P/C), IBN, IBCHG, DUZ, IBGMTR(opt)
N TOT,UNIT S UNIT=1
I IBX="P" S X1=IBDT,X2=IBCHFR D ^%DTC S UNIT=X+1,TOT=UNIT*IBCHG
I IBX="C" S TOT=IBCHTOTL+IBCHG
D NOW^%DTC S $P(^IB(IBN,0),"^",6,7)=UNIT_"^"_TOT,$P(^(0),"^",15)=IBDT,$P(^(1),"^",3,4)=DUZ_"^"_%
I $G(IBGMTR) S $P(^IB(IBN,0),"^",21)=1 ; GMT RELATED field #.21
S DIK="^IB(",DA=IBN D IX1^DIK K DIK,DA
;I $G(IBJOB)=1 S ^TMP($J,"IBAMTC","I",+$G(DFN),IBN)=""
Q
;
SERV ; Find the service pointer for MAS.
S IBSERV=$P($G(^IBE(350.9,1,1)),"^",14) I '$D(^DIC(49,+IBSERV,0)) S IBY="-1^IB003"
Q
;
TYPE ; Find the IB action type and rate for per diem and OPT co-payment charges.
; Input: IBDT, IBBS (if IBX=P), IBX (O=opt copay/P=per diem)
; IBTYPE (only if outpatient, specify Basic or Specialty)
; Output: IBATYP, IBCHG, IBDESC, IBRTED
N J,IBOLDBS S IBCHG=0,IBDESC=""
I IBX="O" D
.S IBBS=$$ITPTR^IBCRU2(9,$S(IBTYPE=2:"SPECIALTY CARE",1:"BASIC CARE"))
.S IBCS=$$CSN^IBCRU3("TL-MT OPT COPAY")
.S IBOLDBS=$$MCCRUTL^IBCRU1("OUTPATIENT VISIT",5)
.D COPAY
;
I IBX="P" S IBATYP=+$P($G(^DGCR(399.1,IBBS,0)),"^",8) I IBATYP D COST X:$D(^IBE(350.1,IBATYP,20)) ^(20)
I 'IBATYP S IBY="-1^IB008" G TYPEQ
I 'IBCHG S IBY="-1^IB029"
TYPEQ Q
;
COST ; - find per diem charge. Input: IBATYP, IBDT Output: IBCHG
N X S X=$O(^IBE(350.2,"AIVDT",IBATYP,-(IBDT+.1))),X=$O(^(+X,0)) I $D(^IBE(350.2,+X,0)) S X=$P(^(0),"^",4)
S IBCHG=+X Q
;
COPAY ; Find the Inpatient/NHCU daily copay rate and IB action type
; Input: IBBS, IBDT, IBCS (for the opt copay only)
; Output: IBATYP, IBCHG, IBDESC, IBRTED
;
S (IBATYP,IBCHG)=0,IBDESC=""
S IBATYP=$P($G(^DGCR(399.1,$S($D(IBOLDBS):IBOLDBS,1:IBBS),0)),"^",7) I 'IBATYP S IBY="-1^IB008" G COPAYQ
I $D(^IBE(350.1,+IBATYP,20)) X ^(20)
;
; - charge set is not defined as input for inpatient rates
I '$G(IBCS) S IBCS=$$CSN^IBCRU3("TL-INPT (INCLUSIVE)")
S IBCHG=$$ITCHG^IBCRCI(IBCS,IBBS,IBDT)
S IBRTED=$P(IBCHG,"^",2),IBCHG=+IBCHG
;
I 'IBCHG S IBY="-1^IB030"
COPAYQ K IBCS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL2 3170 printed Dec 13, 2024@02:08:05 Page 2
IBAUTL2 ;ALB/CPM-MEANS TEST BILLING UTILITIES ;30-AUG-91
+1 ;;2.0;INTEGRATED BILLING;**52,153,167,187,183**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CHFIND ; Find open charge for a billable event
+1 ; Input: IBEVDA, IBX (C=copay/P=per diem)
+2 ; Output: IBCH*DA=0/ien of charge also IBCH* if IBCH*DA>0
+3 NEW J,X
SET J=0
+4 FOR
SET J=$ORDER(^IB("ACT",IBEVDA,J))
if 'J
QUIT
SET X=$GET(^IB(J,0))
IF X]""
IF (($PIECE(X,"^",8)["CO-PAY"&(IBX="C"))!($PIECE(X,"^",8)["PER DIEM"&(IBX="P")))
if $PIECE(X,"^",5)=1
QUIT
+5 if J
SET IBCHTOTL=$PIECE(X,"^",7)
SET IBCHFR=$PIECE(X,"^",14)
SET IBCHTO=$PIECE(X,"^",15)
+6 SET @("IBCH"_IBX_"DA")=+J
QUIT
+7 ;
CHADD ; Add a new IB Action in #350
+1 DO ADD^IBAUTL
IF Y<1
SET IBY=Y
GOTO CHADDQ
+2 SET $PIECE(^IB(IBN,0),"^",2,16)=DFN_"^"_IBATYP_"^"_IBSL_"^1^1^"_IBCHG_"^"_IBDESC_"^"_IBN_"^^^^"_IBFAC_"^"_IBDT_"^"_IBDT_"^"_IBEVDA
+3 ; GMT RELATED field #.21
IF $GET(IBGMTR)
SET $PIECE(^IB(IBN,0),"^",21)=1
+4 DO NOW^%DTC
SET $PIECE(^IB(IBN,1),"^")=DUZ
SET $PIECE(^(1),"^",3,4)=DUZ_"^"_%
+5 SET DIK="^IB("
SET DA=IBN
DO IX1^DIK
KILL DIK,DA
+6 ;I $G(IBJOB)=1 S ^TMP($J,"IBAMTC","I",DFN,IBN)=""
CHADDQ QUIT
+1 ;
CHUPD ; Update an IB Action charge
+1 ; Input: IBCHTOTL, IBCHFR, IBDT, IBX(P/C), IBN, IBCHG, DUZ, IBGMTR(opt)
+2 NEW TOT,UNIT
SET UNIT=1
+3 IF IBX="P"
SET X1=IBDT
SET X2=IBCHFR
DO ^%DTC
SET UNIT=X+1
SET TOT=UNIT*IBCHG
+4 IF IBX="C"
SET TOT=IBCHTOTL+IBCHG
+5 DO NOW^%DTC
SET $PIECE(^IB(IBN,0),"^",6,7)=UNIT_"^"_TOT
SET $PIECE(^(0),"^",15)=IBDT
SET $PIECE(^(1),"^",3,4)=DUZ_"^"_%
+6 ; GMT RELATED field #.21
IF $GET(IBGMTR)
SET $PIECE(^IB(IBN,0),"^",21)=1
+7 SET DIK="^IB("
SET DA=IBN
DO IX1^DIK
KILL DIK,DA
+8 ;I $G(IBJOB)=1 S ^TMP($J,"IBAMTC","I",+$G(DFN),IBN)=""
+9 QUIT
+10 ;
SERV ; Find the service pointer for MAS.
+1 SET IBSERV=$PIECE($GET(^IBE(350.9,1,1)),"^",14)
IF '$DATA(^DIC(49,+IBSERV,0))
SET IBY="-1^IB003"
+2 QUIT
+3 ;
TYPE ; Find the IB action type and rate for per diem and OPT co-payment charges.
+1 ; Input: IBDT, IBBS (if IBX=P), IBX (O=opt copay/P=per diem)
+2 ; IBTYPE (only if outpatient, specify Basic or Specialty)
+3 ; Output: IBATYP, IBCHG, IBDESC, IBRTED
+4 NEW J,IBOLDBS
SET IBCHG=0
SET IBDESC=""
+5 IF IBX="O"
Begin DoDot:1
+6 SET IBBS=$$ITPTR^IBCRU2(9,$SELECT(IBTYPE=2:"SPECIALTY CARE",1:"BASIC CARE"))
+7 SET IBCS=$$CSN^IBCRU3("TL-MT OPT COPAY")
+8 SET IBOLDBS=$$MCCRUTL^IBCRU1("OUTPATIENT VISIT",5)
+9 DO COPAY
End DoDot:1
+10 ;
+11 IF IBX="P"
SET IBATYP=+$PIECE($GET(^DGCR(399.1,IBBS,0)),"^",8)
IF IBATYP
DO COST
if $DATA(^IBE(350.1,IBATYP,20))
XECUTE ^(20)
+12 IF 'IBATYP
SET IBY="-1^IB008"
GOTO TYPEQ
+13 IF 'IBCHG
SET IBY="-1^IB029"
TYPEQ QUIT
+1 ;
COST ; - find per diem charge. Input: IBATYP, IBDT Output: IBCHG
+1 NEW X
SET X=$ORDER(^IBE(350.2,"AIVDT",IBATYP,-(IBDT+.1)))
SET X=$ORDER(^(+X,0))
IF $DATA(^IBE(350.2,+X,0))
SET X=$PIECE(^(0),"^",4)
+2 SET IBCHG=+X
QUIT
+3 ;
COPAY ; Find the Inpatient/NHCU daily copay rate and IB action type
+1 ; Input: IBBS, IBDT, IBCS (for the opt copay only)
+2 ; Output: IBATYP, IBCHG, IBDESC, IBRTED
+3 ;
+4 SET (IBATYP,IBCHG)=0
SET IBDESC=""
+5 SET IBATYP=$PIECE($GET(^DGCR(399.1,$SELECT($DATA(IBOLDBS):IBOLDBS,1:IBBS),0)),"^",7)
IF 'IBATYP
SET IBY="-1^IB008"
GOTO COPAYQ
+6 IF $DATA(^IBE(350.1,+IBATYP,20))
XECUTE ^(20)
+7 ;
+8 ; - charge set is not defined as input for inpatient rates
+9 IF '$GET(IBCS)
SET IBCS=$$CSN^IBCRU3("TL-INPT (INCLUSIVE)")
+10 SET IBCHG=$$ITCHG^IBCRCI(IBCS,IBBS,IBDT)
+11 SET IBRTED=$PIECE(IBCHG,"^",2)
SET IBCHG=+IBCHG
+12 ;
+13 IF 'IBCHG
SET IBY="-1^IB030"
COPAYQ KILL IBCS
+1 QUIT
