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

IBNCPDP5.m

Go to the documentation of this file. 
  1. IBNCPDP5 ;ALB/BDB - PROCESSING FOR ECME RESP FOR SECONDARY ;11/15/07 09:43
  1.  ;;2.0;INTEGRATED BILLING;**411,452,526,516,649,665**;21-MAR-94;Build 28
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. BILLSEC(DFN,IBD) ; Create secondary bill
  1.  ;
  1.  N IBBCB,IBBCF,IBBCT,IBCAN,IBCCR,IBCDFN,IBCNFN,IBCOB,IBCTCOPY,IBDBC
  1.  N IBIFN,IBINS,IBINSN,IBOFFSET,IBPLAN,IBY,IBAMT,IBRES,IBDUP
  1.  ;
  1.  ;if the primary claim was rejected and we don't have any primary bill for the RX/refill (see IBSEND^BPSECMP2 for additional information)
  1.  I $G(IBD("PRIMREJ"))=1 D
  1.  . N IBRX,IBRFL,IBREJ,IBDPR,IBRESUL,IBZARR,IBAR433,IBREJINF,DA,DR,DIE,IBRJ,IBRJCODE
  1.  . S IBRX=+$G(IBD("PRESCRIPTION"))
  1.  . S IBRFL=+$G(IBD("FILL NUMBER"))
  1.  . ;check the case when we are resubmitting the secondary claims that was submitted for rejected primary claim - 
  1.  . ;then we have already created a "dummy" primary bill and don't want to do this again
  1.  . I +$$RXBILL^IBNCPUT3(IBRX,IBRFL,"P",,.IBZARR)>0 S IBD("PRIOR PAYMENT")=0,IBD("PRIMARY BILL")=+$O(IBZARR(0)) Q  ;quit if any primary bills exist, set IBD("PRIMARY BILL") to the first existing bill ien
  1.  . ; create a "dummy" primary bill for the primary claim as it would be a payable primary claim with 0$ amount: 
  1.  . S IBDPR("PAID")=IBD("PAID")
  1.  . S IBDPR("PLAN")=IBD("PLAN")
  1.  . S IBDPR("RTYPE")=IBD("RTYPE")
  1.  . S IBD("PAID")=0
  1.  . S IBD("PLAN")=IBD("PRIMPLAN")
  1.  . S IBD("RTYPE")=""
  1.  . S IBD("RXCOB")=1
  1.  . S IBRESUL=$$BILL^IBNCPDP2(DFN,.IBD)
  1.  . ; the previous step should do contractual adjustment, if not - then we need to do something else here to adjust this amount and close the primary bill
  1.  . S IBD("PAID")=IBDPR("PAID")
  1.  . S IBD("PLAN")=IBDPR("PLAN")
  1.  . S IBD("RTYPE")=IBDPR("RTYPE")
  1.  . S IBD("RXCOB")=2
  1.  . S IBD("PRIMARY BILL")=$S(+IBRESUL>1:+IBRESUL,1:"")
  1.  . S IBD("PRIOR PAYMENT")=0
  1.  . Q:+IBD("PRIMARY BILL")=0
  1.  . ; get a reject information from IBD("REJ CODES") (see IBSEND^BPSECMP2) REJS(1,"REJ CODES",1,"08")
  1.  . S IBREJINF="Auto Dec.: ECME Primary claim rejected - "_$E($$REJINF(.IBD),1,30)
  1.  . ; put a note with the reject code/reason to AR file #433
  1.  . S IBAR433=$O(^PRCA(433,"C",+IBD("PRIMARY BILL"),0)) ; ICR# 3336
  1.  . S DA=IBAR433,DIE="^PRCA(433,",DR="41///"_IBREJINF D ^DIE ; ICR# 3336
  1.  . ; now quit to continue to create a secondary bill - i.e. allow the rest of the code to do its job
  1.  . Q
  1.  ;
  1.  ; IB*2*452 - esg - check for duplicate response first thing
  1.  S IBDUP=$$DUP^IBNCPDP2(.IBD) I IBDUP S IBY="0^Sec. Bill# "_$P(IBDUP,U,2)_" exists (Dup)" G BILLQ
  1.  ;
  1.  ; bill TRICARE copay if applicable
  1.  I $G(IBD("COPAY")) D BILL^IBNCPDP6($G(IBD("PRESCRIPTION"))_";"_$G(IBD("FILL NUMBER")),IBD("COPAY"),$G(IBD("RTYPE")))
  1.  ;
  1.  S IBCAN=2,IBDBC=DT,IBBCB=DUZ,IBCTCOPY=1,IBY=1
  1.  S IBIFN=$G(IBD("PRIMARY BILL")) I IBIFN="" S IBY="0^Missing the primary bill." G BILLQ
  1.  S IBPLAN=$G(IBD("PLAN")) I IBPLAN="" S IBY="0^The Secondary Payer is not a valid Insurance Co." G BILLQ
  1.  S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBD("DOS"))
  1.  I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ
  1.  S IBCNFN=$P(IBCDFN,"^",2)
  1.  S IBINSN=+^IBA(355.3,IBPLAN,0) ;insurance company
  1.  S IBINS=$G(^DIC(36,+IBINSN,0)) I IBINS="" S IBY="0^The Secondary Payer is not a valid Insurance Co." G BILLQ
  1.  S DIE="^DGCR(399,",DA=IBIFN,DR="102////"_IBINSN_";113////"_IBCNFN D ^DIE K DA,DR,DIE
  1.  S IBCOB("0",15)="" ;.15 BILL COPIED FROM 
  1.  S IBCOB("0",21)=$S($G(IBD("RXCOB"))=1:"P",$G(IBD("RXCOB"))=2:"S",1:"P") ;.21 CURRENT BILL PAYER SEQUENCE
  1.  S IBCOB("M1",5)=IBD("PRIMARY BILL") ;125 PRIMARY BILL # [5P:399]
  1.  S IBCOB("U2",4)=IBD("PRIOR PAYMENT") ;218 PRIMARY PRIOR PAYMENT [4N]
  1.  ;
  1.  S IBBCF=IBIFN ;this is the claim we are copying FROM
  1.  S IBIDS(.15)=IBIFN K IBIFN
  1. STEP2 ;
  1.  S IBND0=^DGCR(399,IBIDS(.15),0) I $D(^("U")) S IBNDU=^("U")
  1.  ;
  1.  ; *** Note - all these fields should also be included in WHERE^IBCCC1
  1.  ;            ECME claims should NOT define the 399,.27 - BILL CHARGE TYPE - leave it blank for RX COST Charge Set
  1.  ;
  1.  F I=2:1:12 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I)
  1.  F I=16:1:19,21:1:26 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I)
  1.  F I=151,152,155 S IBIDS(I)=$P(IBNDU,"^",(I-150))
  1.  S IBIDS(159.5)=$P(IBNDU,U,20)
  1.  S DFN=IBIDS(.02) D DEM^VADPT
  1.  ;set rate type
  1.  I $G(IBD("RXCOB"))=2,$G(IBD("RTYPE")) S IBIDS(.07)=IBD("RTYPE")
  1.  S PRCASV("SER")=$P($G(^IBE(350.9,1,1)),"^",14)
  1.  S PRCASV("SITE")=$P($$SITE^VASITE,"^",3),IBNWBL=""
  1.  D SETUP^PRCASVC3
  1.  I $S($P(PRCASV("ARREC"),"^")=-1:1,$P(PRCASV("ARBIL"),"^")=-1:1,1:0) S IBY="0^No Billing Record Set up for: "_$P(PRCASV("ARREC"),"^",2)_" "_$P(PRCASV("ARBIL"),"^",2) G BILLQ
  1.  S IBIDS(.01)=$P(PRCASV("ARBIL"),"-",2)
  1.  S IBIDS(.17)=$S($D(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))
  1.  S IBIDS(.02)=DFN,IBHV("IBIFN")=$S($G(IBIFN):IBIFN,1:$G(IBIDS(.15)))
  1.  S X=$P($T(WHERE),";;",2) F I=0:0 S I=$O(IBIDS(I)) Q:'I  S X1=$P($E(X,$F(X,I)+1,999),";",1),$P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IBIDS(I)
  1.  S IBIFN=PRCASV("ARREC") F I=0,"C","M","M1","S","U","U1" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I)
  1.  D  ; Protect variables;index entry;replace FT if copy/clone and it changes
  1.  . N IBHOLD,DIE,DR,DA,X,Y
  1.  . S IBHOLD("FT")=$P($G(^DGCR(399,IBIFN,0)),U,19)
  1.  . S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1 D INDEX^IBCCC2
  1.  . I IBHOLD("FT"),IBHOLD("FT")'=$P($G(^DGCR(399,IBIFN,0)),U,19) S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBHOLD("FT") D ^DIE
  1.  S IBYN=1
  1.  S IBBCT=IBIFN ; bill that the old claim was cloned TO.
  1.  K %,%DT,I,IB,IBA,IBBT,IBIDS,IBNWBL,J,VADM,X,X1,X2,X3,X4,Y
  1.  ;
  1.  S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
  1.  ;
  1.  ;move pure data nodes
  1.  ; MRD;IB*2.0*516 - Added "In7" nodes.
  1.  F I="I1","I17","I2","I27","I3","I37","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
  1.  ;
  1.  ;move top level data node. ;Do not move 'TX' node
  1.  F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @(I_"^IBCCC2")
  1.  ;
  1.  ;move multiple level data
  1.  F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @(I_"^IBCCC2")
  1.  ;
  1.  D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same
  1.  D COBCHG^IBCCC2(IBIFN,,.IBCOB)
  1.  ;
  1.  D ^IBCCC3 ; copy table files (362.3)
  1.  ;
  1.  S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
  1.  D PRIOR^IBCCC2(IBIFN) ; add new bill to previous bills in series, primary/secondary
  1.  I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ)
  1.  ;
  1. END ;
  1.  K %,%DT,D,DDH,DIC,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,DGFUNC,DGIFN
  1.  K DGPCM,DGREV,DGREV00,DGREVHDR,DGRVRCAL,DGXRF1,DFN
  1.  K I,IB,IBA,IBA1,IBA2,IBAC,IBAD,IBADD1,IBARST,IBBNO,IBBS,IBBT,IBCAN
  1.  K IBCBCOPY,IBCCC,IBCH,IBCHK,IBCNCOPY,IBCOB,IBDA,IBDD,IBDD1,IBDPT,IBDR
  1.  K IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBIN,IBINS,IBIP,IBLS,IBN,IBND,IBND0
  1.  K IBNDS,IBNDU,IBO,IBOA,IBOD,IBPROC,IBPTF,IBQUIT,IBREV,IBST,IBU,IBUC
  1.  K IBUN,IBV,IBV1,IBW,IBWW,IBX,IBYN,IBZZ,J,K
  1.  K PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,VA,VADM,VAEL,VAERR,X,X1,X2,X3,X4,Y
  1.  ;
  1.  N DA,IBADT,IBDIV,IBDUZ,IBPAID,IBTRIC,X
  1.  S IBIFN=IBBCT,IBADT=IBD("DOS"),IBDIV=+$G(IBD("DIVISION")),IBDUZ=$S($G(IBD("USER")):IBD("USER"),1:DUZ)
  1.  ;
  1.  S DIE="^DGCR(399,",DA=IBIFN
  1.  ; update the primary bill,ECME fields (make sure .27 field is blank)
  1.  S DR=".17////"_$G(IBD("PRIMARY BILL"))_";.27////@;460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")"
  1.  D ^DIE K DA,DR,DIE
  1.  ;
  1.  ; if the primary ECME claim was rejected, then do some Claims Tracking updates
  1.  ; since this secondary claim is payable  - esg 7/8/10
  1.  I $G(IBD("PRIMREJ"))=1 D
  1.  . N IBRXN,IBFIL,IBTRKRN,X,Y,D0,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR
  1.  . S IBRXN=+$G(IBD("PRESCRIPTION"))
  1.  . S IBFIL=+$G(IBD("FILL NUMBER"))
  1.  . D SETCT^IBNCPDP2    ; CT updates saying bill has been billed
  1.  . I '$G(IBTRKRN) Q
  1.  . S DIE="^IBT(356,",DA=IBTRKRN
  1.  . S DR=".19///@"                   ; reason not billable - delete it
  1.  . S DR=DR_";1.03///"_$$NOW^XLFDT   ; CT date last edited
  1.  . S DR=DR_";1.04///"_IBDUZ         ; CT last edited by
  1.  . S DR=DR_";1.11///0"              ; ECME Reject flag is 0 - NO
  1.  . D ^DIE
  1.  . Q
  1.  ;
  1.  ; need to make sure we have computed charges
  1.  S IBTRIC=$$TRICARE^IBNCPDP6($G(IBD("PRESCRIPTION"))_";"_$G(IBD("FILL NUMBER")))
  1.  D CHARGES^IBNCPDP2(IBIFN)
  1.  I $P($G(^DGCR(399,IBIFN,"U1")),U,1)'>0 S IBY="-1^Total Charges for Sec. Bill must be greater than $0." G BILLQ
  1.  ;
  1.  ; update the authorize/print fields
  1.  S DIE="^DGCR(399,",DA=IBIFN
  1.  S DR="9////1;12////"_DT D ^DIE
  1.  ;
  1.  ; *526 set approving official
  1.  S:'$D(^VA(200,IBDUZ,0)) IBDUZ=.5
  1.  ; pass the claim to AR
  1.  D GVAR^IBCBB,ARRAY^IBCBB1 S PRCASV("APR")=IBDUZ D ^PRCASVC6    ; perform AR checks
  1.  I 'PRCASV("OKAY") S IBY="-1^"_$$ARERR^IBNCPDP2($G(PRCAERR),2) G BILLQ
  1.  D REL^PRCASVC     ; accept bill into AR
  1.  ;
  1.  ; update the AR status to Active
  1.  S PRCASV("STATUS")=16
  1.  D STATUS^PRCASVC1
  1.  ;
  1.  ; decrease adjust bill
  1.  ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date
  1.  S IBAMT=$G(^DGCR(399,IBIFN,"U1")),IBOFFSET=$P($G(^DGCR(399,IBIFN,"U1")),U,2)
  1.  S IBPAID=$G(IBD("PAID"))
  1.  I IBAMT-IBPAID>.01 D
  1.  . N IBREAS
  1.  . S IBREAS="Adjust based on secondary ECME amount paid."
  1.  . I IBTRIC S IBREAS="Due to TRICARE Patient Responsibility (sec)."
  1.  . D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBOFFSET-IBPAID,IBDUZ,IBREAS,IBADT)
  1.  . I 'IBPAID S PRCASV("STATUS")=22 D STATUS^PRCASVC1 ; collected/closed
  1.  ;
  1.  D  ; set the user in 399
  1.  . N IBI,IBT F IBI=2,5,11,13,15 S IBT(399,IBIFN_",",IBI)=IBDUZ
  1.  . D FILE^DIE("","IBT")
  1.  ;
  1.  ;
  1. BILLQ ;
  1.  S IBRES=$S(IBY<0:"0^"_$S($L($P(IBY,"^",2)):$P(IBY,"^",2),1:$P(IBY,"^",3)),$G(IBBCT):+IBBCT,1:IBY)
  1.  I $G(IBBCT) S IBD("BILL")=IBBCT
  1.  D LOG^IBNCPDP2("BILL",IBRES)
  1.  I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBBCT))
  1.  Q IBRES
  1.  ;
  1. REJINF(IBREJARR) ;
  1.  N IBREJINF,IBRJ,IBRJCODE,IBCNT
  1.  S IBREJINF="",IBCNT=0
  1.  S IBRJ=0 F  S IBRJ=$O(IBREJARR("REJ CODES",IBRJ)) Q:+IBRJ=0  D
  1.  . S IBRJCODE="" F  S IBRJCODE=$O(IBREJARR("REJ CODES",IBRJ,IBRJCODE)) Q:IBRJCODE=""  D
  1.  . . I IBCNT>0 S IBREJINF=IBREJINF_", "
  1.  . . S IBREJINF=IBREJINF_IBRJCODE_":"_$G(IBREJARR("REJ CODES",IBRJ,IBRJCODE))
  1.  . . S IBCNT=IBCNT+1
  1.  Q IBREJINF
  1.  ;
  1. WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.12^0^12;.17^0^17;.18^0^18;.19^0^19;.15^0^15;.16^0^16;.21^0^21;.22^0^22;.23^0^23;.24^0^24;.25^0^25;.26^0^26;151^U^1;152^U^2;155^U^5;159.5^U^20;
  1.  ;