BPSBUTL ;BHAM ISC/MFR/VA/DLF - IB Communication Utilities ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7,8,9,10,11,15,20,24,31**;JUN 2004;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;Reference to STORESP^IBNCPDP supported by DBIA 4299
Q
;
;CLAIM - pointer to #9002313.02
;TRNDX - ptr to #9002313.59
;REASON - text name of the close reason
;PAPER - 1=drop to paper
;RELCOP - 1 (Yes) or 0 (No) release copay or not?
;COMMENT - comment
;ERROR - array by reference for error details
;BPSCLO - 1 indicates call coming from ECME User Screen action CLO
;
CLOSE(CLAIM,TRNDX,REASON,PAPER,RELCOP,COMMENT,ERROR,BPSCLO) ; Send IB an update on the CLAIM status for a Closed Claim
N DFN,BPSARRY,BILLNUM,CLAIMNFO,FILLNUM,RXIEN,TRANINFO
;
; - Data gathering
D GETS^DIQ("9002313.59",TRNDX,"1.11;9","I","TRANINFO")
S RXIEN=TRANINFO(9002313.59,TRNDX_",",1.11,"I")
I $$RXAPI1^BPSUTIL1(RXIEN,.01)="" S ERROR="Prescription not found." Q
S BPSARRY("FILL NUMBER")=TRANINFO(9002313.59,TRNDX_",",9,"I")
D GETS^DIQ("9002313.02",CLAIM,"400*;401;402;403;426","","CLAIMNFO")
S BPSARRY("DOS")=$G(CLAIMNFO("9002313.02",CLAIM_",","401"))
I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000
S FILLNUM=+BPSARRY("FILL NUMBER")
S DFN=$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
S BPSARRY("FILLED BY")=$$RXAPI1^BPSUTIL1(RXIEN,16,"I")
S BPSARRY("PRESCRIPTION")=RXIEN
S BPSARRY("BILLED")=$$DFF2EXT^BPSECFM($P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","426"),"DQ",2))
S BPSARRY("CLAIMID")=$P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","402"),"D2",2)
S BPSARRY("PLAN")=$P(^BPST(TRNDX,10,1,0),"^")
S BPSARRY("STATUS")="CLOSED"
S BPSARRY("PAID")=0
S BPSARRY("RELEASE DATE")=$S(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I"))
I $G(BPSCLO) S BPSARRY("USER")=DUZ
E S BPSARRY("USER")=$$GET1^DIQ(9002313.59,TRNDX,13,"I")
S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,TRNDX,1.07,"I")
S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(TRNDX)
I REASON'="" D
. S BPSARRY("CLOSE REASON")=$O(^IBE(356.8,"B",REASON,0))
. S BPSARRY("DROP TO PAPER")=+$G(PAPER)
. S BPSARRY("RELEASE COPAY")=+$G(RELCOP)
I $G(COMMENT)]"" S BPSARRY("CLOSE COMMENT")=COMMENT
;
; If dropped to Paper, increment the counter in BPS Statistics
I BPSARRY("DROP TO PAPER")=1 D INCSTAT^BPSOSUD("R",8)
;
; Call IB
S BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY)
Q
; Send IB an update on the CLAIM status for a restocked or deleted prescription
CLOSE2(RXIEN,BFILL,BWHERE) ;
N IEN59,BPSARRY,DFN,BILLNUM,FILL,REASON
N CLAIMNFO
N DIE,DA,DR
;
; Check parameters
I '$G(RXIEN) S ERROR="No prescription parameter" Q
I $G(BFILL)="" S ERROR="No fill parameter" Q
I $G(BWHERE)="" S ERROR="No RX Action parameter" Q
;
I $$RXAPI1^BPSUTIL1(RXIEN,.01)="" S ERROR="Prescription not found." Q
I ",DE,RS,"'[(","_BWHERE_",") S ERROR="Invalid BWHERE parameter" Q
;
; Calculate the transaction IEN and see that it exists
S IEN59=$$IEN59^BPSOSRX(RXIEN,BFILL,1)
I '$D(^BPST(IEN59,0)) Q
;
; Get claim data
S CLAIM=$P(^BPST(IEN59,0),"^",4)
I 'CLAIM S ERROR="Claim not found in BPS Transaction" Q
D GETS^DIQ("9002313.02",CLAIM,"400*;401;402;426","","CLAIMNFO")
S BPSARRY("FILL NUMBER")=+BFILL
S BPSARRY("DOS")=$G(CLAIMNFO("9002313.02",CLAIM_",","401"))
I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000
;
; Get prescription data
S FILLNUM=BPSARRY("FILL NUMBER")
S DFN=$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
S BPSARRY("FILLED BY")=$$RXAPI1^BPSUTIL1(RXIEN,16,"I")
S BPSARRY("PRESCRIPTION")=RXIEN
S BPSARRY("BILLED")=$$DFF2EXT^BPSECFM($P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","426"),"DQ",2))
S BPSARRY("CLAIMID")=$P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","402"),"D2",2)
S BPSARRY("PLAN")=$P(^BPST(IEN59,10,1,0),"^")
S BPSARRY("STATUS")="CLOSED"
S BPSARRY("PAID")=0
S BPSARRY("RELEASE DATE")=$S(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I"))
S BPSARRY("USER")=.5
S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,IEN59,1.07,"I")
S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(IEN59)
;
; Determine the reversal reason based on the BWHERE value
I BWHERE="RS" S REASON="PRESCRIPTION NOT RELEASED"
I BWHERE="DE" S REASON="PRESCRIPTION DELETED"
I REASON]"" S BPSARRY("CLOSE REASON")=$O(^IBE(356.8,"B",REASON,0))
;
;if a refill was deleted while RX is still active (not deleted) then send DELETION OF REFILL comment for CT record
I BWHERE="DE",$$RXSTATUS^BPSSCRU2(RXIEN)'=13 S BPSARRY("CLOSE COMMENT")="DELETION OF REFILL ONLY - ORIGINAL RX MAY REMAIN ACTIVE"
;
;
; Update IB
S BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY)
;
; Update the claim file that the claim is closed and the reason why.
S DIE="^BPSC(",DA=CLAIM
S DR="901///1;902///"_$$NOW^XLFDT()_";903////.5;904///"_BPSARRY("CLOSE REASON")
D ^DIE
;
; If this is a primary claim, check and send a bulletin if the secondary claim is open or if there
; is a non-cancelled IB bill for the secondary claim
I BPSARRY("RXCOB")=1 D BULL^BPSECMP2(RXIEN,BFILL,CLAIM,DFN,REASON,BPSARRY("CLAIMID"))
Q
;
; Function to return Transaction, claim, and response IENs
; Parameters:
; RXI: Prescription IEN
; RXR: Fill Number
; COB: COB Indicator
; Returns:
; IEN59^Claim IEN^Response IEN^Reversal Claim IEN^Reversal Response IEN^Prescription/Service Ref Number from BPS CLAIMS file
CLAIM(RXI,RXR,COB) ;
N IEN59,CLAIMIEN,RESPIEN,REVCLAIM,REVRESP,ECMENUM
I '$G(RXI) Q ""
; Note that IEN59 will treat RXR="" as the original fill (0)
; and COB="" as primary (1)
S IEN59=$$IEN59^BPSOSRX(RXI,$G(RXR),$G(COB))
I '$D(^BPST(IEN59,0)) Q ""
S CLAIMIEN=$P(^BPST(IEN59,0),"^",4),RESPIEN=$P(^BPST(IEN59,0),"^",5)
S REVCLAIM=$P($G(^BPST(IEN59,4)),"^",1),REVRESP=$P($G(^BPST(IEN59,4)),"^",2)
S ECMENUM=$$ECMENUM^BPSSCRU2(IEN59)
Q IEN59_U_CLAIMIEN_U_RESPIEN_U_REVCLAIM_U_REVRESP_U_ECMENUM
;
; NABP - Return the value in the Service Provider ID (201-B1) field
; of the claim. Note that as of the NPI release (BPS*1*2), this
; API may return NPI instead of NABP/NCPDP
NABP(RXP,BFILL) ;
I '$G(RXP) Q ""
I $G(BFILL)="" S BFILL=0
N BPSTIEN,BPSCIEN,DFILL,NABP
S DFILL=$E($TR($J("",4-$L(BFILL))," ","0")_BFILL,1,4)
S BPSTIEN=RXP_"."_DFILL_"1"
I 'BPSTIEN Q ""
S BPSCIEN=$P($G(^BPST(BPSTIEN,0)),U,4)
I 'BPSCIEN Q ""
S NABP=$P($G(^BPSC(BPSCIEN,200)),U)
Q NABP
;
; DIVNCPDP - For a specific outpatient site, return the NPI & NCPDP.
; Note that the procedure name is misleading but when originally
; coded, this procedure only returned NCPDP.
;
; Input
; BPSDIV - Outpatient Site (#59)
; Output
; "" - No BPSDIV passed in
; NCPDP and NPI separated by a caret
DIVNCPDP(BPSDIV) ;
N BPSPHARM,NPI,NCPDP
I '$G(BPSDIV) Q "^"
;
; Get the NCPDP
S NCPDP=""
S BPSPHARM=$$GETPHARM^BPSUTIL(BPSDIV)
I BPSPHARM S NCPDP=$$GET1^DIQ(9002313.56,BPSPHARM_",",.02)
;
; Get the NPI and validate it
S NPI=+$$NPI^BPSNPI("Pharmacy_ID",BPSDIV)
I NPI=-1 S NPI=""
;
Q NCPDP_"^"_NPI
;
;ADDCOMM - Add a comment to a ECME claim
;Input:
; BPRX - ien in file #52
; BPREF - refill number (0,1,2,...)
; BPRCMNT - comment text
;Output:
; 1 - okay
; -1 - failed
ADDCOMM(BPRX,BPREF,BPRCMNT,BPBKG) ;
;
;BPRX (required) - Prescription IEN
;BPREF (optional) - Refill number
;BPRCMNT (required) - Comment text
;BPBKG (optional) - Value 1 indicates process is running in background - BPS*1*15
;
N IEN59,BPNOW,BPREC,BPDA,BPERR
; Check parameters
I '$G(BPRX) Q -1
I $G(BPRCMNT)="" Q -1
; Get BPS Transaction number, if needed, and check for existance
S IEN59=$$IEN59^BPSOSRX(BPRX,$G(BPREF),1)
I IEN59="" Q -1
I '$D(^BPST(IEN59)) Q -1
; Lock record and quit if you cannot get the lock
L +^BPST(9002313.59111,+IEN59):10
I '$T Q -1
; Create record and file data
S BPNOW=$$NOW^XLFDT
D INSITEM^BPSCMT01(9002313.59111,+IEN59,BPNOW)
S BPREC=$O(^BPST(IEN59,11,"B",BPNOW,99999999),-1)
I BPREC>0 D
.;If BPBKG is passed this is a background process and user is POSTMASTER - BPS*1*15
. S BPDA(9002313.59111,BPREC_","_IEN59_",",.02)=$S($G(BPBKG):.5,1:+$G(DUZ))
. S BPDA(9002313.59111,BPREC_","_IEN59_",",.03)=$E($G(BPRCMNT),1,63)
. D FILE^DIE("","BPDA","BPERR")
L -^BPST(9002313.59111,+IEN59)
; Quit with result
I BPREC>0,'$D(BPERR) Q 1
Q -1
;
;REOPEN - Reopen closed claim
;Input:
; BP59 - ien in BPS TRANSACTION file
; BP02 - ien in BPS CLAIMS file
; BPREOPDT - reopen date/time
; BPDUZ - user DUZ (#200 ien)
; BPCOMM - reopen comment text
;Output:
; 0^message_error - error
; 1 - success
REOPEN(BP59,BP02,BPREOPDT,BPDUZ,BPCOMM) ;
N RECIENS,BPDA,ERRARR,BPREFNO,BPRXIEN,BPZ,BPSARRY,BPDFN,BPRETVAL,BPZ1
S BPDFN=$P($G(^BPST(BP59,0)),U,6)
S BPREFNO=$P($G(^BPST(BP59,1)),U)
I BPREFNO="" Q "0^Null Fill Number"
S BPRXIEN=$P($G(^BPST(BP59,1)),U,11)
I BPRXIEN="" Q "0^Null RX ien Number"
;in VA there is only one med/claim but in some cases it can different than "1"
;so take the latest one
S BPZ=$O(^BPSC(BP02,400,9999999),-1)
I BPRXIEN="" Q "0^Database Error"
;============
;Now update ECME database
S BPRETVAL=$$UPDREOP^BPSREOP1(BP02,0,BPREOPDT,BPDUZ,BPCOMM)
I +BPRETVAL=0 D Q BPRETVAL
. ;try to reverse it in case it was done partially
. I $$UPDREOP^BPSREOP1(BP02,1,"@",+BPDUZ,"@")
;============
;Now call IB API for "REOPEN" event
S BPSARRY("STATUS")="REOPEN"
S BPSARRY("DOS")=$P($G(^BPSC(BP02,401)),U)
I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000
S BPSARRY("FILL NUMBER")=BPREFNO
S BPSARRY("PRESCRIPTION")=BPRXIEN
S BPSARRY("CLAIMID")=$$CONVCLID^BPSSCRU6($P($G(^BPSC(BP02,400,+BPZ,400)),U,2))
S BPSARRY("DRUG")=$$DRUGIEN^BPSSCRU6(BPRXIEN,BPDFN)
S BPSARRY("PLAN")=$P($G(^BPST(BP59,10,1,0)),"^")
S BPSARRY("USER")=BPDUZ
S BPSARRY("REOPEN COMMENT")=BPCOMM
S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,BP59,1.07,"I")
S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(BP59)
S BPRETVAL=$$STORESP^IBNCPDP(BPDFN,.BPSARRY)
;if successful
I +BPRETVAL>0 Q "1^ReOpening Claim: "_$P($G(^BPSC(BP02,0)),U)_" ... OK"
;===========
;if it was unsuccessful
;reverse ECME database (keep the user who made the attempt)
I $$UPDREOP^BPSREOP1(BP02,1,"@",+BPDUZ,"@")
;return IB error message
Q BPRETVAL
;
GETDAT(RX,FIL,COB,LDOS,LDSUP) ;Returns Last Date of Service and Last Days Supply
;Input:
; RX (req) --> RX IEN
; FIL (req) --> Fill number
; COB (opt) --> Coordination of Benifits indicator; default is 1
;Output:
; LDOS --> Last Date of Service
; LDSUP --> Last Days Supply
;
Q:'($G(RX))!($G(FIL)="")
S:'$G(COB) COB=1
N IEN59,IEN02,STAT,IEN57
S IEN02=""
S IEN59=$$IEN59^BPSOSRX(RX,FIL,COB)
S STAT=$P($G(^BPST(IEN59,0)),U,2)
I STAT=99 S IEN02=$P($G(^BPST(IEN59,0)),U,4)
I IEN02="" D
. S IEN57=""
. F S IEN57=$O(^BPSTL("B",IEN59,IEN57),-1) Q:IEN57=""!(IEN02) D
.. S STAT=$P($G(^BPSTL(IEN57,0)),U,2)
.. I STAT=99 S IEN02=$P($G(^BPSTL(IEN57,0)),U,4)
I 'IEN02 S (LDOS,LDSUP)="" Q
S LDOS=$$GET1^DIQ(9002313.02,IEN02,401,"E") ;LAST DATE OF SERVICE
I LDOS S LDOS=LDOS-17000000 ;CONVERT DATE TO FILEMAN FORMAT
S LDSUP=$$GET1^DIQ(9002313.0201,"1,"_IEN02,405,"I") ;LAST DAYS SUPPLY
I LDSUP'="" S LDSUP=+$E(LDSUP,3,99) ; remove the "D5" NCPDP field ID (bps*1*15)
Q
;
NFLDT(RX,FIL,COB) ;Returns Next Avail Fill Date (B04-BT) from ECME - BPS*1.0*15
;Input:
; RX (req) --> RX IEN
; FIL (req) --> Fill number
; COB (opt) --> Coordination of Benefits indicator; default is 1
;Output:
; NFLDT --> Next Avail Fill Date
Q:'$G(RX)!($G(FIL)="") ""
S:'$G(COB) COB=1
N IEN59,IEN02,STAT,NFLDT,IEN03
S IEN02=""
S IEN59=$$IEN59^BPSOSRX(RX,FIL,COB)
S IEN03=+$P($G(^BPST(IEN59,0)),U,5),NFLDT=""
S:IEN03 NFLDT=$$GET1^DIQ(9002313.0301,"1,"_IEN03,2004,"I") ;NEXT FILL DATE
S:NFLDT NFLDT=NFLDT-17000000 ;CONVERT DATE TO FILEMAN FORMAT
Q NFLDT
;
BBILL(RX,RFILL,COB) ;Return Back Bill Indicator for Pharmacy - BPS*1.0*15
N IEN59,RXACT
;Return 0 if no RXI value input
I '$G(RX) Q 0
; Note that $$IEN59 will treat RFILL="" as the original fill (0)
S IEN59=$$IEN59^BPSOSRX(RX,$G(RFILL),$G(COB))
;No transaction found return 0
I '$D(^BPST(IEN59,0)) Q 0
;Determine if RX ACTION (field #1201) is Back Bill
S RXACT=$P($G(^BPST(IEN59,12)),U)
;Back Bill code not found return 0
I RXACT'="BB",RXACT'="P2",RXACT'="P2S" Q 0
;Otherwise return Back Bill indicator
Q 1
;
AMT(RX,FIL,COB) ; Return Gross Amount Due - BPS*1*15
; RX - rx ien
; FIL - fill#, defaults to original fill if not passed in
; COB - cob payer sequence, defaults to 1 if not passed in
;
N AMT,IEN59,QN
S AMT=""
I '$G(RX) G AMTX
S IEN59=$$IEN59^BPSOSRX(RX,$G(FIL),$G(COB)) ; ien to BPS Transaction file
I '$D(^BPST(IEN59,0)) G AMTX ; make sure it exists
S QN=+$O(^BPST(IEN59,10,0)) I 'QN G AMTX ; get 9002313.59902 subfile ien
S AMT=+$P($G(^BPST(IEN59,10,QN,2)),U,4) ; gross amount due, field 902.15
AMTX ;
Q AMT
;
ELIG(RX,FIL,COB) ; Veteran Eligibility - BPS*1*15
; RX - rx ien
; FIL - fill#, defaults to original fill if not passed in
; COB - cob payer sequence, defaults to 1 if not passed in
;
Q:'$G(RX) ""
; ien to BPS Transaction file
N IEN59 S IEN59=$$IEN59^BPSOSRX(RX,$G(FIL),$G(COB)) Q:'IEN59 ""
Q:'$D(^BPST(IEN59,0)) ""
; ELIGIBILITY field 901.04
Q $P($G(^BPST(IEN59,9)),U,4)
;
GETBAMT(RXIEN,FILL,COB) ; Retrieve the billed amount
; RXIEN = Prescription ien (required)
; FILL# = Fill Number (optional, defaults to latest fill)
; COB = Coordination of Benefits (optional, defaults to 1)
N X,BAMT,CLAIMIEN
S X=$$CLAIM(RXIEN,$G(FILL),$G(COB))
S CLAIMIEN=$P(X,U,2)
S BAMT=$$TOTPRICE^BPSSCRLG(CLAIMIEN)
Q BAMT
;
RESUBMIT(RX,REFILL,COB) ; Return Resubmit indicator for Pharmacy - BPS*1*20.
N BPSIEN59,BPSRXACT
I '$G(RX) Q 0
;
; Determine BPS Transaction number. If none, Quit with '0'.
;
S BPSIEN59=$$IEN59^BPSOSRX(RX,$G(REFILL),$G(COB))
I 'BPSIEN59 Q 0
I '$D(^BPST(BPSIEN59,0)) Q 0
;
; Pull the RX Action from the BPS Transaction. If it's not one that
; indicates resubmission from the ECME User Screen, then Quit with
; '0'. Otherwise, Quit with '1'.
;
S BPSRXACT=$$GET1^DIQ(9002313.59,BPSIEN59_",",1201)
I ",ERES,ERWV,ERNB,"'[(","_BPSRXACT_",") Q 0
Q 1
;
GETCOB(RXIEN,FILL) ; Retrieve the COB payer sequence for usage by PSO
; Input: RXIEN and FILL (both are required)
; Output: Function value will be one of the following
; "" (if the prescription fill cannot be found in BPS Transaction)
; -1 (when there are multiple COB's/payers found in BPS Transaction)
; Otherwise,
; COB#^BPS Transaction IEN
N RET,PRI59,SEC59
S RET=""
I '$G(RXIEN) G GETCOBX
I $G(FILL)="" G GETCOBX
;
S PRI59=+$$IEN59^BPSOSRX(RXIEN,FILL,1) ; possible primary BPS transaction ien
S SEC59=+$$IEN59^BPSOSRX(RXIEN,FILL,2) ; possible secondary BPS transaction ien
;
I $D(^BPST(PRI59)),$D(^BPST(SEC59)) S RET=-1 G GETCOBX ; both payers exist, get out
I $D(^BPST(PRI59)) S RET=1_U_PRI59 G GETCOBX
I $D(^BPST(SEC59)) S RET=2_U_SEC59 G GETCOBX
;
GETCOBX ;
Q RET
;
ADDFLDS(RX,FIL,COB) ;Returns Additional NCPDP fields from ECME
;Input:
; RX (req) --> RX IEN
; FIL (req) --> Fill number
; COB (req) --> 1=Primary, 2=Secondary, 3=Tertiary
;Output:
; BPSREC --> a string separated by "^" containing the output of the BPSARR array
;
Q:'$G(RX)!($G(FIL)="") ""
N BPSAMT,BPSARR,BPSCNT,BPSEDT,BPSFLDS,BPSREC,BPSSDT,IEN03,IEN59
;
S IEN59=$$IEN59^BPSOSRX(RX,FIL,COB)
S IEN03=+$P($G(^BPST(IEN59,0)),U,5)
;
I '$G(IEN03) Q "" ; Quit if INE03 is not found
;
S BPSFLDS="931;932;933;934;935;936;937;938;943;944;2219;2220;2224;2225"
D GETS^DIQ(9002313.0301,"1,"_IEN03,BPSFLDS,"IE","BPSARR")
;
S BPSREC="",BPSCNT=0
F I=1:1:$L(BPSFLDS,";") S BPSCNT=BPSCNT+1 D
. S $P(BPSREC,U,BPSCNT)=BPSARR(9002313.0301,"1,"_IEN03_",",+$P(BPSFLDS,";",I),"E")
;
; Convert Dates to Fileman Format (936,937)
S BPSSDT=BPSARR(9002313.0301,"1,"_IEN03_",",936,"I") ; MAX AMT START DATE
S:BPSSDT BPSSDT=BPSSDT-17000000,$P(BPSREC,U,6)=BPSSDT
S BPSEDT=BPSARR(9002313.0301,"1,"_IEN03_",",937,"I") ; MAX AMT END DATE
S:BPSEDT BPSEDT=BPSEDT-17000000,$P(BPSREC,U,7)=BPSEDT
;
Q BPSREC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSBUTL 16794 printed Apr 09, 2024@20:57:40 Page 2
BPSBUTL ;BHAM ISC/MFR/VA/DLF - IB Communication Utilities ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7,8,9,10,11,15,20,24,31**;JUN 2004;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;Reference to STORESP^IBNCPDP supported by DBIA 4299
+4 QUIT
+5 ;
+6 ;CLAIM - pointer to #9002313.02
+7 ;TRNDX - ptr to #9002313.59
+8 ;REASON - text name of the close reason
+9 ;PAPER - 1=drop to paper
+10 ;RELCOP - 1 (Yes) or 0 (No) release copay or not?
+11 ;COMMENT - comment
+12 ;ERROR - array by reference for error details
+13 ;BPSCLO - 1 indicates call coming from ECME User Screen action CLO
+14 ;
CLOSE(CLAIM,TRNDX,REASON,PAPER,RELCOP,COMMENT,ERROR,BPSCLO) ; Send IB an update on the CLAIM status for a Closed Claim
+1 NEW DFN,BPSARRY,BILLNUM,CLAIMNFO,FILLNUM,RXIEN,TRANINFO
+2 ;
+3 ; - Data gathering
+4 DO GETS^DIQ("9002313.59",TRNDX,"1.11;9","I","TRANINFO")
+5 SET RXIEN=TRANINFO(9002313.59,TRNDX_",",1.11,"I")
+6 IF $$RXAPI1^BPSUTIL1(RXIEN,.01)=""
SET ERROR="Prescription not found."
QUIT
+7 SET BPSARRY("FILL NUMBER")=TRANINFO(9002313.59,TRNDX_",",9,"I")
+8 DO GETS^DIQ("9002313.02",CLAIM,"400*;401;402;403;426","","CLAIMNFO")
+9 SET BPSARRY("DOS")=$GET(CLAIMNFO("9002313.02",CLAIM_",","401"))
+10 IF BPSARRY("DOS")
SET BPSARRY("DOS")=BPSARRY("DOS")-17000000
+11 SET FILLNUM=+BPSARRY("FILL NUMBER")
+12 SET DFN=$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
+13 SET BPSARRY("FILLED BY")=$$RXAPI1^BPSUTIL1(RXIEN,16,"I")
+14 SET BPSARRY("PRESCRIPTION")=RXIEN
+15 SET BPSARRY("BILLED")=$$DFF2EXT^BPSECFM($PIECE(CLAIMNFO("9002313.0201","1,"_CLAIM_",","426"),"DQ",2))
+16 SET BPSARRY("CLAIMID")=$PIECE(CLAIMNFO("9002313.0201","1,"_CLAIM_",","402"),"D2",2)
+17 SET BPSARRY("PLAN")=$PIECE(^BPST(TRNDX,10,1,0),"^")
+18 SET BPSARRY("STATUS")="CLOSED"
+19 SET BPSARRY("PAID")=0
+20 SET BPSARRY("RELEASE DATE")=$SELECT(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I"))
+21 IF $GET(BPSCLO)
SET BPSARRY("USER")=DUZ
+22 IF '$TEST
SET BPSARRY("USER")=$$GET1^DIQ(9002313.59,TRNDX,13,"I")
+23 SET BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,TRNDX,1.07,"I")
+24 SET BPSARRY("RXCOB")=$$COB59^BPSUTIL2(TRNDX)
+25 IF REASON'=""
Begin DoDot:1
+26 SET BPSARRY("CLOSE REASON")=$ORDER(^IBE(356.8,"B",REASON,0))
+27 SET BPSARRY("DROP TO PAPER")=+$GET(PAPER)
+28 SET BPSARRY("RELEASE COPAY")=+$GET(RELCOP)
End DoDot:1
+29 IF $GET(COMMENT)]""
SET BPSARRY("CLOSE COMMENT")=COMMENT
+30 ;
+31 ; If dropped to Paper, increment the counter in BPS Statistics
+32 IF BPSARRY("DROP TO PAPER")=1
DO INCSTAT^BPSOSUD("R",8)
+33 ;
+34 ; Call IB
+35 SET BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY)
+36 QUIT
+37 ; Send IB an update on the CLAIM status for a restocked or deleted prescription
CLOSE2(RXIEN,BFILL,BWHERE) ;
+1 NEW IEN59,BPSARRY,DFN,BILLNUM,FILL,REASON
+2 NEW CLAIMNFO
+3 NEW DIE,DA,DR
+4 ;
+5 ; Check parameters
+6 IF '$GET(RXIEN)
SET ERROR="No prescription parameter"
QUIT
+7 IF $GET(BFILL)=""
SET ERROR="No fill parameter"
QUIT
+8 IF $GET(BWHERE)=""
SET ERROR="No RX Action parameter"
QUIT
+9 ;
+10 IF $$RXAPI1^BPSUTIL1(RXIEN,.01)=""
SET ERROR="Prescription not found."
QUIT
+11 IF ",DE,RS,"'[(","_BWHERE_",")
SET ERROR="Invalid BWHERE parameter"
QUIT
+12 ;
+13 ; Calculate the transaction IEN and see that it exists
+14 SET IEN59=$$IEN59^BPSOSRX(RXIEN,BFILL,1)
+15 IF '$DATA(^BPST(IEN59,0))
QUIT
+16 ;
+17 ; Get claim data
+18 SET CLAIM=$PIECE(^BPST(IEN59,0),"^",4)
+19 IF 'CLAIM
SET ERROR="Claim not found in BPS Transaction"
QUIT
+20 DO GETS^DIQ("9002313.02",CLAIM,"400*;401;402;426","","CLAIMNFO")
+21 SET BPSARRY("FILL NUMBER")=+BFILL
+22 SET BPSARRY("DOS")=$GET(CLAIMNFO("9002313.02",CLAIM_",","401"))
+23 IF BPSARRY("DOS")
SET BPSARRY("DOS")=BPSARRY("DOS")-17000000
+24 ;
+25 ; Get prescription data
+26 SET FILLNUM=BPSARRY("FILL NUMBER")
+27 SET DFN=$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
+28 SET BPSARRY("FILLED BY")=$$RXAPI1^BPSUTIL1(RXIEN,16,"I")
+29 SET BPSARRY("PRESCRIPTION")=RXIEN
+30 SET BPSARRY("BILLED")=$$DFF2EXT^BPSECFM($PIECE(CLAIMNFO("9002313.0201","1,"_CLAIM_",","426"),"DQ",2))
+31 SET BPSARRY("CLAIMID")=$PIECE(CLAIMNFO("9002313.0201","1,"_CLAIM_",","402"),"D2",2)
+32 SET BPSARRY("PLAN")=$PIECE(^BPST(IEN59,10,1,0),"^")
+33 SET BPSARRY("STATUS")="CLOSED"
+34 SET BPSARRY("PAID")=0
+35 SET BPSARRY("RELEASE DATE")=$SELECT(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I"))
+36 SET BPSARRY("USER")=.5
+37 SET BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,IEN59,1.07,"I")
+38 SET BPSARRY("RXCOB")=$$COB59^BPSUTIL2(IEN59)
+39 ;
+40 ; Determine the reversal reason based on the BWHERE value
+41 IF BWHERE="RS"
SET REASON="PRESCRIPTION NOT RELEASED"
+42 IF BWHERE="DE"
SET REASON="PRESCRIPTION DELETED"
+43 IF REASON]""
SET BPSARRY("CLOSE REASON")=$ORDER(^IBE(356.8,"B",REASON,0))
+44 ;
+45 ;if a refill was deleted while RX is still active (not deleted) then send DELETION OF REFILL comment for CT record
+46 IF BWHERE="DE"
IF $$RXSTATUS^BPSSCRU2(RXIEN)'=13
SET BPSARRY("CLOSE COMMENT")="DELETION OF REFILL ONLY - ORIGINAL RX MAY REMAIN ACTIVE"
+47 ;
+48 ;
+49 ; Update IB
+50 SET BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY)
+51 ;
+52 ; Update the claim file that the claim is closed and the reason why.
+53 SET DIE="^BPSC("
SET DA=CLAIM
+54 SET DR="901///1;902///"_$$NOW^XLFDT()_";903////.5;904///"_BPSARRY("CLOSE REASON")
+55 DO ^DIE
+56 ;
+57 ; If this is a primary claim, check and send a bulletin if the secondary claim is open or if there
+58 ; is a non-cancelled IB bill for the secondary claim
+59 IF BPSARRY("RXCOB")=1
DO BULL^BPSECMP2(RXIEN,BFILL,CLAIM,DFN,REASON,BPSARRY("CLAIMID"))
+60 QUIT
+61 ;
+62 ; Function to return Transaction, claim, and response IENs
+63 ; Parameters:
+64 ; RXI: Prescription IEN
+65 ; RXR: Fill Number
+66 ; COB: COB Indicator
+67 ; Returns:
+68 ; IEN59^Claim IEN^Response IEN^Reversal Claim IEN^Reversal Response IEN^Prescription/Service Ref Number from BPS CLAIMS file
CLAIM(RXI,RXR,COB) ;
+1 NEW IEN59,CLAIMIEN,RESPIEN,REVCLAIM,REVRESP,ECMENUM
+2 IF '$GET(RXI)
QUIT ""
+3 ; Note that IEN59 will treat RXR="" as the original fill (0)
+4 ; and COB="" as primary (1)
+5 SET IEN59=$$IEN59^BPSOSRX(RXI,$GET(RXR),$GET(COB))
+6 IF '$DATA(^BPST(IEN59,0))
QUIT ""
+7 SET CLAIMIEN=$PIECE(^BPST(IEN59,0),"^",4)
SET RESPIEN=$PIECE(^BPST(IEN59,0),"^",5)
+8 SET REVCLAIM=$PIECE($GET(^BPST(IEN59,4)),"^",1)
SET REVRESP=$PIECE($GET(^BPST(IEN59,4)),"^",2)
+9 SET ECMENUM=$$ECMENUM^BPSSCRU2(IEN59)
+10 QUIT IEN59_U_CLAIMIEN_U_RESPIEN_U_REVCLAIM_U_REVRESP_U_ECMENUM
+11 ;
+12 ; NABP - Return the value in the Service Provider ID (201-B1) field
+13 ; of the claim. Note that as of the NPI release (BPS*1*2), this
+14 ; API may return NPI instead of NABP/NCPDP
NABP(RXP,BFILL) ;
+1 IF '$GET(RXP)
QUIT ""
+2 IF $GET(BFILL)=""
SET BFILL=0
+3 NEW BPSTIEN,BPSCIEN,DFILL,NABP
+4 SET DFILL=$EXTRACT($TRANSLATE($JUSTIFY("",4-$LENGTH(BFILL))," ","0")_BFILL,1,4)
+5 SET BPSTIEN=RXP_"."_DFILL_"1"
+6 IF 'BPSTIEN
QUIT ""
+7 SET BPSCIEN=$PIECE($GET(^BPST(BPSTIEN,0)),U,4)
+8 IF 'BPSCIEN
QUIT ""
+9 SET NABP=$PIECE($GET(^BPSC(BPSCIEN,200)),U)
+10 QUIT NABP
+11 ;
+12 ; DIVNCPDP - For a specific outpatient site, return the NPI & NCPDP.
+13 ; Note that the procedure name is misleading but when originally
+14 ; coded, this procedure only returned NCPDP.
+15 ;
+16 ; Input
+17 ; BPSDIV - Outpatient Site (#59)
+18 ; Output
+19 ; "" - No BPSDIV passed in
+20 ; NCPDP and NPI separated by a caret
DIVNCPDP(BPSDIV) ;
+1 NEW BPSPHARM,NPI,NCPDP
+2 IF '$GET(BPSDIV)
QUIT "^"
+3 ;
+4 ; Get the NCPDP
+5 SET NCPDP=""
+6 SET BPSPHARM=$$GETPHARM^BPSUTIL(BPSDIV)
+7 IF BPSPHARM
SET NCPDP=$$GET1^DIQ(9002313.56,BPSPHARM_",",.02)
+8 ;
+9 ; Get the NPI and validate it
+10 SET NPI=+$$NPI^BPSNPI("Pharmacy_ID",BPSDIV)
+11 IF NPI=-1
SET NPI=""
+12 ;
+13 QUIT NCPDP_"^"_NPI
+14 ;
+15 ;ADDCOMM - Add a comment to a ECME claim
+16 ;Input:
+17 ; BPRX - ien in file #52
+18 ; BPREF - refill number (0,1,2,...)
+19 ; BPRCMNT - comment text
+20 ;Output:
+21 ; 1 - okay
+22 ; -1 - failed
ADDCOMM(BPRX,BPREF,BPRCMNT,BPBKG) ;
+1 ;
+2 ;BPRX (required) - Prescription IEN
+3 ;BPREF (optional) - Refill number
+4 ;BPRCMNT (required) - Comment text
+5 ;BPBKG (optional) - Value 1 indicates process is running in background - BPS*1*15
+6 ;
+7 NEW IEN59,BPNOW,BPREC,BPDA,BPERR
+8 ; Check parameters
+9 IF '$GET(BPRX)
QUIT -1
+10 IF $GET(BPRCMNT)=""
QUIT -1
+11 ; Get BPS Transaction number, if needed, and check for existance
+12 SET IEN59=$$IEN59^BPSOSRX(BPRX,$GET(BPREF),1)
+13 IF IEN59=""
QUIT -1
+14 IF '$DATA(^BPST(IEN59))
QUIT -1
+15 ; Lock record and quit if you cannot get the lock
+16 LOCK +^BPST(9002313.59111,+IEN59):10
+17 IF '$TEST
QUIT -1
+18 ; Create record and file data
+19 SET BPNOW=$$NOW^XLFDT
+20 DO INSITEM^BPSCMT01(9002313.59111,+IEN59,BPNOW)
+21 SET BPREC=$ORDER(^BPST(IEN59,11,"B",BPNOW,99999999),-1)
+22 IF BPREC>0
Begin DoDot:1
+23 ;If BPBKG is passed this is a background process and user is POSTMASTER - BPS*1*15
+24 SET BPDA(9002313.59111,BPREC_","_IEN59_",",.02)=$SELECT($GET(BPBKG):.5,1:+$GET(DUZ))
+25 SET BPDA(9002313.59111,BPREC_","_IEN59_",",.03)=$EXTRACT($GET(BPRCMNT),1,63)
+26 DO FILE^DIE("","BPDA","BPERR")
End DoDot:1
+27 LOCK -^BPST(9002313.59111,+IEN59)
+28 ; Quit with result
+29 IF BPREC>0
IF '$DATA(BPERR)
QUIT 1
+30 QUIT -1
+31 ;
+32 ;REOPEN - Reopen closed claim
+33 ;Input:
+34 ; BP59 - ien in BPS TRANSACTION file
+35 ; BP02 - ien in BPS CLAIMS file
+36 ; BPREOPDT - reopen date/time
+37 ; BPDUZ - user DUZ (#200 ien)
+38 ; BPCOMM - reopen comment text
+39 ;Output:
+40 ; 0^message_error - error
+41 ; 1 - success
REOPEN(BP59,BP02,BPREOPDT,BPDUZ,BPCOMM) ;
+1 NEW RECIENS,BPDA,ERRARR,BPREFNO,BPRXIEN,BPZ,BPSARRY,BPDFN,BPRETVAL,BPZ1
+2 SET BPDFN=$PIECE($GET(^BPST(BP59,0)),U,6)
+3 SET BPREFNO=$PIECE($GET(^BPST(BP59,1)),U)
+4 IF BPREFNO=""
QUIT "0^Null Fill Number"
+5 SET BPRXIEN=$PIECE($GET(^BPST(BP59,1)),U,11)
+6 IF BPRXIEN=""
QUIT "0^Null RX ien Number"
+7 ;in VA there is only one med/claim but in some cases it can different than "1"
+8 ;so take the latest one
+9 SET BPZ=$ORDER(^BPSC(BP02,400,9999999),-1)
+10 IF BPRXIEN=""
QUIT "0^Database Error"
+11 ;============
+12 ;Now update ECME database
+13 SET BPRETVAL=$$UPDREOP^BPSREOP1(BP02,0,BPREOPDT,BPDUZ,BPCOMM)
+14 IF +BPRETVAL=0
Begin DoDot:1
+15 ;try to reverse it in case it was done partially
+16 IF $$UPDREOP^BPSREOP1(BP02,1,"@",+BPDUZ,"@")
End DoDot:1
QUIT BPRETVAL
+17 ;============
+18 ;Now call IB API for "REOPEN" event
+19 SET BPSARRY("STATUS")="REOPEN"
+20 SET BPSARRY("DOS")=$PIECE($GET(^BPSC(BP02,401)),U)
+21 IF BPSARRY("DOS")
SET BPSARRY("DOS")=BPSARRY("DOS")-17000000
+22 SET BPSARRY("FILL NUMBER")=BPREFNO
+23 SET BPSARRY("PRESCRIPTION")=BPRXIEN
+24 SET BPSARRY("CLAIMID")=$$CONVCLID^BPSSCRU6($PIECE($GET(^BPSC(BP02,400,+BPZ,400)),U,2))
+25 SET BPSARRY("DRUG")=$$DRUGIEN^BPSSCRU6(BPRXIEN,BPDFN)
+26 SET BPSARRY("PLAN")=$PIECE($GET(^BPST(BP59,10,1,0)),"^")
+27 SET BPSARRY("USER")=BPDUZ
+28 SET BPSARRY("REOPEN COMMENT")=BPCOMM
+29 SET BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,BP59,1.07,"I")
+30 SET BPSARRY("RXCOB")=$$COB59^BPSUTIL2(BP59)
+31 SET BPRETVAL=$$STORESP^IBNCPDP(BPDFN,.BPSARRY)
+32 ;if successful
+33 IF +BPRETVAL>0
QUIT "1^ReOpening Claim: "_$PIECE($GET(^BPSC(BP02,0)),U)_" ... OK"
+34 ;===========
+35 ;if it was unsuccessful
+36 ;reverse ECME database (keep the user who made the attempt)
+37 IF $$UPDREOP^BPSREOP1(BP02,1,"@",+BPDUZ,"@")
+38 ;return IB error message
+39 QUIT BPRETVAL
+40 ;
GETDAT(RX,FIL,COB,LDOS,LDSUP) ;Returns Last Date of Service and Last Days Supply
+1 ;Input:
+2 ; RX (req) --> RX IEN
+3 ; FIL (req) --> Fill number
+4 ; COB (opt) --> Coordination of Benifits indicator; default is 1
+5 ;Output:
+6 ; LDOS --> Last Date of Service
+7 ; LDSUP --> Last Days Supply
+8 ;
+9 if '($GET(RX))!($GET(FIL)="")
QUIT
+10 if '$GET(COB)
SET COB=1
+11 NEW IEN59,IEN02,STAT,IEN57
+12 SET IEN02=""
+13 SET IEN59=$$IEN59^BPSOSRX(RX,FIL,COB)
+14 SET STAT=$PIECE($GET(^BPST(IEN59,0)),U,2)
+15 IF STAT=99
SET IEN02=$PIECE($GET(^BPST(IEN59,0)),U,4)
+16 IF IEN02=""
Begin DoDot:1
+17 SET IEN57=""
+18 FOR
SET IEN57=$ORDER(^BPSTL("B",IEN59,IEN57),-1)
if IEN57=""!(IEN02)
QUIT
Begin DoDot:2
+19 SET STAT=$PIECE($GET(^BPSTL(IEN57,0)),U,2)
+20 IF STAT=99
SET IEN02=$PIECE($GET(^BPSTL(IEN57,0)),U,4)
End DoDot:2
End DoDot:1
+21 IF 'IEN02
SET (LDOS,LDSUP)=""
QUIT
+22 ;LAST DATE OF SERVICE
SET LDOS=$$GET1^DIQ(9002313.02,IEN02,401,"E")
+23 ;CONVERT DATE TO FILEMAN FORMAT
IF LDOS
SET LDOS=LDOS-17000000
+24 ;LAST DAYS SUPPLY
SET LDSUP=$$GET1^DIQ(9002313.0201,"1,"_IEN02,405,"I")
+25 ; remove the "D5" NCPDP field ID (bps*1*15)
IF LDSUP'=""
SET LDSUP=+$EXTRACT(LDSUP,3,99)
+26 QUIT
+27 ;
NFLDT(RX,FIL,COB) ;Returns Next Avail Fill Date (B04-BT) from ECME - BPS*1.0*15
+1 ;Input:
+2 ; RX (req) --> RX IEN
+3 ; FIL (req) --> Fill number
+4 ; COB (opt) --> Coordination of Benefits indicator; default is 1
+5 ;Output:
+6 ; NFLDT --> Next Avail Fill Date
+7 if '$GET(RX)!($GET(FIL)="")
QUIT ""
+8 if '$GET(COB)
SET COB=1
+9 NEW IEN59,IEN02,STAT,NFLDT,IEN03
+10 SET IEN02=""
+11 SET IEN59=$$IEN59^BPSOSRX(RX,FIL,COB)
+12 SET IEN03=+$PIECE($GET(^BPST(IEN59,0)),U,5)
SET NFLDT=""
+13 ;NEXT FILL DATE
if IEN03
SET NFLDT=$$GET1^DIQ(9002313.0301,"1,"_IEN03,2004,"I")
+14 ;CONVERT DATE TO FILEMAN FORMAT
if NFLDT
SET NFLDT=NFLDT-17000000
+15 QUIT NFLDT
+16 ;
BBILL(RX,RFILL,COB) ;Return Back Bill Indicator for Pharmacy - BPS*1.0*15
+1 NEW IEN59,RXACT
+2 ;Return 0 if no RXI value input
+3 IF '$GET(RX)
QUIT 0
+4 ; Note that $$IEN59 will treat RFILL="" as the original fill (0)
+5 SET IEN59=$$IEN59^BPSOSRX(RX,$GET(RFILL),$GET(COB))
+6 ;No transaction found return 0
+7 IF '$DATA(^BPST(IEN59,0))
QUIT 0
+8 ;Determine if RX ACTION (field #1201) is Back Bill
+9 SET RXACT=$PIECE($GET(^BPST(IEN59,12)),U)
+10 ;Back Bill code not found return 0
+11 IF RXACT'="BB"
IF RXACT'="P2"
IF RXACT'="P2S"
QUIT 0
+12 ;Otherwise return Back Bill indicator
+13 QUIT 1
+14 ;
AMT(RX,FIL,COB) ; Return Gross Amount Due - BPS*1*15
+1 ; RX - rx ien
+2 ; FIL - fill#, defaults to original fill if not passed in
+3 ; COB - cob payer sequence, defaults to 1 if not passed in
+4 ;
+5 NEW AMT,IEN59,QN
+6 SET AMT=""
+7 IF '$GET(RX)
GOTO AMTX
+8 ; ien to BPS Transaction file
SET IEN59=$$IEN59^BPSOSRX(RX,$GET(FIL),$GET(COB))
+9 ; make sure it exists
IF '$DATA(^BPST(IEN59,0))
GOTO AMTX
+10 ; get 9002313.59902 subfile ien
SET QN=+$ORDER(^BPST(IEN59,10,0))
IF 'QN
GOTO AMTX
+11 ; gross amount due, field 902.15
SET AMT=+$PIECE($GET(^BPST(IEN59,10,QN,2)),U,4)
AMTX ;
+1 QUIT AMT
+2 ;
ELIG(RX,FIL,COB) ; Veteran Eligibility - BPS*1*15
+1 ; RX - rx ien
+2 ; FIL - fill#, defaults to original fill if not passed in
+3 ; COB - cob payer sequence, defaults to 1 if not passed in
+4 ;
+5 if '$GET(RX)
QUIT ""
+6 ; ien to BPS Transaction file
+7 NEW IEN59
SET IEN59=$$IEN59^BPSOSRX(RX,$GET(FIL),$GET(COB))
if 'IEN59
QUIT ""
+8 if '$DATA(^BPST(IEN59,0))
QUIT ""
+9 ; ELIGIBILITY field 901.04
+10 QUIT $PIECE($GET(^BPST(IEN59,9)),U,4)
+11 ;
GETBAMT(RXIEN,FILL,COB) ; Retrieve the billed amount
+1 ; RXIEN = Prescription ien (required)
+2 ; FILL# = Fill Number (optional, defaults to latest fill)
+3 ; COB = Coordination of Benefits (optional, defaults to 1)
+4 NEW X,BAMT,CLAIMIEN
+5 SET X=$$CLAIM(RXIEN,$GET(FILL),$GET(COB))
+6 SET CLAIMIEN=$PIECE(X,U,2)
+7 SET BAMT=$$TOTPRICE^BPSSCRLG(CLAIMIEN)
+8 QUIT BAMT
+9 ;
RESUBMIT(RX,REFILL,COB) ; Return Resubmit indicator for Pharmacy - BPS*1*20.
+1 NEW BPSIEN59,BPSRXACT
+2 IF '$GET(RX)
QUIT 0
+3 ;
+4 ; Determine BPS Transaction number. If none, Quit with '0'.
+5 ;
+6 SET BPSIEN59=$$IEN59^BPSOSRX(RX,$GET(REFILL),$GET(COB))
+7 IF 'BPSIEN59
QUIT 0
+8 IF '$DATA(^BPST(BPSIEN59,0))
QUIT 0
+9 ;
+10 ; Pull the RX Action from the BPS Transaction. If it's not one that
+11 ; indicates resubmission from the ECME User Screen, then Quit with
+12 ; '0'. Otherwise, Quit with '1'.
+13 ;
+14 SET BPSRXACT=$$GET1^DIQ(9002313.59,BPSIEN59_",",1201)
+15 IF ",ERES,ERWV,ERNB,"'[(","_BPSRXACT_",")
QUIT 0
+16 QUIT 1
+17 ;
GETCOB(RXIEN,FILL) ; Retrieve the COB payer sequence for usage by PSO
+1 ; Input: RXIEN and FILL (both are required)
+2 ; Output: Function value will be one of the following
+3 ; "" (if the prescription fill cannot be found in BPS Transaction)
+4 ; -1 (when there are multiple COB's/payers found in BPS Transaction)
+5 ; Otherwise,
+6 ; COB#^BPS Transaction IEN
+7 NEW RET,PRI59,SEC59
+8 SET RET=""
+9 IF '$GET(RXIEN)
GOTO GETCOBX
+10 IF $GET(FILL)=""
GOTO GETCOBX
+11 ;
+12 ; possible primary BPS transaction ien
SET PRI59=+$$IEN59^BPSOSRX(RXIEN,FILL,1)
+13 ; possible secondary BPS transaction ien
SET SEC59=+$$IEN59^BPSOSRX(RXIEN,FILL,2)
+14 ;
+15 ; both payers exist, get out
IF $DATA(^BPST(PRI59))
IF $DATA(^BPST(SEC59))
SET RET=-1
GOTO GETCOBX
+16 IF $DATA(^BPST(PRI59))
SET RET=1_U_PRI59
GOTO GETCOBX
+17 IF $DATA(^BPST(SEC59))
SET RET=2_U_SEC59
GOTO GETCOBX
+18 ;
GETCOBX ;
+1 QUIT RET
+2 ;
ADDFLDS(RX,FIL,COB) ;Returns Additional NCPDP fields from ECME
+1 ;Input:
+2 ; RX (req) --> RX IEN
+3 ; FIL (req) --> Fill number
+4 ; COB (req) --> 1=Primary, 2=Secondary, 3=Tertiary
+5 ;Output:
+6 ; BPSREC --> a string separated by "^" containing the output of the BPSARR array
+7 ;
+8 if '$GET(RX)!($GET(FIL)="")
QUIT ""
+9 NEW BPSAMT,BPSARR,BPSCNT,BPSEDT,BPSFLDS,BPSREC,BPSSDT,IEN03,IEN59
+10 ;
+11 SET IEN59=$$IEN59^BPSOSRX(RX,FIL,COB)
+12 SET IEN03=+$PIECE($GET(^BPST(IEN59,0)),U,5)
+13 ;
+14 ; Quit if INE03 is not found
IF '$GET(IEN03)
QUIT ""
+15 ;
+16 SET BPSFLDS="931;932;933;934;935;936;937;938;943;944;2219;2220;2224;2225"
+17 DO GETS^DIQ(9002313.0301,"1,"_IEN03,BPSFLDS,"IE","BPSARR")
+18 ;
+19 SET BPSREC=""
SET BPSCNT=0
+20 FOR I=1:1:$LENGTH(BPSFLDS,";")
SET BPSCNT=BPSCNT+1
Begin DoDot:1
+21 SET $PIECE(BPSREC,U,BPSCNT)=BPSARR(9002313.0301,"1,"_IEN03_",",+$PIECE(BPSFLDS,";",I),"E")
End DoDot:1
+22 ;
+23 ; Convert Dates to Fileman Format (936,937)
+24 ; MAX AMT START DATE
SET BPSSDT=BPSARR(9002313.0301,"1,"_IEN03_",",936,"I")
+25 if BPSSDT
SET BPSSDT=BPSSDT-17000000
SET $PIECE(BPSREC,U,6)=BPSSDT
+26 ; MAX AMT END DATE
SET BPSEDT=BPSARR(9002313.0301,"1,"_IEN03_",",937,"I")
+27 if BPSEDT
SET BPSEDT=BPSEDT-17000000
SET $PIECE(BPSREC,U,7)=BPSEDT
+28 ;
+29 QUIT BPSREC
