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

IBNCPDP3.m

Go to the documentation of this file.
  1. IBNCPDP3 ;OAK/ELZ - STORES NDC/AWP UPDATES ;11/14/07 13:18
  1. ;;2.0;INTEGRATED BILLING;**223,276,342,363,383,384,411,435,452,516,647**;21-MAR-94;Build 10
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference to ^PRCASER1 supported by IA# 593
  1. ; Reference to BPS RESPONSES file (#9002313.03) supported by IA# 4813
  1. ;
  1. ;
  1. UPAWP(IBNDC,IBAWP,IBADT) ; updates AWP prices for NDCs
  1. ;
  1. N IBITEM,IBCS
  1. ;
  1. ;
  1. S IBCS=$P($G(^IBE(350.9,1,9)),"^",12)
  1. I 'IBCS Q "0^Unable to find Charge Set"
  1. ;
  1. S IBNDC=$$NDC^IBNCPNB(IBNDC)
  1. ;
  1. S IBITEM=+$$ADDBI^IBCREF("NDC",IBNDC) I IBITEM Q "0^Unable to add item"
  1. ;
  1. I '$$ADDCI^IBCREF(IBCS,IBITEM,IBADT,IBAWP) Q "0^Unable to add charge"
  1. ;
  1. Q 1
  1. ;
  1. ;
  1. ;
  1. ;
  1. REVERSE(DFN,IBD,IBAUTO) ;process reversed claims
  1. N IBIFN,I,IB,IBIL,IBCHG,IBCRES,IBY,X,Y,DA,DIE,DR,IBADT,IBLOCK,IBLDT
  1. N IBNOW,IBDUZ,IBCR,IBRELC,IBCC,IBPAP,IBRXN,IBFIL,IBRTS,IBARES,IBUSR
  1. N IBLGL,IBLDT
  1. S IBDUZ=.5
  1. S IBLOCK=0
  1. ; find bill number
  1. I 'DFN S IBY="0^No patient" G REVQ
  1. I '$L($G(IBD("CLAIMID"))) S IBY="0^Missing ECME Number" G REVQ
  1. S IBADT=+$G(IBD("DOS")) I 'IBADT S IBY="0^Missing Date of Service" G REVQ
  1. S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^No Rx IEN" G REVQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G REVQ
  1. I $E($G(IBD("RESPONSE")),1)="R" D G REVQ:+'$G(IBRTS)
  1. . S IBY="0^REVERSAL rejected by payer"
  1. . S IBRTS=$$RTS(IBD("REVERSAL REASON"))
  1. ;
  1. D CANC^IBNCPDP6(IBRXN_";"_IBFIL) ; cancel 1st party charge for TRICARE
  1. ;
  1. S IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT)
  1. L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number" G REVQ
  1. S IBLOCK=1
  1. S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
  1. S IBLDT=$$FMADD^XLFDT(DT,1) F S IBLGL=$O(^XTMP("IBNCPLDT"_IBLDT),-1),IBLDT=$E(IBLGL,9,15) Q:IBLDT<$$FMADD^XLFDT(DT,-3)!(IBLGL'["IBNCPLDT") I $D(^XTMP(IBLGL,IBD("BCID"))) S ^(IBD("BCID"))="" Q
  1. S IBIFN=$$MATCH^IBNCPDP2(IBD("BCID"),$G(IBD("RXCOB")))
  1. I $D(IBD("CLOSE REASON")),'$D(IBD("DROP TO PAPER")) S IBD("DROP TO PAPER")=""
  1. S IBCR=+$G(IBD("CLOSE REASON"))
  1. S IBPAP=$G(IBD("DROP TO PAPER"))
  1. S IBRELC=$G(IBD("RELEASE COPAY"))
  1. S IBCC=$G(IBD("CLOSE COMMENT"))
  1. D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,IBPAP,IBRELC,IBCC,IBUSR)
  1. I 'IBIFN S IBY="0^"_$S(IBPAP:"Dropped to paper",IBCR>1:"Set non-billable reason in CT",1:"Cannot find the bill to reverse") G REVQ
  1. ;
  1. F I=0,"S" S IB(I)=$G(^DGCR(399,IBIFN,I))
  1. I IB(0)="" S IBY="0^No data in bill" G REVQ
  1. I +$P(IB("S"),U,16),$P(IB("S"),U,17)]"" S IBY="0^Bill already cancelled" G REVQ
  1. ;
  1. S:'$D(IBCRES) IBCRES="ECME PRESCRIPTION REVERSED"
  1. S DA=IBIFN,DR="16////1;19////"_IBCRES,DIE="^DGCR(399,"
  1. D ^DIE K DA,DIE,DR
  1. ;
  1. ; - decrease out the receivable in AR
  1. S IB("U1")=$G(^DGCR(399,IBIFN,"U1"))
  1. S IBIL=$P($G(^PRCA(430,IBIFN,0)),"^")
  1. S IBCHG=$S(IB("U1")']"":0,$P(IB("U1"),"^",1)]"":$P(IB("U1"),"^",1),1:0)
  1. ;
  1. S X="21^"_IBCHG_"^"_IBIL_"^"_IBDUZ_"^"_DT_"^"_IBCRES
  1. D ^PRCASER1
  1. S IBARES=Y
  1. I IBARES<0 S IBY=IBARES D BULL
  1. ;
  1. S IBY=$S(IBARES<0:"0^"_$P(IBARES,"^",2),1:1)
  1. ;
  1. I IBDUZ'=DUZ D ; set the real user
  1. . N IBI,IBT S IBI=18,IBT(399,IBIFN_",",IBI)=IBDUZ D FILE^DIE("","IBT")
  1. ;
  1. REVQ ; perform end of job tasks
  1. D LOG^IBNCPDP2($S($G(IBAUTO)=1:"AUTO REVERSE",$G(IBAUTO)=2:"BILL CANCELLED",1:"REVERSE"),IBY)
  1. I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
  1. I IBY=1,$G(IBIFN) S IBY=+IBIFN
  1. Q IBY
  1. ;
  1. RTS(IBRR) ; Return to Stock processing on Released Rx
  1. ; input - IBRR = reversal reason
  1. ; IBCRSN = passed in by reference
  1. ; output - 0 = reversal not due to a Rx RETURN TO STOCK or Rx DELETE
  1. ; 1 = reversal due to a Rx RETURN TO STOCK or Rx DELETE
  1. ; IBCRSN = charge removal reason
  1. N IBTRKRN,IBLOCK2,IBCMT,DA,DIE,DR
  1. ;
  1. I IBRR'="RX RETURNED TO STOCK"&(IBRR'="RX DELETED") Q 0
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
  1. I 'IBTRKRN Q 0 ; CT record does not exist
  1. I '$P($G(^IBT(356,IBTRKRN,0)),U,11) Q 0 ; BILL does not exist
  1. S IBCRES=$$GETRSN(DFN,IBRXN,IBFIL) ; recorded in file 399 entry
  1. L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
  1. S DIE="^IBT(356,",DA=IBTRKRN,IBCMT="Rx RTS - May Need Refund"
  1. S DR="1.08////"_IBCMT
  1. D ^DIE
  1. I IBLOCK2 L -^IBT(356,IBTRKRN)
  1. Q 1
  1. ;
  1. BULL ; Generate a bulletin if there is an error in cancelling the claim.
  1. N IBC,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
  1. ;
  1. S IBPT=$$PT^IBEFUNC(DFN)
  1. S XMSUB="ERROR ENCOUNTERED"
  1. S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
  1. S XMY(IBDUZ)=""
  1. S XMY("G.IBCNR EPHARM")=""
  1. ;
  1. S IBT(1)="An error occurred while cancelling the Pharmacy claim from ECME"
  1. S IBT(2)="fiscal intermediary for the following patient:"
  1. S IBT(3)=" " S IBC=3
  1. D PAT^IBAERR1 ; Accepts IBDUZ
  1. S IBC=IBC+1,IBT(IBC)=" Bill #: "_IBIL
  1. S IBC=IBC+1,IBT(IBC)=" "
  1. S IBC=IBC+1,IBT(IBC)="The following error was encountered:"
  1. S IBC=IBC+1,IBT(IBC)=" "
  1. D ERR^IBAERR1
  1. S IBC=IBC+1,IBT(IBC)=" "
  1. S IBC=IBC+1,IBT(IBC)="Please review the circumstances surrounding this error and decrease"
  1. S IBC=IBC+1,IBT(IBC)="out this receivable in Accounts Receivable if necessary."
  1. D ^XMD
  1. Q
  1. ;
  1. GETRSN(DFN,IBRXN,IBFIL) ;
  1. ; retrieve charge removal reason from file 354.71
  1. ; input - DFN,IBRXN=Rx ien,IBFIL=fill number
  1. ; output - charge removal reason
  1. N IBDT,IBDA,IBXRSN,IBRXFIL,IB0
  1. S (IBDT,IBDA)=0,IBXRSN=""
  1. S IBRXFIL=$S('IBFIL:IBRXN,1:IBRXN_";"_IBFIL)
  1. F S IBDT=$O(^IBAM(354.71,"AD",DFN,IBDT)) Q:'IBDT Q:IBXRSN]"" D
  1. . F S IBDA=$O(^IBAM(354.71,"AD",DFN,IBDT,IBDA)) Q:'IBDA Q:IBXRSN]"" D
  1. . . S IB0=^IBAM(354.71,IBDA,0)
  1. . . Q:$P(IB0,"^",6)'[IBRXFIL
  1. . . S IBXRSN=$$GET1^DIQ(354.71,IBDA_",",.19)
  1. S:IBXRSN']"" IBXRSN="CHARGE REMOVAL REASON NOT FOUND"
  1. Q "Reversal Rej, no pymt due<>"_IBXRSN
  1. ;
  1. ELIG(DFN,IBD) ; process an Eligibility response
  1. N IBRES,ERACT,IDUZ,IBFDA,BPRIEN,IBUSR,IBCDFN,IBPL,IBERR,EPHSRC,INSIEN,BUDA,PTDA,PLDA,ICDA,BUFF,BPSR,ZR,BPRSUB,BPRGRP,IBNCPDPELIG
  1. S IBRES=""
  1. I '$G(DFN) S IBRES="0^No patient - ELIG response" G ELIGX
  1. S BPRIEN=+$G(IBD("RESPIEN")) ; response file ien
  1. S IBUSR=+$G(IBD("USER")) ; DUZ of user
  1. S IBCDFN=+$G(IBD("POLICY")) ; pt. ins. policy subfile 2.312 ien
  1. S IBPL=+$G(IBD("PLAN")) ; plan 355.3 ien
  1. ;
  1. ; data integrity checks
  1. I 'BPRIEN S IBRES="0^No BPS RESPONSES file ien" G ELIGX
  1. I '$D(^BPSR(BPRIEN,0)) S IBRES="0^No BPS RESPONSES file data exists for this ien" G ELIGX
  1. S ZR=BPRIEN_","
  1. D GETS^DIQ(9002313.03,ZR,"103;301;302","IEN","BPSR")
  1. I $G(BPSR(9002313.03,ZR,103,"E"))'="E1" S IBRES="0^BPS Response is not an E1 Transaction Code" G ELIGX
  1. I 'IBCDFN S IBRES="0^No pt. policy ien" G ELIGX
  1. I '$D(^DPT(DFN,.312,IBCDFN,0)) S IBRES="0^Pt. insurance policy data not found" G ELIGX
  1. I +$P($G(^DPT(DFN,.312,IBCDFN,0)),U,18)'=IBPL S IBRES="0^Mismatch on plan ien" G ELIGX
  1. ;
  1. ; build a buffer entry based primarily on the ins. policy in the pt. file
  1. K IBERR
  1. S IDUZ=IBUSR
  1. S IBNCPDPELIG=1 ; special variable indicating to eIV where the buffer entry is coming from
  1. D PT^IBCNEBF(DFN,IBCDFN,"","",1,.IBERR) ; build and add buffer entry
  1. I $G(IBERR)'="" S IBRES="0^"_IBERR G ELIGX
  1. I '$G(IBFDA) S IBRES="0^No Buffer entry was created" G ELIGX
  1. I '$D(^IBA(355.33,IBFDA,0)) S IBRES="0^Buffer entry doesn't exist" G ELIGX
  1. S EPHSRC=+$O(^IBE(355.12,"C","E-PHARMACY",0)) ; source of information
  1. I 'EPHSRC S IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary" G ELIGX
  1. S INSIEN=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,1)
  1. I 'INSIEN S IBRES="0^Insurance Company pointer not there" G ELIGX
  1. ;
  1. ; complete the buffer entry
  1. S BUDA=+IBFDA_"," ; IENS for the buffer entry
  1. S PTDA=IBCDFN_","_DFN_"," ; IENS for the pt. ins. policy subfile entry 2.312
  1. S PLDA=IBPL_"," ; IENS for the plan entry 355.3
  1. S ICDA=INSIEN_"," ; IENS for the insurance company entry 36
  1. ;
  1. S BUFF(355.33,BUDA,60.1)=$$GET1^DIQ(2.312,PTDA,4.01,"I")
  1. S BUFF(355.33,BUDA,60.11)=$$GET1^DIQ(2.312,PTDA,4.02,"I")
  1. ;
  1. S BUFF(355.33,BUDA,40.01)=$$GET1^DIQ(355.3,PLDA,.02,"I")
  1. S BUFF(355.33,BUDA,40.04)=$$GET1^DIQ(355.3,PLDA,.05,"I")
  1. S BUFF(355.33,BUDA,40.05)=$$GET1^DIQ(355.3,PLDA,.06,"I")
  1. S BUFF(355.33,BUDA,40.06)=$$GET1^DIQ(355.3,PLDA,.12,"I")
  1. S BUFF(355.33,BUDA,40.07)=$$GET1^DIQ(355.3,PLDA,.07,"I")
  1. S BUFF(355.33,BUDA,40.08)=$$GET1^DIQ(355.3,PLDA,.08,"I")
  1. S BUFF(355.33,BUDA,40.09)=$$GET1^DIQ(355.3,PLDA,.09,"I")
  1. S BUFF(355.33,BUDA,40.1)=$$GET1^DIQ(355.3,PLDA,6.02,"I")
  1. S BUFF(355.33,BUDA,40.11)=$$GET1^DIQ(355.3,PLDA,6.03,"I")
  1. ;
  1. S BUFF(355.33,BUDA,20.02)=$$GET1^DIQ(36,ICDA,.131,"I")
  1. S BUFF(355.33,BUDA,20.05)=$$GET1^DIQ(36,ICDA,1,"I")
  1. S BUFF(355.33,BUDA,21.01)=$$GET1^DIQ(36,ICDA,.111,"I")
  1. S BUFF(355.33,BUDA,21.02)=$$GET1^DIQ(36,ICDA,.112,"I")
  1. S BUFF(355.33,BUDA,21.03)=$$GET1^DIQ(36,ICDA,.113,"I")
  1. S BUFF(355.33,BUDA,21.04)=$$GET1^DIQ(36,ICDA,.114,"I")
  1. S BUFF(355.33,BUDA,21.05)=$$GET1^DIQ(36,ICDA,.115,"I")
  1. S BUFF(355.33,BUDA,21.06)=$$GET1^DIQ(36,ICDA,.116,"I")
  1. ;
  1. ; update buffer entry with some additional information
  1. S BUFF(355.33,BUDA,.03)=EPHSRC ; source of info
  1. S BUFF(355.33,BUDA,.12)="" ; make sure eIV related fields are blank
  1. S BUFF(355.33,BUDA,.13)=""
  1. S BUFF(355.33,BUDA,.14)=""
  1. S BUFF(355.33,BUDA,.15)=""
  1. S BUFF(355.33,BUDA,.17)=BPRIEN ; BPS response file ien
  1. ;
  1. ; update buffer entry with data pulled from BPS response file
  1. ; only 2 fields are applicable here: group# and cardholder ID
  1. ;
  1. S BPRSUB=$G(BPSR(9002313.03,ZR,302,"E")) ; subscriber/cardholder ID
  1. ;I BPRSUB'="" S BUFF(355.33,BUDA,60.04)=BPRSUB ; update buffer if field exists
  1. I BPRSUB'="" S BUFF(355.33,BUDA,90.03)=BPRSUB ; update new field - 516 - baa
  1. ;
  1. S BPRGRP=$G(BPSR(9002313.03,ZR,301,"E")) ; group number
  1. ;I BPRGRP'="" S BUFF(355.33,BUDA,40.03)=BPRGRP ; update buffer if field exists
  1. I BPRGRP'="" S BUFF(355.33,BUDA,90.02)=BPRGRP ; update new field - 516 - baa
  1. ;
  1. D FILE^DIE(,"BUFF")
  1. ;
  1. S IBRES=1 ; all good
  1. ;
  1. ELIGX ;
  1. Q IBRES
  1. ;
  1. ;IBNCPDP3