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

BPSPRRX6.m

Go to the documentation of this file. 
  1. BPSPRRX6 ;ALB/SS - ePharmacy secondary billing ;12-DEC-08
  1.  ;;1.0;E CLAIMS MGMT ENGINE;**8,10,11,19,23,24**;JUN 2004;Build 43
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;
  1. RXINFO(BPSRX) ;
  1.  ;Check if if prescription with given number exists
  1.  ;Input:
  1.  ;  BPSRX - RX#
  1.  ;Return:
  1.  ;  1st piece - ien of #52
  1.  ;  2nd piece - ien of #2
  1.  ;  -1 if "^" was entered
  1.  ;
  1.  N BPSDFN,BPS52,BPSRET
  1.  ;prompt for the patient
  1.  S BPSDFN=$$PROMPT^BPSSCRCV("P^DPT(","SELECT PATIENT")
  1.  I BPSDFN=-1 Q -1
  1.  K ^TMP($J,"BPSPRRX")
  1.  D RX^PSO52API(BPSDFN,"BPSPRRX",,BPSRX,"0")
  1.  I +$G(^TMP($J,"BPSPRRX",BPSDFN,0))=-1 D  Q 0
  1.  . W !,"Incorrect RX# or patient name entered.",!
  1.  S BPSRET=+$O(^TMP($J,"BPSPRRX",BPSDFN,0))_U_BPSDFN
  1.  K ^TMP($J,"BPSPRRX")
  1.  Q BPSRET
  1.  ;
  1. RXREFIL(BPS52,BPSDFN,BPSRXNO) ;
  1.  ; Prompt for the fill# and do the rest
  1.  ;
  1.  N BPSRF,BPSARR,BPSVAL,BPSELCTD,BPSRETV,BPORRFDT
  1.  K ^TMP($J,"BPSPRRX")
  1.  D RX^PSO52API(BPSDFN,"BPSPRRX",BPS52,,"R")
  1.  I +$G(^TMP($J,"BPSPRRX",BPSDFN,BPS52,"RF",0))=0 Q 0
  1.  S BPSRF=0
  1.  F  S BPSRF=$O(^TMP($J,"BPSPRRX",BPSDFN,BPS52,"RF",BPSRF)) Q:+BPSRF=0  D
  1.  . S BPSVAL=$G(^TMP($J,"BPSPRRX",BPSDFN,BPS52,"RF",BPSRF,.01))
  1.  . S BPSARR(BPSRF)=BPSRF_U_$P(BPSVAL,U)
  1.  ;original fill date
  1.  S BPORRFDT=$$RXFLDT^PSOBPSUT(BPS52,0)
  1.  S BPSARR(0)=0_U_BPORRFDT
  1.  F  S BPSELCTD=$$SELREFIL^BPSPRRX5(.BPSARR,"SELECT A FILL TO BILL","RX #"_BPSRXNO_" has the following fills:") Q:$P(BPSELCTD,U)'=""
  1.  I BPSELCTD<0 Q -1
  1.  Q BPSELCTD
  1.  ;
  1. SECBIL59(MOREDATA,IEN59) ;
  1.  ; Populate secondary billing fields in BPS TRANSACTION
  1.  ; MOREDATA array filed into 9002313.59
  1.  N BPTYPE,BPSTIME,BPCOB
  1.  N AMTIEN,BPIEN1,BPIEN2,BPZ5914,BPZ,BPZ1,BPZ2,OPAMT,OPAPQ,OPAYD,OPPRA,OPREJ,PIEN,REJIEN,BPQ
  1.  I +$G(IEN59)=0 Q
  1.  ;
  1.  I $L($G(MOREDATA("337-4C"))) I $$FILLFLDS^BPSUTIL2(9002313.59,1204,IEN59,MOREDATA("337-4C"))<1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#1204) of (#9002313.59)")   ; cob other payments count
  1.  I $L($G(MOREDATA("308-C8"))) I $$FILLFLDS^BPSUTIL2(9002313.59,1205,IEN59,MOREDATA("308-C8"))<1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#1205) of (#9002313.59)")   ; other coverage code
  1.  ;
  1.  ; store secondary billing related data entered by the user - esg 6/14/10
  1.  S BPQ=0
  1.  S PIEN=0 F  S PIEN=$O(MOREDATA("OTHER PAYER",PIEN)) Q:'PIEN!BPQ  D
  1.  . S OPAYD=$G(MOREDATA("OTHER PAYER",PIEN,0)) Q:OPAYD=""
  1.  . ;
  1.  . ; count up the number of multiples we have in each set
  1.  . S BPZ=0 F BPZ1=0:1 S BPZ=$O(MOREDATA("OTHER PAYER",PIEN,"P",BPZ)) Q:'BPZ
  1.  . S BPZ=0 F BPZ2=0:1 S BPZ=$O(MOREDATA("OTHER PAYER",PIEN,"R",BPZ)) Q:'BPZ
  1.  . I BPZ1,BPZ2 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot have both payments and rejects for the same OTHER PAYER.") Q
  1.  . ;
  1.  . ; add a new entry to subfile 9002313.5914
  1.  . S BPZ5914=$$INSITEM^BPSUTIL2(9002313.5914,IEN59,PIEN,PIEN,"",,0)
  1.  . I BPZ5914<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Can't create entry in COB OTHER PAYERS multiple of the BPS TRANSACTION file") Q
  1.  . ;
  1.  . ; set the rest of the pieces at this level
  1.  . I $P(OPAYD,U,2)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.02,PIEN_","_IEN59,$P(OPAYD,U,2))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.02) of (#9002313.5914)") Q
  1.  . I $P(OPAYD,U,3)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.03,PIEN_","_IEN59,$P(OPAYD,U,3))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.03) of (#9002313.5914)") Q
  1.  . I $P(OPAYD,U,4)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.04,PIEN_","_IEN59,$P(OPAYD,U,4))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.04) of (#9002313.5914)") Q
  1.  . I $P(OPAYD,U,5)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.05,PIEN_","_IEN59,$P(OPAYD,U,5))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.05) of (#9002313.5914)") Q
  1.  . I $$FILLFLDS^BPSUTIL2(9002313.5914,.06,PIEN_","_IEN59,BPZ1)<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.06) of (#9002313.5914)") Q
  1.  . I $$FILLFLDS^BPSUTIL2(9002313.5914,.07,PIEN_","_IEN59,BPZ2)<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.07) of (#9002313.5914)") Q
  1.  . I $P(OPAYD,U,11)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.11,PIEN_","_IEN59,$P(OPAYD,U,11))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.11) of (#9002313.5914)") Q
  1.  . ;
  1.  . ; now loop thru the other payer payment array
  1.  . S AMTIEN=0 F  S AMTIEN=$O(MOREDATA("OTHER PAYER",PIEN,"P",AMTIEN)) Q:'AMTIEN!BPQ  D
  1.  .. S OPAMT=$G(MOREDATA("OTHER PAYER",PIEN,"P",AMTIEN,0))
  1.  .. S OPAPQ=$P(OPAMT,U,2)   ; 342-HC other payer amt paid qualifier (ncpdp 5.1 blank is OK)
  1.  .. S OPPRA=$P(OPAMT,U,3)   ; 352-NQ, Other Payer-Patient Responsibility Amount
  1.  .. S OPAMT=+OPAMT          ; 431-DV other payer amt paid
  1.  .. ;
  1.  .. ; add a new entry to subfile 9002313.59141
  1.  .. S BPIEN1=$$INSITEM^BPSUTIL2(9002313.59141,PIEN_","_IEN59,OPAMT,AMTIEN,"",,0)
  1.  .. I BPIEN1<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Can't create entry in 9002313.59141 subfile") Q
  1.  .. ;
  1.  .. ; set piece 2
  1.  .. I OPAPQ'="" I $$FILLFLDS^BPSUTIL2(9002313.59141,.02,AMTIEN_","_PIEN_","_IEN59,OPAPQ)<1 D
  1.  ... S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.02) of (#9002313.59141)")
  1.  ... Q
  1.  .. ;
  1.  .. ; set piece 3
  1.  .. I OPPRA'="" I $$FILLFLDS^BPSUTIL2(9002313.59141,.03,AMTIEN_","_PIEN_","_IEN59,OPPRA)<1 D
  1.  ... S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.03) of (#9002313.59141)")
  1.  ... Q
  1.  .. ;
  1.  .. Q
  1.  . ;
  1.  . ; now loop thru the other payer reject array
  1.  . S REJIEN=0 F  S REJIEN=$O(MOREDATA("OTHER PAYER",PIEN,"R",REJIEN)) Q:'REJIEN!BPQ  D
  1.  .. S OPREJ=$G(MOREDATA("OTHER PAYER",PIEN,"R",REJIEN,0)) Q:OPREJ=""  Q:$P(OPREJ,U,1)=""
  1.  .. ;
  1.  .. ; add a new entry to subfile 9002313.59142
  1.  .. S BPIEN2=$$INSITEM^BPSUTIL2(9002313.59142,PIEN_","_IEN59,$P(OPREJ,U,1),REJIEN,"",,0)
  1.  .. I BPIEN2<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Can't create entry in 9002313.59142 subfile") Q
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;
  1. SECDATA(RX,FILL,BPSPLAN,BPSPRDAT,BPSRTYPE) ;
  1.  ;Populate array elements to resubmit SECONDARY claim.  This builds the COB data using
  1.  ;  the secondary claim that was previously submitted.
  1.  ;This will be called by the PRO option (BPSPRRX, BPSPRRX5) and Resubmit with Edits (BPSRES)
  1.  ;  if it cannot build the COB claim data from the primary claim, which will only happen
  1.  ;  if the primary claim is missing (primary claim was paper).
  1.  ;This is also called by BPSNCPDP when the secondary data is missing.  I believe that this
  1.  ;  will only happen for a Resubmit (RES) from the ECME User Screen.  For this process, we
  1.  ;  also need to compile the PRIMARY BILL, insurance plan, and rate type.
  1.  ;
  1.  ;Input:
  1.  ;  RX - Prescription (#52) IEN
  1.  ;  FILL - Fill Number
  1.  ;  BPSPLAN - Plan (#355.3) IEN, by reference
  1.  ;  BPSPRDAT - Array with secondary data, by reference
  1.  ;  BPSRTYPE - Rate Type (#399.3) IEN, by reference
  1.  ;Output:
  1.  ;  1 - Success
  1.  ;  0 - Cannot populate array
  1.  ;
  1.  N IEN59SEC,BPBILL
  1.  I '$G(RX) Q 0
  1.  I $G(FILL)="" Q 0
  1.  ;
  1.  ; Get Transaction IENs for the secondary transaction
  1.  S IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2)
  1.  ;
  1.  ; Get Primary Bill for the secondary claim
  1.  S BPBILL=$$PAYBLPRI^BPSUTIL2(IEN59SEC)
  1.  I BPBILL>0 S BPSPRDAT("PRIMARY BILL")=BPBILL
  1.  ;
  1.  ; Get Plan, Rate Type, and Prior Payment from the secondary transaction
  1.  S BPSPLAN=+$P($G(^BPST(IEN59SEC,10,1,0)),U,1)
  1.  S BPSRTYPE=+$P($G(^BPST(IEN59SEC,10,1,0)),U,8)
  1.  S BPSPRDAT("PRIOR PAYMENT")=$P($G(^BPST(IEN59SEC,10,1,2)),U,9)
  1.  ;
  1.  ; Build array of COB secondary claim data from the BPS Transaction file - esg - 6/14/10
  1.  S BPSPRDAT("337-4C")=$P($G(^BPST(IEN59SEC,12)),U,4)  ;1204 cob other payments count
  1.  S BPSPRDAT("308-C8")=$P($G(^BPST(IEN59SEC,12)),U,5)  ;1205 other coverage code
  1.  ;
  1.  ; Build COB data array - esg - 6/14/10
  1.  N COBPIEN,APDIEN,REJIEN
  1.  K BPSPRDAT("OTHER PAYER")
  1.  S COBPIEN=0 F  S COBPIEN=$O(^BPST(IEN59SEC,14,COBPIEN)) Q:'COBPIEN  D
  1.  . S BPSPRDAT("OTHER PAYER",COBPIEN,0)=$G(^BPST(IEN59SEC,14,COBPIEN,0))
  1.  . ;
  1.  . ; Retrieve data from other payer amount paid multiple
  1.  . S APDIEN=0 F  S APDIEN=$O(^BPST(IEN59SEC,14,COBPIEN,1,APDIEN)) Q:'APDIEN  D
  1.  .. S BPSPRDAT("OTHER PAYER",COBPIEN,"P",APDIEN,0)=$G(^BPST(IEN59SEC,14,COBPIEN,1,APDIEN,0))
  1.  .. Q
  1.  . ;
  1.  . ; Retrieve data from other payer reject multiple
  1.  . S REJIEN=0 F  S REJIEN=$O(^BPST(IEN59SEC,14,COBPIEN,2,REJIEN)) Q:'REJIEN  D
  1.  .. S BPSPRDAT("OTHER PAYER",COBPIEN,"R",REJIEN,0)=$G(^BPST(IEN59SEC,14,COBPIEN,2,REJIEN,0))
  1.  .. Q
  1.  . Q
  1.  Q 1
  1.  ;
  1. PRIMDATA(RX,FILL,COBARRAY) ;
  1.  ; Build COB data from primary claim and response
  1.  ; This is called by PRO option (BPSPRRX, BPSPRRX5) and Resubmit with Edits (BPSRES)
  1.  ; 
  1.  ; Input:
  1.  ;   RX - Prescription IEN
  1.  ;   FILL - Fill Number
  1.  ;   COBARRAY - Array that will be build, passed by reference
  1.  ; Return:
  1.  ;   0 = Invalid data (transactions, claim, or response is missing)
  1.  ;   1 = Valid data
  1.  ;
  1.  I '$G(RX) Q 0
  1.  I $G(FILL)="" Q 0
  1.  N IEN59PR,BPSIEN,BPSCLM,BPSRESP,BPSSTAT,BIN,BPSOPDT,BPX,BPSPIEN,CNT
  1.  N BPSRECID
  1.  ;
  1.  ; Get primary transaction and check that is exists
  1.  S IEN59PR=$$IEN59^BPSOSRX(RX,FILL,1)
  1.  I '$D(^BPST(IEN59PR)) Q 0
  1.  ;
  1.  ; Get Claim and Response and make sure they both exist
  1.  S BPSCLM=+$P($G(^BPST(IEN59PR,0)),U,4)
  1.  I BPSCLM=0 Q 0
  1.  I '$D(^BPSC(BPSCLM)) Q 0
  1.  S BPSRESP=+$P($G(^BPST(IEN59PR,0)),U,5)
  1.  I BPSRESP=0 Q 0
  1.  I '$D(^BPSR(BPSRESP)) Q 0
  1.  ;
  1.  ; Get status of primary transaction
  1.  S BPSSTAT=$P($$STATUS^BPSOSRX(RX,FILL,,,1),U)
  1.  ;
  1.  ; If the primary claim is payable, get the PRIOR PAYMENT from the primary Response record
  1.  S COBARRAY("PRIOR PAYMENT")=""
  1.  I $$PAYABLE^BPSOSRX5(BPSSTAT),BPSRESP S COBARRAY("PRIOR PAYMENT")=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,9))
  1.  ;
  1.  ; Get Coverage Code
  1.  I $G(COBARRAY("PRIOR PAYMENT"))>0 S COBARRAY("308-C8")="02"
  1.  E  I BPSSTAT["E REJECTED" S COBARRAY("308-C8")="03"
  1.  E  S COBARRAY("308-C8")="04"
  1.  ;
  1.  ; Get BIN from the primary claim record
  1.  S BIN=""
  1.  I BPSCLM S BIN=$P($G(^BPSC(BPSCLM,100)),U)
  1.  ;
  1.  ; Get the Other Payer Date in internal format from the primary Response record
  1.  S BPSOPDT=""
  1.  I BPSRESP S BPSOPDT=($P($G(^BPSR(BPSRESP,0)),U,2))\1
  1.  ;
  1.  ; Default the Other Payer IEN 1 since we only do secondary
  1.  S BPSPIEN=1
  1.  S COBARRAY("337-4C")=BPSPIEN ; Other Payer Count
  1.  ;
  1.  ; Set array of Other Payer Data
  1.  K COBARRAY("OTHER PAYER")
  1.  S COBARRAY("OTHER PAYER",BPSPIEN,0)="1^01^03^"_BIN_"^"_BPSOPDT_"^0^0"
  1.  ; Add Reconciliation ID to Other Payer Data, transmit on Secondary
  1.  ; claim as Other Payer Reconciliation ID
  1.  S BPSRECID=$$ANFF^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,"B98")),U,1),30)
  1.  I BPSRECID'="" S $P(COBARRAY("OTHER PAYER",BPSPIEN,0),"^",11)=BPSRECID
  1.  ;
  1.  ; Build Paid Amounts if previous claim was paid
  1.  I BPSSTAT["E PAYABLE",$G(COBARRAY("PRIOR PAYMENT"))]"" D
  1.  . N BPARR,BPX D GETOPAP(BPSRESP,.BPARR)
  1.  . S BPX=0 F CNT=0:1  S BPX=$O(BPARR(BPX)) Q:BPX=""  S COBARRAY("OTHER PAYER",BPSPIEN,"P",BPX,0)=BPARR(BPX)
  1.  . S $P(COBARRAY("OTHER PAYER",BPSPIEN,0),U,6)=CNT
  1.  ;
  1.  ; Build Reject Codes if previous claims was rejected
  1.  I BPSSTAT["E REJECTED" D
  1.  . N BPARR,BPX D GETRJCOD(BPSRESP,.BPARR)
  1.  . S BPX=0 F CNT=0:1  S BPX=$O(BPARR(BPX)) Q:BPX=""  S COBARRAY("OTHER PAYER",BPSPIEN,"R",BPX,0)=BPARR(BPX)
  1.  . S $P(COBARRAY("OTHER PAYER",BPSPIEN,0),U,7)=CNT
  1.  Q 1
  1.  ;
  1. GETOPAP(BPSRESP,BPSDAT) ;
  1.  ; Get the Other Payer Amount Paid values and qualifiers
  1.  ; Input:
  1.  ;   BPSRESP = IEN of BPS RESPONSE file
  1.  ;   BPSDAT(N) = Array of Other Payer fields (passed by reference)
  1.  ;       [1] Patient Pay Amount
  1.  ;       [2] Qualifier
  1.  ;       [3] Other Payer Patient Responsibility Amount
  1.  ;
  1.  I '$G(BPSRESP) Q
  1.  I '$D(^BPSR(BPSRESP,1000)) Q
  1.  N CNT,BPS505,BPS509,BPS559,BPS558,BPS523,BPS563,BPS562,BPS521,BPSQUAL,BPSAMNT,BPSTAX,BPSOAP,BPSX
  1.  S CNT=0
  1.  ; Set up D.0 fields for COB segment
  1.  S BPS509=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,9))
  1.  ; If Total Amount Paid is a negative number, set it to zero.
  1.  ; Zero Pay amount is allowed
  1.  I BPS509<0 S BPS509=0
  1.  ;
  1.  ; Cognitive Services Qualifier/Professional Service Fee Paid
  1.  S BPS562=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,560)),U,2))
  1.  I BPS562<0 S BPS562=0
  1.  I +BPS562 S CNT=CNT+1,BPSDAT(CNT)=BPS562_U_"06"
  1.  ;
  1.  ; Incentive Qualifier/Incentive Amt Paid
  1.  S BPS521=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,21))
  1.  I BPS521<0 S BPS521=0
  1.  I +BPS521 S CNT=CNT+1,BPSDAT(CNT)=BPS521_U_"05"
  1.  ; Subtract Incentive Qualifier from Paid Amount for Drug Benefit
  1.  S BPS509=BPS509-BPS521
  1.  ;
  1.  ; Default all Tax values to zero for negative values
  1.  S BPS559=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,550)),U,9)) ; Percentage Sales Tax Paid
  1.  I BPS559<0 S BPS559=0
  1.  S BPS558=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,550)),U,8)) ; Flat Sales Tax Paid
  1.  I BPS558<0 S BPS558=0
  1.  S BPS523=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,23)) ; Amount Attributed to Sales Tax
  1.  I BPS523<0 S BPS523=0
  1.  ;
  1.  ; Sales Tax Qualifier
  1.  S BPSTAX=BPS559+BPS558-BPS523
  1.  I BPSTAX<0 S BPSTAX=0
  1.  I +BPSTAX S CNT=CNT+1,BPSDAT(CNT)=BPSTAX_U_"10"
  1.  ; Subtract Sales Tax Qualifier from Paid Amount for Drug Benefit
  1.  S BPS509=BPS509-BPSTAX
  1.  ;
  1.  ; Set OTHER AMOUNT PAID multiples
  1.  S BPS563=0 F  S BPS563=$O(^BPSR(BPSRESP,1000,1,563.01,BPS563)) Q:BPS563=""  D
  1.  . S BPSQUAL=$P($G(^BPSR(BPSRESP,1000,1,563.01,BPS563,1)),U,1)
  1.  . ; Quit if qualifier = 99 since there is no NCPDP mapping for this qualifier
  1.  . Q:BPSQUAL']""!(BPSQUAL=99)
  1.  . S BPSAMNT=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,563.01,BPS563,1)),U,2))
  1.  . ; Default negative amounts to zero
  1.  . I BPSAMNT<0 S BPSAMNT=0
  1.  . I $D(BPSOAP(BPSQUAL)) S BPSOAP(BPSQUAL)=BPSOAP(BPSQUAL)+BPSAMNT
  1.  . I '$D(BPSOAP(BPSQUAL)) S BPSOAP(BPSQUAL)=BPSAMNT
  1.  . ; Subtract Amount if Qualifier is 01, 02, 03, 04, 09 or 11
  1.  . I "010203040911"[BPSQUAL S BPS509=BPS509-BPSAMNT
  1.  I $D(BPSOAP) D
  1.  . S BPSX="" F  S BPSX=$O(BPSOAP(BPSX)) Q:BPSX=""  D
  1.  . . S CNT=CNT+1,BPSDAT(CNT)=BPSOAP(BPSX)_U_$$GETPDIEN(BPSX)
  1.  ; Set Drug Benefit Qualifier
  1.  I BPS509<0 S BPS509=0
  1.  ; Set Patient Pay Amount
  1.  S BPS505=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,5))
  1.  ;
  1.  S CNT=CNT+1,BPSDAT(CNT)=BPS509_U_$$GETPDIEN("07")_U_BPS505
  1.  Q
  1.  ;
  1. GETPDIEN(CODE) ;
  1.  ; Get the Other Payer Amount Paid Qualifier IEN for BPS NCPCP OTHER
  1.  ;   PAYER AMOUNT PAID QUAL file
  1.  I $G(CODE)="" Q ""
  1.  Q $O(^BPS(9002313.2,"B",CODE,""))
  1.  ;
  1. GETRJCOD(BPRESP,BPARR) ;
  1.  ; Get the first five reject codes w/o getting duplicates
  1.  ; Input:
  1.  ;   BPSRESP = IEN of BPS RESPONSE file
  1.  ;   BPSARR1 = Array of Reject Codes
  1.  ;
  1.  I '$G(BPRESP) Q
  1.  I '$D(^BPSR(BPRESP,1000)) Q
  1.  N BPRCNT,BPRJ,BPPOS,BPRJCOD
  1.  ;
  1.  ; Default BPPOS to the first transaction in the RESPONSE multiple
  1.  ; We only want the first five reject codes and no duplicates
  1.  S (BPRCNT,BPRJ)=0,BPPOS=1
  1.  F  S BPRJ=$O(^BPSR(BPRESP,1000,BPPOS,511,BPRJ)) Q:+BPRJ=0  D  Q:BPRCNT>4
  1.  . S BPRJCOD=$P($G(^BPSR(BPRESP,1000,BPPOS,511,BPRJ,0)),U)
  1.  . Q:$L(BPRJCOD)=0
  1.  . ; Only store if not a duplicate
  1.  . I '$D(BPARR(BPRJCOD)) S BPRCNT=BPRCNT+1,BPARR(BPRCNT)=BPRJCOD
  1.  Q
  1.  ;BPSPRRX6