- 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 Jan 18, 2025@03:25:50 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