- 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 Jan 18, 2025@03:09:18 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