IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ; 2-NOV-89
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRBB1
;
% ;Bill Status
I IBST=""!($L(IBST)>1)!("012347"'[IBST) S IBER=IBER_"IB045;"
I IBST=0 S IBER="IB045;"
;
;Statement Covers From
I IBFDT="" S IBER=IBER_"IB061;"
I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;"
S IBFFY=$S($E(IBFDT,4,5)<10:$E(IBFDT,2,3),1:$E(IBFDT,2,3)+1)
;
;Statement Covers To
I IBTDT="" S IBER=IBER_"IB062;"
I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;"
S IBTFY=$S($E(IBTDT,4,5)<10:$E(IBTDT,2,3),1:$E(IBTDT,2,3)+1)
;
;Statement crosses fiscal years
I IBTFY'=IBFFY S IBER=IBER_"IB047;"
;
;Statement crosses calendar years
I $E(IBTDT,1,3)'=$E(IBFDT,1,3) S IBER=IBER_"IB046;"
;
;Total Charges
I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;"
;
;Fiscal Year 1
I IBFY=""!($L(IBFY)'=2)!(IBFY<80)!(IBFY>($S($E(DT,4,5)<10:$E(DT,2,3),1:$E(DT,2,3)+1))) S IBER=IBER_"IB050;"
;
;FY 1 Charges
I +IBFYC'>0!(+IBFYC'=IBFYC) S IBER=IBER_"IB051;"
;
;FY 1 Charges minus offset greater than 0
I +IBFYC-$P(IBNDU1,"^",2)'>0 S IBER=IBER_"IB052;"
;
;Check provider link for current user, enterer, reviewer and Authorizor
I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;"
I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;"
I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;"
I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;"
;
;Bill exists and not already new bill
;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;"
;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;"
;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;"
I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;"
;
;asc on bill and more than one visit, ub's only
I IBFT'=2,IBWHO="i",$D(^DGCR(399,"ASC2",IBIFN)),$O(^($O(^DGCR(399,IBIFN,"OP",0)))) S IBER=IBER_"IB042;"
;
;edit checks for HCFA 1500 forms
I IBFT=2 D ^IBCBB2
;
;Other things that could be added: Revenue Code - calculating charges
; Diagnosis Coding, if Cat C - check for other co-payments
;
D ARRAY:IBER=""
;
END ;Don't kill IBifn, IBer, dfn
K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBNDS,IBND0,IBNDU,IBNDM,IBNDU1,IBFFY,IBTFY,IBFT
I $D(IBER),IBER="" W !,"No Errors found"
Q
;
ARRAY ;Build PRCASV(array)
K PRCASV
S X=IBIFN D ^IBCAMS S:Y>0 PRCASV("AMIS")=Y
S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN
S PRCASV("APR")=DUZ
S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6)
I IBWHO="i" S PRCASV("DEBTOR")=+IBNDM_";DIC(36,"
S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"")
S PRCASV("CARE")=IBLOC_IBCL
S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"")
PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2)
I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3)
Q:'$D(^DGCR(399,IBIFN,"I1")) S IBNDI1=^("I1")
S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3)
S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15)
S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17)
S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO")
Q
IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ; 2-NOV-89
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRBB1
+5 ;
% ;Bill Status
+1 IF IBST=""!($LENGTH(IBST)>1)!("012347"'[IBST)
SET IBER=IBER_"IB045;"
+2 IF IBST=0
SET IBER="IB045;"
+3 ;
+4 ;Statement Covers From
+5 IF IBFDT=""
SET IBER=IBER_"IB061;"
+6 IF IBFDT]""
IF IBFDT'?7N&(IBFDT'?7N1".".N)
SET IBER=IBER_"IB061;"
+7 SET IBFFY=$SELECT($EXTRACT(IBFDT,4,5)<10:$EXTRACT(IBFDT,2,3),1:$EXTRACT(IBFDT,2,3)+1)
+8 ;
+9 ;Statement Covers To
+10 IF IBTDT=""
SET IBER=IBER_"IB062;"
+11 IF IBTDT]""
IF IBTDT'?7N&(IBTDT'?7N1".".N)
SET IBER=IBER_"IB062;"
+12 SET IBTFY=$SELECT($EXTRACT(IBTDT,4,5)<10:$EXTRACT(IBTDT,2,3),1:$EXTRACT(IBTDT,2,3)+1)
+13 ;
+14 ;Statement crosses fiscal years
+15 IF IBTFY'=IBFFY
SET IBER=IBER_"IB047;"
+16 ;
+17 ;Statement crosses calendar years
+18 IF $EXTRACT(IBTDT,1,3)'=$EXTRACT(IBFDT,1,3)
SET IBER=IBER_"IB046;"
+19 ;
+20 ;Total Charges
+21 IF +IBTC'>0!(+IBTC'=IBTC)
SET IBER=IBER_"IB064;"
+22 ;
+23 ;Fiscal Year 1
+24 IF IBFY=""!($LENGTH(IBFY)'=2)!(IBFY<80)!(IBFY>($SELECT($EXTRACT(DT,4,5)<10:$EXTRACT(DT,2,3),1:$EXTRACT(DT,2,3)+1)))
SET IBER=IBER_"IB050;"
+25 ;
+26 ;FY 1 Charges
+27 IF +IBFYC'>0!(+IBFYC'=IBFYC)
SET IBER=IBER_"IB051;"
+28 ;
+29 ;FY 1 Charges minus offset greater than 0
+30 IF +IBFYC-$PIECE(IBNDU1,"^",2)'>0
SET IBER=IBER_"IB052;"
+31 ;
+32 ;Check provider link for current user, enterer, reviewer and Authorizor
+33 IF '$DATA(^VA(200,DUZ,0))
SET IBER=IBER_"IB048;"
+34 IF IBEU]""
IF '$DATA(^VA(200,IBEU,0))
SET IBER=IBER_"IB048;"
+35 IF IBRU]""
IF '$DATA(^VA(200,IBRU,0))
SET IBER=IBER_"IB060;"
+36 IF IBAU]""
IF '$DATA(^VA(200,IBAU,0))
SET IBER=IBER_"IB041;"
+37 ;
+38 ;Bill exists and not already new bill
+39 ;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;"
+40 ;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;"
+41 ;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;"
+42 IF IBER=""
IF +$$STA^PRCAFN(IBIFN)=104
SET IBER=IBER_"IB040;"
+43 ;
+44 ;asc on bill and more than one visit, ub's only
+45 IF IBFT'=2
IF IBWHO="i"
IF $DATA(^DGCR(399,"ASC2",IBIFN))
IF $ORDER(^($ORDER(^DGCR(399,IBIFN,"OP",0))))
SET IBER=IBER_"IB042;"
+46 ;
+47 ;edit checks for HCFA 1500 forms
+48 IF IBFT=2
DO ^IBCBB2
+49 ;
+50 ;Other things that could be added: Revenue Code - calculating charges
+51 ; Diagnosis Coding, if Cat C - check for other co-payments
+52 ;
+53 IF IBER=""
DO ARRAY
+54 ;
END ;Don't kill IBifn, IBer, dfn
+1 KILL IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBNDS,IBND0,IBNDU,IBNDM,IBNDU1,IBFFY,IBTFY,IBFT
+2 IF $DATA(IBER)
IF IBER=""
WRITE !,"No Errors found"
+3 QUIT
+4 ;
ARRAY ;Build PRCASV(array)
+1 KILL PRCASV
+2 SET X=IBIFN
DO ^IBCAMS
IF Y>0
SET PRCASV("AMIS")=Y
+3 SET PRCASV("BDT")=DT
SET PRCASV("ARREC")=IBIFN
+4 SET PRCASV("APR")=DUZ
+5 SET PRCASV("PAT")=DFN
SET PRCASV("CAT")=$PIECE(^DGCR(399.3,IBAT,0),"^",6)
+6 IF IBWHO="i"
SET PRCASV("DEBTOR")=+IBNDM_";DIC(36,"
+7 SET PRCASV("DEBTOR")=$SELECT(IBWHO="p":DFN_";DPT(",IBWHO="o":$PIECE(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"")
+8 SET PRCASV("CARE")=IBLOC_IBCL
+9 SET PRCASV("FY")=$PIECE(IBNDU1,U,9)_U_$SELECT($PIECE(IBNDU1,U,2)]"":($PIECE(IBNDU1,U,10)-$PIECE(IBNDU1,U,2)),1:$PIECE(IBNDU1,U,10))_$SELECT($PIECE(IBNDU1,U,11)]"":U_$PIECE(IBNDU1,U,11)_U_$PIECE(IBNDU1,U,12),1:"")
PLUS IF IBWHO="i"
IF $PIECE(IBNDM,"^",2)
IF $DATA(^DIC(36,$PIECE(IBNDM,"^",2),0))
SET PRCASV("2NDINS")=$PIECE(IBNDM,"^",2)
+1 IF IBWHO="i"
IF $PIECE(IBNDM,"^",3)
IF $DATA(^DIC(36,$PIECE(IBNDM,"^",3),0))
SET PRCASV("3RDINS")=$PIECE(IBNDM,"^",3)
+2 IF '$DATA(^DGCR(399,IBIFN,"I1"))
QUIT
SET IBNDI1=^("I1")
+3 IF $PIECE(IBNDI1,"^",3)]""
SET PRCASV("GPNO")=$PIECE(IBNDI1,"^",3)
+4 IF $PIECE(IBNDI1,"^",15)]""
SET PRCASV("GPNM")=$PIECE(IBNDI1,"^",15)
+5 IF $PIECE(IBNDI1,"^",17)]""
SET PRCASV("INPA")=$PIECE(IBNDI1,"^",17)
+6 IF $PIECE(IBNDI1,"^",2)]""
SET PRCASV("IDNO")=$PIECE(IBNDI1,"^",2)
SET PRCASV("INID")=PRCASV("IDNO")
+7 QUIT
