IBNCPDP3 ;OAK/ELZ - STORES NDC/AWP UPDATES ;14-NOV-2007
;;2.0;INTEGRATED BILLING;**223,276,342,363,383,384,411,435,452,516,647,822**;21-MAR-94;Build 21
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to ^PRCASER1 supported by ICR# 593
; Reference to BPS RESPONSES file (#9002313.03) supported by ICR# 4813
;
;
UPAWP(IBNDC,IBAWP,IBADT) ; updates AWP prices for NDCs
;
N IBITEM,IBCS
;
;
S IBCS=$P($G(^IBE(350.9,1,9)),"^",12)
I 'IBCS Q "0^Unable to find Charge Set"
;
S IBNDC=$$NDC^IBNCPNB(IBNDC)
;
S IBITEM=+$$ADDBI^IBCREF("NDC",IBNDC) I IBITEM Q "0^Unable to add item"
;
I '$$ADDCI^IBCREF(IBCS,IBITEM,IBADT,IBAWP) Q "0^Unable to add charge"
;
Q 1
;
;
;
;
REVERSE(DFN,IBD,IBAUTO) ;process reversed claims
N IBIFN,I,IB,IBIL,IBCHG,IBCRES,IBY,X,Y,DA,DIE,DR,IBADT,IBLOCK,IBLDT
N IBNOW,IBDUZ,IBCR,IBRELC,IBCC,IBPAP,IBRXN,IBFIL,IBRTS,IBARES,IBUSR
N IBLGL,IBLDT
S IBDUZ=.5
S IBLOCK=0
; find bill number
I 'DFN S IBY="0^No patient" G REVQ
I '$L($G(IBD("CLAIMID"))) S IBY="0^Missing ECME Number" G REVQ
S IBADT=+$G(IBD("DOS")) I 'IBADT S IBY="0^Missing Date of Service" G REVQ
S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^No Rx IEN" G REVQ
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G REVQ
I $E($G(IBD("RESPONSE")),1)="R" D G REVQ:+'$G(IBRTS)
. S IBY="0^REVERSAL rejected by payer"
. S IBRTS=$$RTS(IBD("REVERSAL REASON"))
;
D CANC^IBNCPDP6(IBRXN_";"_IBFIL) ; cancel 1st party charge for TRICARE
;
S IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT)
L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number" G REVQ
S IBLOCK=1
S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
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
S IBIFN=$$MATCH^IBNCPDP2(IBD("BCID"),$G(IBD("RXCOB")))
I $D(IBD("CLOSE REASON")),'$D(IBD("DROP TO PAPER")) S IBD("DROP TO PAPER")=""
S IBCR=+$G(IBD("CLOSE REASON"))
S IBPAP=$G(IBD("DROP TO PAPER"))
S IBRELC=$G(IBD("RELEASE COPAY"))
S IBCC=$G(IBD("CLOSE COMMENT"))
D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,IBPAP,IBRELC,IBCC,IBUSR)
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
;
F I=0,"S" S IB(I)=$G(^DGCR(399,IBIFN,I))
I IB(0)="" S IBY="0^No data in bill" G REVQ
I +$P(IB("S"),U,16),$P(IB("S"),U,17)]"" S IBY="0^Bill already cancelled" G REVQ
;
S:'$D(IBCRES) IBCRES="ECME PRESCRIPTION REVERSED"
S DA=IBIFN,DR="16////1;19////"_IBCRES,DIE="^DGCR(399,"
D ^DIE K DA,DIE,DR
;
; - decrease out the receivable in AR
S IB("U1")=$G(^DGCR(399,IBIFN,"U1"))
S IBIL=$P($G(^PRCA(430,IBIFN,0)),"^")
S IBCHG=$S(IB("U1")']"":0,$P(IB("U1"),"^",1)]"":$P(IB("U1"),"^",1),1:0)
;
S X="21^"_IBCHG_"^"_IBIL_"^"_IBDUZ_"^"_DT_"^"_IBCRES
D ^PRCASER1
S IBARES=Y
I IBARES<0 S IBY=IBARES D BULL
;
S IBY=$S(IBARES<0:"0^"_$P(IBARES,"^",2),1:1)
;
I IBDUZ'=DUZ D ; set the real user
. N IBI,IBT S IBI=18,IBT(399,IBIFN_",",IBI)=IBDUZ D FILE^DIE("","IBT")
;
REVQ ; perform end of job tasks
D LOG^IBNCPDP2($S($G(IBAUTO)=1:"AUTO REVERSE",$G(IBAUTO)=2:"BILL CANCELLED",1:"REVERSE"),IBY)
I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
I IBY=1,$G(IBIFN) S IBY=+IBIFN
Q IBY
;
RTS(IBRR) ; Return to Stock processing on Released Rx
; input - IBRR = reversal reason
; IBCRSN = passed in by reference
; output - 0 = reversal not due to a Rx RETURN TO STOCK or Rx DELETE
; 1 = reversal due to a Rx RETURN TO STOCK or Rx DELETE
; IBCRSN = charge removal reason
N IBTRKRN,IBLOCK2,IBCMT,DA,DIE,DR
;
I IBRR'="RX RETURNED TO STOCK"&(IBRR'="RX DELETED") Q 0
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
I 'IBTRKRN Q 0 ; CT record does not exist
I '$P($G(^IBT(356,IBTRKRN,0)),U,11) Q 0 ; BILL does not exist
S IBCRES=$$GETRSN(DFN,IBRXN,IBFIL) ; recorded in file 399 entry
L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
S DIE="^IBT(356,",DA=IBTRKRN,IBCMT="Rx RTS - May Need Refund"
S DR="1.08////"_IBCMT
D ^DIE
I IBLOCK2 L -^IBT(356,IBTRKRN)
Q 1
;
BULL ; Generate a bulletin if there is an error in cancelling the claim.
N IBC,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
;
S IBPT=$$PT^IBEFUNC(DFN)
S XMSUB="ERROR ENCOUNTERED"
S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
S XMY(IBDUZ)=""
S XMY("G.IBCNR EPHARM")=""
;
S IBT(1)="An error occurred while cancelling the Pharmacy claim from ECME"
S IBT(2)="fiscal intermediary for the following patient:"
S IBT(3)=" " S IBC=3
D PAT^IBAERR1 ; Accepts IBDUZ
S IBC=IBC+1,IBT(IBC)=" Bill #: "_IBIL
S IBC=IBC+1,IBT(IBC)=" "
S IBC=IBC+1,IBT(IBC)="The following error was encountered:"
S IBC=IBC+1,IBT(IBC)=" "
D ERR^IBAERR1
S IBC=IBC+1,IBT(IBC)=" "
S IBC=IBC+1,IBT(IBC)="Please review the circumstances surrounding this error and decrease"
S IBC=IBC+1,IBT(IBC)="out this receivable in Accounts Receivable if necessary."
D ^XMD
Q
;
GETRSN(DFN,IBRXN,IBFIL) ;
; retrieve charge removal reason from file 354.71
; input - DFN,IBRXN=Rx ien,IBFIL=fill number
; output - charge removal reason
N IBDT,IBDA,IBXRSN,IBRXFIL,IB0
S (IBDT,IBDA)=0,IBXRSN=""
S IBRXFIL=$S('IBFIL:IBRXN,1:IBRXN_";"_IBFIL)
F S IBDT=$O(^IBAM(354.71,"AD",DFN,IBDT)) Q:'IBDT Q:IBXRSN]"" D
. F S IBDA=$O(^IBAM(354.71,"AD",DFN,IBDT,IBDA)) Q:'IBDA Q:IBXRSN]"" D
. . S IB0=^IBAM(354.71,IBDA,0)
. . Q:$P(IB0,"^",6)'[IBRXFIL
. . S IBXRSN=$$GET1^DIQ(354.71,IBDA_",",.19)
S:IBXRSN']"" IBXRSN="CHARGE REMOVAL REASON NOT FOUND"
Q "Reversal Rej, no pymt due<>"_IBXRSN
;
ELIG(DFN,IBD) ; process an Eligibility response
N IBRES,ERACT,IDUZ,IBFDA,BPRIEN,IBUSR,IBCDFN,IBPL,IBERR,EPHSRC,INSIEN,BUDA,PTDA,PLDA,ICDA,BUFF,BPSR,ZR,BPRSUB,BPRGRP,IBNCPDPELIG
S IBRES=""
I '$G(DFN) S IBRES="0^No patient - ELIG response" G ELIGX
S BPRIEN=+$G(IBD("RESPIEN")) ; response file ien
S IBUSR=+$G(IBD("USER")) ; DUZ of user
S IBCDFN=+$G(IBD("POLICY")) ; pt. ins. policy subfile 2.312 ien
S IBPL=+$G(IBD("PLAN")) ; plan 355.3 ien
;
; data integrity checks
I 'BPRIEN S IBRES="0^No BPS RESPONSES file ien" G ELIGX
I '$D(^BPSR(BPRIEN,0)) S IBRES="0^No BPS RESPONSES file data exists for this ien" G ELIGX
S ZR=BPRIEN_","
D GETS^DIQ(9002313.03,ZR,"103;301;302","IEN","BPSR")
I $G(BPSR(9002313.03,ZR,103,"E"))'="E1" S IBRES="0^BPS Response is not an E1 Transaction Code" G ELIGX
I 'IBCDFN S IBRES="0^No pt. policy ien" G ELIGX
I '$D(^DPT(DFN,.312,IBCDFN,0)) S IBRES="0^Pt. insurance policy data not found" G ELIGX
I +$P($G(^DPT(DFN,.312,IBCDFN,0)),U,18)'=IBPL S IBRES="0^Mismatch on plan ien" G ELIGX
;
; IB*822/DJW - call gatekeeper if test acct and triggered from eIV appt ext
I $$CHECK^BPSTEST D E1^IBCNETST(DFN,BPRIEN)
;
;IB*822/CKB - get E1 buffer symbol
N BPSSTAT,E1SYMBOL S (BPSSTAT,E1SYMBOL)=""
S BPSSTAT=$$GET1^DIQ(9002313.0301,"1,"_BPRIEN,112,"I") ;TRANSACTION RESPONSE STATUS
S E1SYMBOL=$S(BPSSTAT="A":"a1",BPSSTAT="R":"r1",1:"")
S E1SYMBOL=$$FIND1^DIC(365.15,,"MX",E1SYMBOL) ;get IEN of E1 symbol
;
; build a buffer entry based primarily on the ins. policy in the pt. file
K IBERR
S IDUZ=IBUSR
S IBNCPDPELIG=1 ; special variable indicating to eIV where the buffer entry is coming from
;
;IB*822/CKB - include symbol from E1 transaction (E1SYMBOL) when creating the Buffer
; - moved up from below: 1) added IBSOURCE and 2) changed "E-PHARMACY" to "EPHARMACY"
N IBSOURCE
S (IBSOURCE,EPHSRC)=+$O(^IBE(355.12,"C","EPHARMACY",0)) ; source of information
I 'EPHSRC S IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary" G ELIGX
D PT^IBCNEBF(DFN,IBCDFN,E1SYMBOL,"",1,.IBERR) ; build and add buffer entry
I $G(IBERR)'="" S IBRES="0^"_IBERR G ELIGX
I '$G(IBFDA) S IBRES="0^No Buffer entry was created" G ELIGX
I '$D(^IBA(355.33,IBFDA,0)) S IBRES="0^Buffer entry doesn't exist"
;IB*822/CKB - changed "E-PHARMACY" to "EPHARMACY"
S EPHSRC=+$O(^IBE(355.12,"C","EPHARMACY",0)) ; source of information
I 'EPHSRC S IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary" G ELIGX
S INSIEN=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,1)
I 'INSIEN S IBRES="0^Insurance Company pointer not there" G ELIGX
;
; complete the buffer entry
S BUDA=+IBFDA_"," ; IENS for the buffer entry
S PTDA=IBCDFN_","_DFN_"," ; IENS for the pt. ins. policy subfile entry 2.312
S PLDA=IBPL_"," ; IENS for the plan entry 355.3
S ICDA=INSIEN_"," ; IENS for the insurance company entry 36
;
;IB*822/CKB - removed adding the addt'l fields to the buffer as they are not coming from the Payer
;S BUFF(355.33,BUDA,60.1)=$$GET1^DIQ(2.312,PTDA,4.01,"I")
;S BUFF(355.33,BUDA,60.11)=$$GET1^DIQ(2.312,PTDA,4.02,"I")
;
;S BUFF(355.33,BUDA,40.01)=$$GET1^DIQ(355.3,PLDA,.02,"I")
;S BUFF(355.33,BUDA,40.04)=$$GET1^DIQ(355.3,PLDA,.05,"I")
;S BUFF(355.33,BUDA,40.05)=$$GET1^DIQ(355.3,PLDA,.06,"I")
;S BUFF(355.33,BUDA,40.06)=$$GET1^DIQ(355.3,PLDA,.12,"I")
;S BUFF(355.33,BUDA,40.07)=$$GET1^DIQ(355.3,PLDA,.07,"I")
;S BUFF(355.33,BUDA,40.08)=$$GET1^DIQ(355.3,PLDA,.08,"I")
;S BUFF(355.33,BUDA,40.09)=$$GET1^DIQ(355.3,PLDA,.09,"I")
;S BUFF(355.33,BUDA,40.1)=$$GET1^DIQ(355.3,PLDA,6.02,"I")
;S BUFF(355.33,BUDA,40.11)=$$GET1^DIQ(355.3,PLDA,6.03,"I")
;
;S BUFF(355.33,BUDA,20.02)=$$GET1^DIQ(36,ICDA,.131,"I")
;S BUFF(355.33,BUDA,20.05)=$$GET1^DIQ(36,ICDA,1,"I")
;S BUFF(355.33,BUDA,21.01)=$$GET1^DIQ(36,ICDA,.111,"I")
;S BUFF(355.33,BUDA,21.02)=$$GET1^DIQ(36,ICDA,.112,"I")
;S BUFF(355.33,BUDA,21.03)=$$GET1^DIQ(36,ICDA,.113,"I")
;S BUFF(355.33,BUDA,21.04)=$$GET1^DIQ(36,ICDA,.114,"I")
;S BUFF(355.33,BUDA,21.05)=$$GET1^DIQ(36,ICDA,.115,"I")
;S BUFF(355.33,BUDA,21.06)=$$GET1^DIQ(36,ICDA,.116,"I")
;
; update buffer entry with some additional information
;IB*822/CKB - commented out the following lines of code as they are being set unneccessarily
; this overwrites a valid value - S BUFF(355.33,BUDA,.03)=EPHSRC ; source of info
;S BUFF(355.33,BUDA,.12)="" ; make sure eIV related fields are blank
;S BUFF(355.33,BUDA,.13)=""
;S BUFF(355.33,BUDA,.14)=""
S BUFF(355.33,BUDA,.15)=$$NOW^XLFDT ; IB*822/CKB - changed from "" (setting IIV PDATE on purpose)
S BUFF(355.33,BUDA,.17)=BPRIEN ; BPS response file ien
;
; update buffer entry with data pulled from BPS response file
; only 2 fields are applicable here: group# and cardholder ID
;
S BPRGRP=$G(BPSR(9002313.03,ZR,301,"E")) ; group number
;I BPRGRP'="" S BUFF(355.33,BUDA,40.03)=BPRGRP ; update buffer if field exists
I BPRGRP'="" S BUFF(355.33,BUDA,90.02)=BPRGRP ; update new field - 516 - baa
;
S BPRSUB=$G(BPSR(9002313.03,ZR,302,"E")) ; subscriber/cardholder ID
;I BPRSUB'="" S BUFF(355.33,BUDA,60.04)=BPRSUB ; update buffer if field exists
I BPRSUB'="" S BUFF(355.33,BUDA,90.03)=BPRSUB ; update new field - 516 - baa
;
D FILE^DIE(,"BUFF")
;
;IB*822/CKB - call to add tracking the E1 transactions
D EIVE1LOG
;
S IBRES=1 ; all good
;
ELIGX ;
Q IBRES
;
EIVE1LOG ;IB*822/CKB - Add to EIV E1 TRANSACTION RESPONSE LOG file #365.3
N E1IEN,E1LOG,IBDATA,IBERR,IBFILE,IBIEN,IBIENS
S IBFILE=365.3
;
S IBDATA(.01)=DFN ;IEN of PATIENT file #2
S IBDATA(.02)=$$NOW^XLFDT ;Date/Time response received
S IBDATA(.03)=BPRIEN ;IEN of BPS RESPONSE file #9002313.03
;Add/create entry in file #365.3
S E1IEN=$$ADD^IBDFDBS(IBFILE,,.IBDATA,.IBERR,.IBIEN)
I 'E1IEN,('IBIEN) Q ; W "Unable to add entry, "_IBERR
K IBDATA S IBERR=""
;
;IBIENS=IEN for file #365.3 - add other info to file
S IBIENS=E1IEN S:IBIENS="" IBIENS=IBIEN S IBIENS=IBIENS_","
S E1LOG(365.3,IBIENS,.04)=$$GET1^DIQ(9002313.0301,"1,"_BPRIEN,112,"I") ;Transaction Status
S E1LOG(365.3,IBIENS,.05)=IBFDA ;IEN of Buffer file #355.33
S E1LOG(365.3,IBIENS,.06)=0 ;prevent from purging
S E1LOG(365.3,IBIENS,1.1)=IBCDFN ;IEN of PATIENT INSURANCE subfile #2.312
S E1LOG(365.3,IBIENS,1.2)=INSIEN ;IEN of INSURANCE file #36
S E1LOG(365.3,IBIENS,1.3)=$$GET1^DIQ(36,ICDA,.01) ;Insurance Company Name
S E1LOG(365.3,IBIENS,1.4)=IBPL ;IEN of GROUP PLAN file #355.3
S E1LOG(365.3,IBIENS,1.5)=$$GET1^DIQ(355.33,BUDA,90.02) ;Group Number
S E1LOG(365.3,IBIENS,1.6)=$$GET1^DIQ(355.33,BUDA,90.03) ;Subscriber ID
D FILE^DIE(,"E1LOG")
K E1LOG
Q
;IBNCPDP3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP3 12613 printed Mar 25, 2026@15:49:38 Page 2
IBNCPDP3 ;OAK/ELZ - STORES NDC/AWP UPDATES ;14-NOV-2007
+1 ;;2.0;INTEGRATED BILLING;**223,276,342,363,383,384,411,435,452,516,647,822**;21-MAR-94;Build 21
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to ^PRCASER1 supported by ICR# 593
+5 ; Reference to BPS RESPONSES file (#9002313.03) supported by ICR# 4813
+6 ;
+7 ;
UPAWP(IBNDC,IBAWP,IBADT) ; updates AWP prices for NDCs
+1 ;
+2 NEW IBITEM,IBCS
+3 ;
+4 ;
+5 SET IBCS=$PIECE($GET(^IBE(350.9,1,9)),"^",12)
+6 IF 'IBCS
QUIT "0^Unable to find Charge Set"
+7 ;
+8 SET IBNDC=$$NDC^IBNCPNB(IBNDC)
+9 ;
+10 SET IBITEM=+$$ADDBI^IBCREF("NDC",IBNDC)
IF IBITEM
QUIT "0^Unable to add item"
+11 ;
+12 IF '$$ADDCI^IBCREF(IBCS,IBITEM,IBADT,IBAWP)
QUIT "0^Unable to add charge"
+13 ;
+14 QUIT 1
+15 ;
+16 ;
+17 ;
+18 ;
REVERSE(DFN,IBD,IBAUTO) ;process reversed claims
+1 NEW IBIFN,I,IB,IBIL,IBCHG,IBCRES,IBY,X,Y,DA,DIE,DR,IBADT,IBLOCK,IBLDT
+2 NEW IBNOW,IBDUZ,IBCR,IBRELC,IBCC,IBPAP,IBRXN,IBFIL,IBRTS,IBARES,IBUSR
+3 NEW IBLGL,IBLDT
+4 SET IBDUZ=.5
+5 SET IBLOCK=0
+6 ; find bill number
+7 IF 'DFN
SET IBY="0^No patient"
GOTO REVQ
+8 IF '$LENGTH($GET(IBD("CLAIMID")))
SET IBY="0^Missing ECME Number"
GOTO REVQ
+9 SET IBADT=+$GET(IBD("DOS"))
IF 'IBADT
SET IBY="0^Missing Date of Service"
GOTO REVQ
+10 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
IF 'IBRXN
SET IBY="0^No Rx IEN"
GOTO REVQ
+11 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
IF IBFIL<0
SET IBY="0^No fill number"
GOTO REVQ
+12 IF $EXTRACT($GET(IBD("RESPONSE")),1)="R"
Begin DoDot:1
+13 SET IBY="0^REVERSAL rejected by payer"
+14 SET IBRTS=$$RTS(IBD("REVERSAL REASON"))
End DoDot:1
if +'$GET(IBRTS)
GOTO REVQ
+15 ;
+16 ; cancel 1st party charge for TRICARE
DO CANC^IBNCPDP6(IBRXN_";"_IBFIL)
+17 ;
+18 SET IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT)
+19 LOCK +^DGCR(399,"AG",IBD("BCID")):15
IF '$TEST
SET IBY="0^Cannot lock ECME number"
GOTO REVQ
+20 SET IBLOCK=1
+21 SET IBUSR=$SELECT(+$GET(IBD("USER"))=0:DUZ,1:IBD("USER"))
+22 SET IBLDT=$$FMADD^XLFDT(DT,1)
FOR
SET IBLGL=$ORDER(^XTMP("IBNCPLDT"_IBLDT),-1)
SET IBLDT=$EXTRACT(IBLGL,9,15)
if IBLDT<$$FMADD^XLFDT(DT,-3)!(IBLGL'["IBNCPLDT")
QUIT
IF $DATA(^XTMP(IBLGL,IBD("BCID")))
SET ^(IBD("BCID"))=""
QUIT
+23 SET IBIFN=$$MATCH^IBNCPDP2(IBD("BCID"),$GET(IBD("RXCOB")))
+24 IF $DATA(IBD("CLOSE REASON"))
IF '$DATA(IBD("DROP TO PAPER"))
SET IBD("DROP TO PAPER")=""
+25 SET IBCR=+$GET(IBD("CLOSE REASON"))
+26 SET IBPAP=$GET(IBD("DROP TO PAPER"))
+27 SET IBRELC=$GET(IBD("RELEASE COPAY"))
+28 SET IBCC=$GET(IBD("CLOSE COMMENT"))
+29 DO NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,IBPAP,IBRELC,IBCC,IBUSR)
+30 IF 'IBIFN
SET IBY="0^"_$SELECT(IBPAP:"Dropped to paper",IBCR>1:"Set non-billable reason in CT",1:"Cannot find the bill to reverse")
GOTO REVQ
+31 ;
+32 FOR I=0,"S"
SET IB(I)=$GET(^DGCR(399,IBIFN,I))
+33 IF IB(0)=""
SET IBY="0^No data in bill"
GOTO REVQ
+34 IF +$PIECE(IB("S"),U,16)
IF $PIECE(IB("S"),U,17)]""
SET IBY="0^Bill already cancelled"
GOTO REVQ
+35 ;
+36 if '$DATA(IBCRES)
SET IBCRES="ECME PRESCRIPTION REVERSED"
+37 SET DA=IBIFN
SET DR="16////1;19////"_IBCRES
SET DIE="^DGCR(399,"
+38 DO ^DIE
KILL DA,DIE,DR
+39 ;
+40 ; - decrease out the receivable in AR
+41 SET IB("U1")=$GET(^DGCR(399,IBIFN,"U1"))
+42 SET IBIL=$PIECE($GET(^PRCA(430,IBIFN,0)),"^")
+43 SET IBCHG=$SELECT(IB("U1")']"":0,$PIECE(IB("U1"),"^",1)]"":$PIECE(IB("U1"),"^",1),1:0)
+44 ;
+45 SET X="21^"_IBCHG_"^"_IBIL_"^"_IBDUZ_"^"_DT_"^"_IBCRES
+46 DO ^PRCASER1
+47 SET IBARES=Y
+48 IF IBARES<0
SET IBY=IBARES
DO BULL
+49 ;
+50 SET IBY=$SELECT(IBARES<0:"0^"_$PIECE(IBARES,"^",2),1:1)
+51 ;
+52 ; set the real user
IF IBDUZ'=DUZ
Begin DoDot:1
+53 NEW IBI,IBT
SET IBI=18
SET IBT(399,IBIFN_",",IBI)=IBDUZ
DO FILE^DIE("","IBT")
End DoDot:1
+54 ;
REVQ ; perform end of job tasks
+1 DO LOG^IBNCPDP2($SELECT($GET(IBAUTO)=1:"AUTO REVERSE",$GET(IBAUTO)=2:"BILL CANCELLED",1:"REVERSE"),IBY)
+2 IF IBLOCK
LOCK -^DGCR(399,"AG",IBD("BCID"))
+3 IF IBY=1
IF $GET(IBIFN)
SET IBY=+IBIFN
+4 QUIT IBY
+5 ;
RTS(IBRR) ; Return to Stock processing on Released Rx
+1 ; input - IBRR = reversal reason
+2 ; IBCRSN = passed in by reference
+3 ; output - 0 = reversal not due to a Rx RETURN TO STOCK or Rx DELETE
+4 ; 1 = reversal due to a Rx RETURN TO STOCK or Rx DELETE
+5 ; IBCRSN = charge removal reason
+6 NEW IBTRKRN,IBLOCK2,IBCMT,DA,DIE,DR
+7 ;
+8 IF IBRR'="RX RETURNED TO STOCK"&(IBRR'="RX DELETED")
QUIT 0
+9 SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
+10 ; CT record does not exist
IF 'IBTRKRN
QUIT 0
+11 ; BILL does not exist
IF '$PIECE($GET(^IBT(356,IBTRKRN,0)),U,11)
QUIT 0
+12 ; recorded in file 399 entry
SET IBCRES=$$GETRSN(DFN,IBRXN,IBFIL)
+13 LOCK +^IBT(356,IBTRKRN):5
SET IBLOCK2=$TEST
+14 SET DIE="^IBT(356,"
SET DA=IBTRKRN
SET IBCMT="Rx RTS - May Need Refund"
+15 SET DR="1.08////"_IBCMT
+16 DO ^DIE
+17 IF IBLOCK2
LOCK -^IBT(356,IBTRKRN)
+18 QUIT 1
+19 ;
BULL ; Generate a bulletin if there is an error in cancelling the claim.
+1 NEW IBC,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
+2 ;
+3 SET IBPT=$$PT^IBEFUNC(DFN)
+4 SET XMSUB="ERROR ENCOUNTERED"
+5 SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="IBT("
+6 SET XMY(IBDUZ)=""
+7 SET XMY("G.IBCNR EPHARM")=""
+8 ;
+9 SET IBT(1)="An error occurred while cancelling the Pharmacy claim from ECME"
+10 SET IBT(2)="fiscal intermediary for the following patient:"
+11 SET IBT(3)=" "
SET IBC=3
+12 ; Accepts IBDUZ
DO PAT^IBAERR1
+13 SET IBC=IBC+1
SET IBT(IBC)=" Bill #: "_IBIL
+14 SET IBC=IBC+1
SET IBT(IBC)=" "
+15 SET IBC=IBC+1
SET IBT(IBC)="The following error was encountered:"
+16 SET IBC=IBC+1
SET IBT(IBC)=" "
+17 DO ERR^IBAERR1
+18 SET IBC=IBC+1
SET IBT(IBC)=" "
+19 SET IBC=IBC+1
SET IBT(IBC)="Please review the circumstances surrounding this error and decrease"
+20 SET IBC=IBC+1
SET IBT(IBC)="out this receivable in Accounts Receivable if necessary."
+21 DO ^XMD
+22 QUIT
+23 ;
GETRSN(DFN,IBRXN,IBFIL) ;
+1 ; retrieve charge removal reason from file 354.71
+2 ; input - DFN,IBRXN=Rx ien,IBFIL=fill number
+3 ; output - charge removal reason
+4 NEW IBDT,IBDA,IBXRSN,IBRXFIL,IB0
+5 SET (IBDT,IBDA)=0
SET IBXRSN=""
+6 SET IBRXFIL=$SELECT('IBFIL:IBRXN,1:IBRXN_";"_IBFIL)
+7 FOR
SET IBDT=$ORDER(^IBAM(354.71,"AD",DFN,IBDT))
if 'IBDT
QUIT
if IBXRSN]""
QUIT
Begin DoDot:1
+8 FOR
SET IBDA=$ORDER(^IBAM(354.71,"AD",DFN,IBDT,IBDA))
if 'IBDA
QUIT
if IBXRSN]""
QUIT
Begin DoDot:2
+9 SET IB0=^IBAM(354.71,IBDA,0)
+10 if $PIECE(IB0,"^",6)'[IBRXFIL
QUIT
+11 SET IBXRSN=$$GET1^DIQ(354.71,IBDA_",",.19)
End DoDot:2
End DoDot:1
+12 if IBXRSN']""
SET IBXRSN="CHARGE REMOVAL REASON NOT FOUND"
+13 QUIT "Reversal Rej, no pymt due<>"_IBXRSN
+14 ;
ELIG(DFN,IBD) ; process an Eligibility response
+1 NEW IBRES,ERACT,IDUZ,IBFDA,BPRIEN,IBUSR,IBCDFN,IBPL,IBERR,EPHSRC,INSIEN,BUDA,PTDA,PLDA,ICDA,BUFF,BPSR,ZR,BPRSUB,BPRGRP,IBNCPDPELIG
+2 SET IBRES=""
+3 IF '$GET(DFN)
SET IBRES="0^No patient - ELIG response"
GOTO ELIGX
+4 ; response file ien
SET BPRIEN=+$GET(IBD("RESPIEN"))
+5 ; DUZ of user
SET IBUSR=+$GET(IBD("USER"))
+6 ; pt. ins. policy subfile 2.312 ien
SET IBCDFN=+$GET(IBD("POLICY"))
+7 ; plan 355.3 ien
SET IBPL=+$GET(IBD("PLAN"))
+8 ;
+9 ; data integrity checks
+10 IF 'BPRIEN
SET IBRES="0^No BPS RESPONSES file ien"
GOTO ELIGX
+11 IF '$DATA(^BPSR(BPRIEN,0))
SET IBRES="0^No BPS RESPONSES file data exists for this ien"
GOTO ELIGX
+12 SET ZR=BPRIEN_","
+13 DO GETS^DIQ(9002313.03,ZR,"103;301;302","IEN","BPSR")
+14 IF $GET(BPSR(9002313.03,ZR,103,"E"))'="E1"
SET IBRES="0^BPS Response is not an E1 Transaction Code"
GOTO ELIGX
+15 IF 'IBCDFN
SET IBRES="0^No pt. policy ien"
GOTO ELIGX
+16 IF '$DATA(^DPT(DFN,.312,IBCDFN,0))
SET IBRES="0^Pt. insurance policy data not found"
GOTO ELIGX
+17 IF +$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),U,18)'=IBPL
SET IBRES="0^Mismatch on plan ien"
GOTO ELIGX
+18 ;
+19 ; IB*822/DJW - call gatekeeper if test acct and triggered from eIV appt ext
+20 IF $$CHECK^BPSTEST
DO E1^IBCNETST(DFN,BPRIEN)
+21 ;
+22 ;IB*822/CKB - get E1 buffer symbol
+23 NEW BPSSTAT,E1SYMBOL
SET (BPSSTAT,E1SYMBOL)=""
+24 ;TRANSACTION RESPONSE STATUS
SET BPSSTAT=$$GET1^DIQ(9002313.0301,"1,"_BPRIEN,112,"I")
+25 SET E1SYMBOL=$SELECT(BPSSTAT="A":"a1",BPSSTAT="R":"r1",1:"")
+26 ;get IEN of E1 symbol
SET E1SYMBOL=$$FIND1^DIC(365.15,,"MX",E1SYMBOL)
+27 ;
+28 ; build a buffer entry based primarily on the ins. policy in the pt. file
+29 KILL IBERR
+30 SET IDUZ=IBUSR
+31 ; special variable indicating to eIV where the buffer entry is coming from
SET IBNCPDPELIG=1
+32 ;
+33 ;IB*822/CKB - include symbol from E1 transaction (E1SYMBOL) when creating the Buffer
+34 ; - moved up from below: 1) added IBSOURCE and 2) changed "E-PHARMACY" to "EPHARMACY"
+35 NEW IBSOURCE
+36 ; source of information
SET (IBSOURCE,EPHSRC)=+$ORDER(^IBE(355.12,"C","EPHARMACY",0))
+37 IF 'EPHSRC
SET IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary"
GOTO ELIGX
+38 ; build and add buffer entry
DO PT^IBCNEBF(DFN,IBCDFN,E1SYMBOL,"",1,.IBERR)
+39 IF $GET(IBERR)'=""
SET IBRES="0^"_IBERR
GOTO ELIGX
+40 IF '$GET(IBFDA)
SET IBRES="0^No Buffer entry was created"
GOTO ELIGX
+41 IF '$DATA(^IBA(355.33,IBFDA,0))
SET IBRES="0^Buffer entry doesn't exist"
+42 ;IB*822/CKB - changed "E-PHARMACY" to "EPHARMACY"
+43 ; source of information
SET EPHSRC=+$ORDER(^IBE(355.12,"C","EPHARMACY",0))
+44 IF 'EPHSRC
SET IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary"
GOTO ELIGX
+45 SET INSIEN=+$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),U,1)
+46 IF 'INSIEN
SET IBRES="0^Insurance Company pointer not there"
GOTO ELIGX
+47 ;
+48 ; complete the buffer entry
+49 ; IENS for the buffer entry
SET BUDA=+IBFDA_","
+50 ; IENS for the pt. ins. policy subfile entry 2.312
SET PTDA=IBCDFN_","_DFN_","
+51 ; IENS for the plan entry 355.3
SET PLDA=IBPL_","
+52 ; IENS for the insurance company entry 36
SET ICDA=INSIEN_","
+53 ;
+54 ;IB*822/CKB - removed adding the addt'l fields to the buffer as they are not coming from the Payer
+55 ;S BUFF(355.33,BUDA,60.1)=$$GET1^DIQ(2.312,PTDA,4.01,"I")
+56 ;S BUFF(355.33,BUDA,60.11)=$$GET1^DIQ(2.312,PTDA,4.02,"I")
+57 ;
+58 ;S BUFF(355.33,BUDA,40.01)=$$GET1^DIQ(355.3,PLDA,.02,"I")
+59 ;S BUFF(355.33,BUDA,40.04)=$$GET1^DIQ(355.3,PLDA,.05,"I")
+60 ;S BUFF(355.33,BUDA,40.05)=$$GET1^DIQ(355.3,PLDA,.06,"I")
+61 ;S BUFF(355.33,BUDA,40.06)=$$GET1^DIQ(355.3,PLDA,.12,"I")
+62 ;S BUFF(355.33,BUDA,40.07)=$$GET1^DIQ(355.3,PLDA,.07,"I")
+63 ;S BUFF(355.33,BUDA,40.08)=$$GET1^DIQ(355.3,PLDA,.08,"I")
+64 ;S BUFF(355.33,BUDA,40.09)=$$GET1^DIQ(355.3,PLDA,.09,"I")
+65 ;S BUFF(355.33,BUDA,40.1)=$$GET1^DIQ(355.3,PLDA,6.02,"I")
+66 ;S BUFF(355.33,BUDA,40.11)=$$GET1^DIQ(355.3,PLDA,6.03,"I")
+67 ;
+68 ;S BUFF(355.33,BUDA,20.02)=$$GET1^DIQ(36,ICDA,.131,"I")
+69 ;S BUFF(355.33,BUDA,20.05)=$$GET1^DIQ(36,ICDA,1,"I")
+70 ;S BUFF(355.33,BUDA,21.01)=$$GET1^DIQ(36,ICDA,.111,"I")
+71 ;S BUFF(355.33,BUDA,21.02)=$$GET1^DIQ(36,ICDA,.112,"I")
+72 ;S BUFF(355.33,BUDA,21.03)=$$GET1^DIQ(36,ICDA,.113,"I")
+73 ;S BUFF(355.33,BUDA,21.04)=$$GET1^DIQ(36,ICDA,.114,"I")
+74 ;S BUFF(355.33,BUDA,21.05)=$$GET1^DIQ(36,ICDA,.115,"I")
+75 ;S BUFF(355.33,BUDA,21.06)=$$GET1^DIQ(36,ICDA,.116,"I")
+76 ;
+77 ; update buffer entry with some additional information
+78 ;IB*822/CKB - commented out the following lines of code as they are being set unneccessarily
+79 ; this overwrites a valid value - S BUFF(355.33,BUDA,.03)=EPHSRC ; source of info
+80 ;S BUFF(355.33,BUDA,.12)="" ; make sure eIV related fields are blank
+81 ;S BUFF(355.33,BUDA,.13)=""
+82 ;S BUFF(355.33,BUDA,.14)=""
+83 ; IB*822/CKB - changed from "" (setting IIV PDATE on purpose)
SET BUFF(355.33,BUDA,.15)=$$NOW^XLFDT
+84 ; BPS response file ien
SET BUFF(355.33,BUDA,.17)=BPRIEN
+85 ;
+86 ; update buffer entry with data pulled from BPS response file
+87 ; only 2 fields are applicable here: group# and cardholder ID
+88 ;
+89 ; group number
SET BPRGRP=$GET(BPSR(9002313.03,ZR,301,"E"))
+90 ;I BPRGRP'="" S BUFF(355.33,BUDA,40.03)=BPRGRP ; update buffer if field exists
+91 ; update new field - 516 - baa
IF BPRGRP'=""
SET BUFF(355.33,BUDA,90.02)=BPRGRP
+92 ;
+93 ; subscriber/cardholder ID
SET BPRSUB=$GET(BPSR(9002313.03,ZR,302,"E"))
+94 ;I BPRSUB'="" S BUFF(355.33,BUDA,60.04)=BPRSUB ; update buffer if field exists
+95 ; update new field - 516 - baa
IF BPRSUB'=""
SET BUFF(355.33,BUDA,90.03)=BPRSUB
+96 ;
+97 DO FILE^DIE(,"BUFF")
+98 ;
+99 ;IB*822/CKB - call to add tracking the E1 transactions
+100 DO EIVE1LOG
+101 ;
+102 ; all good
SET IBRES=1
+103 ;
ELIGX ;
+1 QUIT IBRES
+2 ;
EIVE1LOG ;IB*822/CKB - Add to EIV E1 TRANSACTION RESPONSE LOG file #365.3
+1 NEW E1IEN,E1LOG,IBDATA,IBERR,IBFILE,IBIEN,IBIENS
+2 SET IBFILE=365.3
+3 ;
+4 ;IEN of PATIENT file #2
SET IBDATA(.01)=DFN
+5 ;Date/Time response received
SET IBDATA(.02)=$$NOW^XLFDT
+6 ;IEN of BPS RESPONSE file #9002313.03
SET IBDATA(.03)=BPRIEN
+7 ;Add/create entry in file #365.3
+8 SET E1IEN=$$ADD^IBDFDBS(IBFILE,,.IBDATA,.IBERR,.IBIEN)
+9 ; W "Unable to add entry, "_IBERR
IF 'E1IEN
IF ('IBIEN)
QUIT
+10 KILL IBDATA
SET IBERR=""
+11 ;
+12 ;IBIENS=IEN for file #365.3 - add other info to file
+13 SET IBIENS=E1IEN
if IBIENS=""
SET IBIENS=IBIEN
SET IBIENS=IBIENS_","
+14 ;Transaction Status
SET E1LOG(365.3,IBIENS,.04)=$$GET1^DIQ(9002313.0301,"1,"_BPRIEN,112,"I")
+15 ;IEN of Buffer file #355.33
SET E1LOG(365.3,IBIENS,.05)=IBFDA
+16 ;prevent from purging
SET E1LOG(365.3,IBIENS,.06)=0
+17 ;IEN of PATIENT INSURANCE subfile #2.312
SET E1LOG(365.3,IBIENS,1.1)=IBCDFN
+18 ;IEN of INSURANCE file #36
SET E1LOG(365.3,IBIENS,1.2)=INSIEN
+19 ;Insurance Company Name
SET E1LOG(365.3,IBIENS,1.3)=$$GET1^DIQ(36,ICDA,.01)
+20 ;IEN of GROUP PLAN file #355.3
SET E1LOG(365.3,IBIENS,1.4)=IBPL
+21 ;Group Number
SET E1LOG(365.3,IBIENS,1.5)=$$GET1^DIQ(355.33,BUDA,90.02)
+22 ;Subscriber ID
SET E1LOG(365.3,IBIENS,1.6)=$$GET1^DIQ(355.33,BUDA,90.03)
+23 DO FILE^DIE(,"E1LOG")
+24 KILL E1LOG
+25 QUIT
+26 ;IBNCPDP3
