IBNCPDP3 ;OAK/ELZ - STORES NDC/AWP UPDATES ;11/14/07 13:18
;;2.0;INTEGRATED BILLING;**223,276,342,363,383,384,411,435,452,516,647**;21-MAR-94;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to ^PRCASER1 supported by IA# 593
; Reference to BPS RESPONSES file (#9002313.03) supported by IA# 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
;
; 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
D PT^IBCNEBF(DFN,IBCDFN,"","",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" G ELIGX
S EPHSRC=+$O(^IBE(355.12,"C","E-PHARMACY",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
;
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
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)=""
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 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
;
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
;
D FILE^DIE(,"BUFF")
;
S IBRES=1 ; all good
;
ELIGX ;
Q IBRES
;
;IBNCPDP3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP3 10026 printed Oct 16, 2024@18:25:16 Page 2
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
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to ^PRCASER1 supported by IA# 593
+5 ; Reference to BPS RESPONSES file (#9002313.03) supported by IA# 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 ; build a buffer entry based primarily on the ins. policy in the pt. file
+20 KILL IBERR
+21 SET IDUZ=IBUSR
+22 ; special variable indicating to eIV where the buffer entry is coming from
SET IBNCPDPELIG=1
+23 ; build and add buffer entry
DO PT^IBCNEBF(DFN,IBCDFN,"","",1,.IBERR)
+24 IF $GET(IBERR)'=""
SET IBRES="0^"_IBERR
GOTO ELIGX
+25 IF '$GET(IBFDA)
SET IBRES="0^No Buffer entry was created"
GOTO ELIGX
+26 IF '$DATA(^IBA(355.33,IBFDA,0))
SET IBRES="0^Buffer entry doesn't exist"
GOTO ELIGX
+27 ; source of information
SET EPHSRC=+$ORDER(^IBE(355.12,"C","E-PHARMACY",0))
+28 IF 'EPHSRC
SET IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary"
GOTO ELIGX
+29 SET INSIEN=+$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),U,1)
+30 IF 'INSIEN
SET IBRES="0^Insurance Company pointer not there"
GOTO ELIGX
+31 ;
+32 ; complete the buffer entry
+33 ; IENS for the buffer entry
SET BUDA=+IBFDA_","
+34 ; IENS for the pt. ins. policy subfile entry 2.312
SET PTDA=IBCDFN_","_DFN_","
+35 ; IENS for the plan entry 355.3
SET PLDA=IBPL_","
+36 ; IENS for the insurance company entry 36
SET ICDA=INSIEN_","
+37 ;
+38 SET BUFF(355.33,BUDA,60.1)=$$GET1^DIQ(2.312,PTDA,4.01,"I")
+39 SET BUFF(355.33,BUDA,60.11)=$$GET1^DIQ(2.312,PTDA,4.02,"I")
+40 ;
+41 SET BUFF(355.33,BUDA,40.01)=$$GET1^DIQ(355.3,PLDA,.02,"I")
+42 SET BUFF(355.33,BUDA,40.04)=$$GET1^DIQ(355.3,PLDA,.05,"I")
+43 SET BUFF(355.33,BUDA,40.05)=$$GET1^DIQ(355.3,PLDA,.06,"I")
+44 SET BUFF(355.33,BUDA,40.06)=$$GET1^DIQ(355.3,PLDA,.12,"I")
+45 SET BUFF(355.33,BUDA,40.07)=$$GET1^DIQ(355.3,PLDA,.07,"I")
+46 SET BUFF(355.33,BUDA,40.08)=$$GET1^DIQ(355.3,PLDA,.08,"I")
+47 SET BUFF(355.33,BUDA,40.09)=$$GET1^DIQ(355.3,PLDA,.09,"I")
+48 SET BUFF(355.33,BUDA,40.1)=$$GET1^DIQ(355.3,PLDA,6.02,"I")
+49 SET BUFF(355.33,BUDA,40.11)=$$GET1^DIQ(355.3,PLDA,6.03,"I")
+50 ;
+51 SET BUFF(355.33,BUDA,20.02)=$$GET1^DIQ(36,ICDA,.131,"I")
+52 SET BUFF(355.33,BUDA,20.05)=$$GET1^DIQ(36,ICDA,1,"I")
+53 SET BUFF(355.33,BUDA,21.01)=$$GET1^DIQ(36,ICDA,.111,"I")
+54 SET BUFF(355.33,BUDA,21.02)=$$GET1^DIQ(36,ICDA,.112,"I")
+55 SET BUFF(355.33,BUDA,21.03)=$$GET1^DIQ(36,ICDA,.113,"I")
+56 SET BUFF(355.33,BUDA,21.04)=$$GET1^DIQ(36,ICDA,.114,"I")
+57 SET BUFF(355.33,BUDA,21.05)=$$GET1^DIQ(36,ICDA,.115,"I")
+58 SET BUFF(355.33,BUDA,21.06)=$$GET1^DIQ(36,ICDA,.116,"I")
+59 ;
+60 ; update buffer entry with some additional information
+61 ; source of info
SET BUFF(355.33,BUDA,.03)=EPHSRC
+62 ; make sure eIV related fields are blank
SET BUFF(355.33,BUDA,.12)=""
+63 SET BUFF(355.33,BUDA,.13)=""
+64 SET BUFF(355.33,BUDA,.14)=""
+65 SET BUFF(355.33,BUDA,.15)=""
+66 ; BPS response file ien
SET BUFF(355.33,BUDA,.17)=BPRIEN
+67 ;
+68 ; update buffer entry with data pulled from BPS response file
+69 ; only 2 fields are applicable here: group# and cardholder ID
+70 ;
+71 ; subscriber/cardholder ID
SET BPRSUB=$GET(BPSR(9002313.03,ZR,302,"E"))
+72 ;I BPRSUB'="" S BUFF(355.33,BUDA,60.04)=BPRSUB ; update buffer if field exists
+73 ; update new field - 516 - baa
IF BPRSUB'=""
SET BUFF(355.33,BUDA,90.03)=BPRSUB
+74 ;
+75 ; group number
SET BPRGRP=$GET(BPSR(9002313.03,ZR,301,"E"))
+76 ;I BPRGRP'="" S BUFF(355.33,BUDA,40.03)=BPRGRP ; update buffer if field exists
+77 ; update new field - 516 - baa
IF BPRGRP'=""
SET BUFF(355.33,BUDA,90.02)=BPRGRP
+78 ;
+79 DO FILE^DIE(,"BUFF")
+80 ;
+81 ; all good
SET IBRES=1
+82 ;
ELIGX ;
+1 QUIT IBRES
+2 ;
+3 ;IBNCPDP3
