Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCD2

IBCD2.m

Go to the documentation of this file.
  1. IBCD2 ;ALB/ARH - AUTOMATED BILLER (CREATE - SETUP/GATHER DATA FIELDS) ; 8/6/93
  1. ;;2.0;INTEGRATED BILLING;**4,55,91,106,384,458,592**;21-MAR-94;Build 58
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. FIND ;
  1. S IBX=$$CHKSYS^IBCD4 I 'IBX D TERR(0,0,$P(IBX,U,2)) G EXIT
  1. S IBS="IBC0" F S IBS=$O(^TMP(IBS)) Q:IBS="" S IBX=$E(IBS,4,99) Q:$E(IBS,1,3)'="IBC"!'+IBX D
  1. . N IBQUERY
  1. . S IBDFN=0 F S IBDFN=$O(^TMP(IBS,$J,IBDFN)) Q:'IBDFN D
  1. .. S IBSTDT="" F S IBSTDT=$O(^TMP(IBS,$J,IBDFN,IBSTDT)) Q:IBSTDT="" D I $D(IBCT)>9 D CREATE(.IBQUERY)
  1. ... K IBCT S IBTRN=0 F S IBTRN=$O(^TMP(IBS,$J,IBDFN,IBSTDT,IBTRN)) Q:'IBTRN S IBCT(IBTRN)="",IBTF=^TMP(IBS,$J,IBDFN,IBSTDT,IBTRN)
  1. .I $G(IBQUERY) D CLOSE^IBSDU(IBQUERY)
  1. EXIT K IBS,IBDFN,IBSTDT,IBCT,IBTRN,IBTF,IBX,X,DFN
  1. Q
  1. ;
  1. CREATE(IBQUERY) ;set up a bill, required: IBCT(IBTRN),IBDFN,IBSTDT
  1. ; IBQUERY, if defined, will be used to activate the outpt visit QUERY
  1. Q:$D(IBCT)<9 K IB
  1. S IBSP=$G(^IBE(350.9,1,1)),IBDIV=$P(IBSP,U,25),IBTRN=+$O(IBCT(0))
  1. S IBTRND=$G(^IBT(356,IBTRN,0)) I 'IBTRND D TERR(+IBTRN,0,"Claims Tracking Record not found or not complete.") G QUIT
  1. S IBTYPE=$P(IBTRND,U,18) S IBX=$$CHK I 'IBX D TERR(+IBTRN,0,$P(IBX,U,2)) G QUIT
  1. ;
  1. S IBX=$$ARSET I 'IBX D TERR(IBTRN,0,$P(IBX,U,2)) G QUIT
  1. S IBIFN=+IBX,IB(.01)=$P(IBX,U,2),IB(.17)=$P(IBX,U,3),IB(.2)=1,IB(.22)=IBDIV
  1. S (IB(.02),DFN)=IBDFN,IB(.06)=IBTF
  1. S IB(.07)=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",0)) I 'IB(.07) S IB(.07)=8
  1. S IBX=$O(^IBT(356.2,"ATRTP",IBTRN,1,"")) I +IBX S IB(163)=$E($P($G(^IBT(356.2,IBX,2)),U,2),1,18) ;pre-cert #
  1. ;
  1. S IBX=$P($G(^IBE(356.6,+IBTYPE,0)),U,1)
  1. I IBX="INPATIENT ADMISSION" D INPT^IBCD5 G CONT
  1. I IBX="PRESCRIPTION REFILL" D RXRF G CONT
  1. I IBX="OUTPATIENT VISIT" D OUTPT G CONT
  1. G QUIT
  1. ;
  1. CONT S IBX=$$BDT^IBCU3(IBDFN,IB(.03)) S IB(.17)=$S(+IBX:IBX,1:IBIFN) ; continuing episode of care
  1. ;Note if a primary bill is found for an outpatient bill then it allows them to choose the bill during bill creation, .17 is not editable on the screens
  1. S IB(.18)=$$SC^IBCU3(IBDFN) ; SC at time of care
  1. ;
  1. ; Note: variable IBQUERY used in this call to ^IBCD3
  1. D EN^IBCD3(.IBQUERY) ; create bill
  1. ;
  1. S IBTRN=0 F S IBTRN=$O(IBCT(IBTRN)) Q:'IBTRN D
  1. . D TERR(IBTRN,IBIFN,"") ; bill created
  1. . I ",2,3,"'[+$G(IB(.06)) D TEABD(IBTRN,0) ; remove eabd for final bills
  1. . D TBILL(IBTRN,IBIFN) ; set index for bill and event (356.399)
  1. . I $O(IB(43,0)),$$NABSCT^IBCU81(IBTRN) D TERR(IBTRN,IBIFN,"Stop/Clinic flagged to be ignored by auto biller but another visit is billed on same date.")
  1. . I $O(IB(43,0)),$$NBOE^IBCU81(+$P($G(^IBT(356,+IBTRN,0)),U,4)) D TERR(IBTRN,IBIFN,"Visit flagged as SC in source file but has no RNB.")
  1. ;
  1. S IBTRN=$O(IBCT(IBTRN)) Q:'IBTRN D
  1. . I $G(IB(.05))>2,$G(IB(.27))=1,+$G(^DGCR(399,IBIFN,"MP")),'$O(^DGCR(399,IBIFN,"RC",0)) D TERR(IBTRN,IBIFN,"This RC Opt bill appears to have no institutional charges but may have professional charges.")
  1. ;
  1. S X=$$PRCDIV^IBCU71(IBIFN) ; reset bill division from site default to first procedures division
  1. ;
  1. QUIT K X,Y,IBX,IBY,IBSP,IBDIV,IBTRN,IBTRND,IBTYPE,IB
  1. Q
  1. ;
  1. OUTPT S IB(.04)=$S(+$P($G(^DG(40.8,+IBDIV,0)),U,3):7,1:1) ;division outpatient only or hospital
  1. S IB(.05)=3,IB(.06)=1,IB(.09)=4
  1. ;event dt is date of first visit, stmt from is first visit dt, stmt to is last visit dt on bill
  1. S (IB(.03),IB(151))=9999999,IB(152)=""
  1. S IBTRNX=0 F S IBTRNX=$O(IBCT(IBTRNX)) Q:'IBTRNX S IBX=$P($G(^IBT(356,IBTRNX,0)),U,6)\1 D
  1. . S IB(43,+IBX)="" S:IB(152)<IBX IB(152)=IBX F IBI=.03,151 I IB(IBI)>IBX S IB(IBI)=IBX
  1. I +$$BILLRATE^IBCRU3(+$G(IB(.07)),IB(.05),IB(.03),"RC") S IB(.27)=1 ; reasonable charges institutional bill
  1. ;JWS;IB*2.0*592;US1109;IA# 2056; Identify event as Dental event
  1. S IBDENT=$F($$GET1^DIQ(9000010,$P(IBTRND,"^",3)_",",.08),"DENTAL")
  1. ;JWS;IB*2.0*592; for dental claims, default
  1. ; BILL CHARGE TYPE (.27) = 2 (PROFESSIONAL)
  1. ; FORM TYPE (.19) = 7
  1. ; TYPE OF ADMISSION (158) = 3 (ELECTIVE)
  1. ; PROCEDURE CODING METHOD (.09) = 5 (HCPCS)
  1. I IBDENT S IB(.27)=2,IB(.19)=7,IB(158)=3,IB(.09)=5
  1. ;JWS;IB*2.0*592;US1109 - added IBDENT to kill
  1. K IBI,IBX,IBTRNX,IBDENT
  1. Q
  1. RXRF S IB(.04)=$S(+$P($G(^DG(40.8,+IBDIV,0)),U,3):7,1:1) ;division outpatient only or hospital
  1. S IB(.05)=3,IB(.06)=1
  1. ;event dt is date of first visit, stmt from is first visit dt, stmt to is last visit dt on bill
  1. S (IB(.03),IB(151))=9999999,IB(152)=""
  1. S IBTRNX=0 F S IBTRNX=$O(IBCT(IBTRNX)) Q:'IBTRNX S IBRX=$G(^IBT(356,IBTRNX,0)) D
  1. . S IBX=$$RXRF^IBCD4(+$P(IBRX,U,8),+$P(IBRX,U,10)),IB(362.4,+$P(IBRX,U,8),+$P(IBRX,U,10))=IBX,IBX=$P(IBX,U,4)
  1. . S:IB(152)<IBX IB(152)=IBX F IBI=.03,151 I IB(IBI)>IBX S IB(IBI)=IBX
  1. . I $P(IBRX,U,31)>1 D ;special consent roi
  1. .. S IB(155)=1,IB(157)=0 ; is dx sensitive
  1. .. I $P(IBRX,U,31)=2 S IB(157)=1 ; ROI obtained
  1. K IBI,IBX,IBTRNX,IBRX
  1. Q
  1. ;
  1. ARSET() ; set up entry for new bill in AR returns IFN, bill number
  1. ;otherwise "0^error meaasge"
  1. N X S X="0^Can not set up bill in AR."
  1. S PRCASV("SER")=$P($G(^IBE(350.9,1,1)),U,14),PRCASV("SITE")=+$P($$SITE^VASITE,U,3)
  1. D SETUP^PRCASVC3
  1. I $P(PRCASV("ARBIL"),U)=-1 S X="0^"_$P(PRCASV("ARBIL"),U,2)_" - "_$$ETXT^IBEFUNC($P(PRCASV("ARBIL"),U,2)) G ARSETQ
  1. I $P(PRCASV("ARREC"),U)=-1 S X="0^"_$P(PRCASV("ARREC"),U,2)_" - "_$$ETXT^IBEFUNC($P(PRCASV("ARREC"),U,2)) G ARSETQ
  1. S X=PRCASV("ARREC")_U_$P(PRCASV("ARBIL"),"-",2)
  1. ARSETQ K PRCASV
  1. Q X
  1. ;
  1. CHK() ;other checks
  1. N X S X=1 I $G(^DPT(+$G(IBDFN),0))="" S X="0^Patient information lacking."
  1. Q X
  1. ;
  1. TEABD(TRN,IBDT) ;
  1. S IBDT=+$G(IBDT),^TMP("IBEABD",$J,+TRN,+IBDT)=""
  1. Q
  1. TERR(TRN,IFN,ER) ;
  1. N X S TRN=+$G(TRN),IFN=+$G(IFN),X=+$G(^TMP("IBCE",$J,DT,TRN,IFN))+1
  1. S ^TMP("IBCE",$J,DT,TRN,IFN,X)=$G(ER),^TMP("IBCE",$J,DT,TRN,IFN)=X
  1. Q
  1. TBILL(TRN,IFN) ;
  1. I '$D(^IBT(356,+$G(TRN),0))!('$D(^DGCR(399,+$G(IFN),0))) Q
  1. S ^TMP("IBILL",$J,TRN,IFN)=""
  1. Q