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