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

BPSBUTL.m

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