- IBAUTL2 ;ALB/CPM - MEANS TEST BILLING UTILITIES ; 30-AUG-91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 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
- 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
- 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_"^"_%
- 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)
- ; Output: IBATYP, IBCHG, IBDESC, IBRTED
- N J S IBCHG=0,IBDESC=""
- I IBX="O" S IBBS=+$O(^DGCR(399.1,"B","OUTPATIENT VISIT",0)) 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 Output: IBATYP, IBCHG, IBDESC, IBRTED
- N CHK,DA,J,R,X,Y
- S (CHK,IBATYP,IBCHG)=0,J=-(IBDT+.1),(DA,IBDESC,R)=""
- S IBATYP=$P($G(^DGCR(399.1,IBBS,0)),"^",7) I 'IBATYP S IBY="-1^IB008" G COPAYQ
- I $D(^IBE(350.1,+IBATYP,20)) X ^(20)
- F S J=$O(^DGCR(399.5,"AIVDT",IBBS,J)) Q:'J D Q:CHK
- . F S R=$O(^DGCR(399.5,"AIVDT",IBBS,J,R)) Q:'R D Q:CHK
- .. F S DA=$O(^DGCR(399.5,"AIVDT",IBBS,J,R,DA)) Q:'DA D Q:CHK
- ... S Y=$G(^DGCR(399.5,+DA,0))
- ... I $P(Y,"^",5),$P(Y,"^",6)["c" S IBCHG=+$P(Y,"^",4),IBRTED=-J,CHK=1
- I 'IBCHG S IBY="-1^IB030"
- COPAYQ Q
- IBAUTL2 ;ALB/CPM - MEANS TEST BILLING UTILITIES ; 30-AUG-91
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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 DO NOW^%DTC
- SET $PIECE(^IB(IBN,1),"^")=DUZ
- SET $PIECE(^(1),"^",3,4)=DUZ_"^"_%
- +4 SET DIK="^IB("
- SET DA=IBN
- DO IX1^DIK
- KILL DIK,DA
- +5 ;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
- +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 SET DIK="^IB("
- SET DA=IBN
- DO IX1^DIK
- KILL DIK,DA
- +7 ;I $G(IBJOB)=1 S ^TMP($J,"IBAMTC","I",+$G(DFN),IBN)=""
- +8 QUIT
- +9 ;
- 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 ; Output: IBATYP, IBCHG, IBDESC, IBRTED
- +3 NEW J
- SET IBCHG=0
- SET IBDESC=""
- +4 IF IBX="O"
- SET IBBS=+$ORDER(^DGCR(399.1,"B","OUTPATIENT VISIT",0))
- DO COPAY
- +5 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)
- +6 IF 'IBATYP
- SET IBY="-1^IB008"
- GOTO TYPEQ
- +7 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 Output: IBATYP, IBCHG, IBDESC, IBRTED
- +2 NEW CHK,DA,J,R,X,Y
- +3 SET (CHK,IBATYP,IBCHG)=0
- SET J=-(IBDT+.1)
- SET (DA,IBDESC,R)=""
- +4 SET IBATYP=$PIECE($GET(^DGCR(399.1,IBBS,0)),"^",7)
- IF 'IBATYP
- SET IBY="-1^IB008"
- GOTO COPAYQ
- +5 IF $DATA(^IBE(350.1,+IBATYP,20))
- XECUTE ^(20)
- +6 FOR
- SET J=$ORDER(^DGCR(399.5,"AIVDT",IBBS,J))
- IF 'J
- QUIT
- Begin DoDot:1
- +7 FOR
- SET R=$ORDER(^DGCR(399.5,"AIVDT",IBBS,J,R))
- IF 'R
- QUIT
- Begin DoDot:2
- +8 FOR
- SET DA=$ORDER(^DGCR(399.5,"AIVDT",IBBS,J,R,DA))
- IF 'DA
- QUIT
- Begin DoDot:3
- +9 SET Y=$GET(^DGCR(399.5,+DA,0))
- +10 IF $PIECE(Y,"^",5)
- IF $PIECE(Y,"^",6)["c"
- SET IBCHG=+$PIECE(Y,"^",4)
- SET IBRTED=-J
- SET CHK=1
- End DoDot:3
- IF CHK
- QUIT
- End DoDot:2
- IF CHK
- QUIT
- End DoDot:1
- IF CHK
- QUIT
- +11 IF 'IBCHG
- SET IBY="-1^IB030"
- COPAYQ QUIT
