- BPSOS03 ;BHAM ISC/FCS/DRS - 9002313.03 utilities ;06/01/2004
- ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,20**;JUN 2004;Build 27
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- Q
- ; General utilities for retrieval from 9002313.03, Claim Response
- ; $$INSPAID is used by BPSOSQL
- INSPAID(N) ;EP - from BPSOSQL - total amount paid by insurer
- N RX,TOT,X S (TOT,RX)=0
- F S RX=$O(^BPSR(N,1000,RX)) Q:'RX D
- . ; Try Gross Amount Due, and if that's zero, Usual and Customary
- . S X=$$INSPAID1(N,RX)
- . S TOT=TOT+X
- Q TOT
- INSPAID1(N,RX) ;EP -
- N X S X=$$509(N,RX) Q X
- NETPAID1(N,RX) ; EP - computed field in 9002313.57 and 9002313.59
- N X S X=$$509(N,RX) ; X = (#509) Total Amount Paid
- N SUB S SUB=1 ; Do we need to subtract (#505) Patient Pay Amount?
- N IEN02,INS,FMT S IEN02=$P(^BPSR(RESP,0),U)
- I IEN02 D
- . S INS=$P($G(^BPSC(IEN02,0)),U,2) Q:'INS ;IHS/SD/lwj 9/11/02
- . S FMT=INS
- . N X S X=$P(^BPSF(9002313.92,FMT,1),U,10)
- . I X S SUB=0 ; Total paid means total paid by insurance
- I SUB S X=X-$$505(N,RX)
- I X<0,SUB D ; apparently this format is supposed to be excl.
- . Q:'$G(FMT)
- . S $P(^BPSF(9002313.92,FMT,1),U,10)=1
- . S X=X+$$505(N,RX) ;*1.26*1*
- Q X
- REJTEXT(RESP,POS,ARR) ; EP - fills array (passed by ref)
- K ARR
- N A,I,X,R S (A,I)=0
- F S A=$O(^BPSR(RESP,1000,POS,511,A)) Q:'A D
- . S R=$P(^BPSR(RESP,1000,POS,511,A,0),U)
- . Q:R=""
- . N S S S=$O(^BPSF(9002313.93,"B",R,0))
- . I S S X=$TR($G(^BPSF(9002313.93,S,0)),U,":")
- . E S X=R_" unrecognized reject code"
- . S I=I+1,ARR(I)=X
- Q
- MESSAGE(RESP,POS,N) ; EP - get additional message from response
- I '$G(RESP) Q ""
- I '$G(POS) S POS=1
- I $G(N)=1 Q $P($G(^BPSR(RESP,504)),U)
- I $G(N)=2 N MSG S MSG="" D Q MSG
- . N ADDMESS,N
- . D ADDMESS^BPSSCRLG(RESP,POS,.ADDMESS)
- . S N="" F S N=$O(ADDMESS(N)) Q:'N S MSG=MSG_$S(N=1:"",1:"~")_ADDMESS(N)
- Q $$MESSAGE(RESP,POS,1)_$$MESSAGE(RESP,POS,2)
- ;
- DFF2EXT(X) Q $$DFF2EXT^BPSECFM(X)
- 505(M,N) Q $$500(M,N,5) ; Patient Pay Amount
- 506(M,N) Q $$500(M,N,6) ; Ingredient Cost Paid
- 507(M,N) Q $$500(M,N,7) ; Dispensing Fee Paid
- 508(M,N) Q $$500(M,N,8) ; Sales Tax Paid
- 509(M,N) Q $$500(M,N,9) ; Total Amount Paid
- 512(M,N) Q $$500(M,N,12) ; Accumulated Deductible Amount
- 513(M,N) Q $$500(M,N,13) ; Remaining Deductible Amount
- 514(M,N) Q $$500(M,N,14) ; Remaining Benefit Amount
- 517(M,N) Q $$500(M,N,17) ; Amt Applied to Periodic Deduct
- 518(M,N) Q $$500(M,N,18) ; Amount of Copay/CoInsurance
- 519(M,N) Q $$500(M,N,19) ; Amt Attrib to Prod Selection
- 520(M,N) Q $$500(M,N,20) ; Amt Exceed Per Benefit Max
- 521(M,N) Q $$500(M,N,21) ; Incentive Fee Paid
- 523(M,N) Q $$500(M,N,23) ; Amount Attributed to Sales Tax
- 500(M,N,J) ; field #500+J signed numeric
- Q:'M!'N ""
- N X S X=$P($G(^BPSR(M,1000,N,500)),U,J)
- I $E(X,1,2)?2U S X=$E(X,3,$L(X))
- S X=$$DFF2EXT(X)
- Q X
- ;
- RESPONSE(BPSRX,BPSFILL,BPSCOB) ; Pull fields from response.
- ; MRD;BPS*1.0*20 - Created this API to display additional information
- ; to the user when an RRR is successfully resubmitted.
- ; Input: (r) BPSRX - Rx IEN (#52)
- ; (o) BPSFILL - Refill#
- ; (o) BPSCOB - Payer Sequence
- ; Output: [1] Total Amount Paid, file# 9002313.0301, field #509
- ; [2] Ingredient Cost Paid, field #506
- ; [3] Amount of Copay/Coinsurance, field #518
- ; [4] Dispensing Fee Paid, field #507
- ; [5] Amount Applied to Periodic Deductible, field #517
- ; [6] Remaining Deductible Amount, field #513
- ;
- N BPSPOS,BPSRESP,BPSTRAN,BPSX
- ;
- I '$G(BPSRX) Q "" ; If no Rx passed in, Quit with "".
- I $G(BPSFILL)="" S BPSFILL=0 ; Default Fill to 0 if none.
- I '$G(BPSCOB) S BPSCOB=1 ; Default COB to 1/primary if none.
- ;
- ; Use $$CLAIM^BPSBUTL to determine the BPS Transaction and BPS Response
- ; based on the Rx, Fill, COB.
- ;
- S BPSX=$$CLAIM^BPSBUTL(BPSRX,BPSFILL,BPSCOB)
- S BPSTRAN=$P(BPSX,U,1) ; BPS Transaction.
- S BPSRESP=$P(BPSX,U,3) ; BPS Response.
- I BPSTRAN=""!(BPSRESP="") Q ""
- ;
- ; Pull the field Position in Claim from the BPS Transaction file.
- ;
- S BPSPOS=$$GET1^DIQ(9002313.59,BPSTRAN,14)
- I '$G(BPSPOS) S BPSPOS=1
- ;
- S BPSX=$$509(BPSRESP,BPSPOS)_"^"_$$506(BPSRESP,BPSPOS)
- S BPSX=BPSX_"^"_$$518(BPSRESP,BPSPOS)_"^"_$$507(BPSRESP,BPSPOS)
- S BPSX=BPSX_"^"_$$517(BPSRESP,BPSPOS)_"^"_$$513(BPSRESP,BPSPOS)
- ;
- Q BPSX
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOS03 4362 printed Jan 18, 2025@02:52:40 Page 2
- BPSOS03 ;BHAM ISC/FCS/DRS - 9002313.03 utilities ;06/01/2004
- +1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,20**;JUN 2004;Build 27
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ; General utilities for retrieval from 9002313.03, Claim Response
- +6 ; $$INSPAID is used by BPSOSQL
- INSPAID(N) ;EP - from BPSOSQL - total amount paid by insurer
- +1 NEW RX,TOT,X
- SET (TOT,RX)=0
- +2 FOR
- SET RX=$ORDER(^BPSR(N,1000,RX))
- if 'RX
- QUIT
- Begin DoDot:1
- +3 ; Try Gross Amount Due, and if that's zero, Usual and Customary
- +4 SET X=$$INSPAID1(N,RX)
- +5 SET TOT=TOT+X
- End DoDot:1
- +6 QUIT TOT
- INSPAID1(N,RX) ;EP -
- +1 NEW X
- SET X=$$509(N,RX)
- QUIT X
- NETPAID1(N,RX) ; EP - computed field in 9002313.57 and 9002313.59
- +1 ; X = (#509) Total Amount Paid
- NEW X
- SET X=$$509(N,RX)
- +2 ; Do we need to subtract (#505) Patient Pay Amount?
- NEW SUB
- SET SUB=1
- +3 NEW IEN02,INS,FMT
- SET IEN02=$PIECE(^BPSR(RESP,0),U)
- +4 IF IEN02
- Begin DoDot:1
- +5 ;IHS/SD/lwj 9/11/02
- SET INS=$PIECE($GET(^BPSC(IEN02,0)),U,2)
- if 'INS
- QUIT
- +6 SET FMT=INS
- +7 NEW X
- SET X=$PIECE(^BPSF(9002313.92,FMT,1),U,10)
- +8 ; Total paid means total paid by insurance
- IF X
- SET SUB=0
- End DoDot:1
- +9 IF SUB
- SET X=X-$$505(N,RX)
- +10 ; apparently this format is supposed to be excl.
- IF X<0
- IF SUB
- Begin DoDot:1
- +11 if '$GET(FMT)
- QUIT
- +12 SET $PIECE(^BPSF(9002313.92,FMT,1),U,10)=1
- +13 ;*1.26*1*
- SET X=X+$$505(N,RX)
- End DoDot:1
- +14 QUIT X
- REJTEXT(RESP,POS,ARR) ; EP - fills array (passed by ref)
- +1 KILL ARR
- +2 NEW A,I,X,R
- SET (A,I)=0
- +3 FOR
- SET A=$ORDER(^BPSR(RESP,1000,POS,511,A))
- if 'A
- QUIT
- Begin DoDot:1
- +4 SET R=$PIECE(^BPSR(RESP,1000,POS,511,A,0),U)
- +5 if R=""
- QUIT
- +6 NEW S
- SET S=$ORDER(^BPSF(9002313.93,"B",R,0))
- +7 IF S
- SET X=$TRANSLATE($GET(^BPSF(9002313.93,S,0)),U,":")
- +8 IF '$TEST
- SET X=R_" unrecognized reject code"
- +9 SET I=I+1
- SET ARR(I)=X
- End DoDot:1
- +10 QUIT
- MESSAGE(RESP,POS,N) ; EP - get additional message from response
- +1 IF '$GET(RESP)
- QUIT ""
- +2 IF '$GET(POS)
- SET POS=1
- +3 IF $GET(N)=1
- QUIT $PIECE($GET(^BPSR(RESP,504)),U)
- +4 IF $GET(N)=2
- NEW MSG
- SET MSG=""
- Begin DoDot:1
- +5 NEW ADDMESS,N
- +6 DO ADDMESS^BPSSCRLG(RESP,POS,.ADDMESS)
- +7 SET N=""
- FOR
- SET N=$ORDER(ADDMESS(N))
- if 'N
- QUIT
- SET MSG=MSG_$SELECT(N=1:"",1:"~")_ADDMESS(N)
- End DoDot:1
- QUIT MSG
- +8 QUIT $$MESSAGE(RESP,POS,1)_$$MESSAGE(RESP,POS,2)
- +9 ;
- DFF2EXT(X) QUIT $$DFF2EXT^BPSECFM(X)
- 505(M,N) ; Patient Pay Amount
- QUIT $$500(M,N,5)
- 506(M,N) ; Ingredient Cost Paid
- QUIT $$500(M,N,6)
- 507(M,N) ; Dispensing Fee Paid
- QUIT $$500(M,N,7)
- 508(M,N) ; Sales Tax Paid
- QUIT $$500(M,N,8)
- 509(M,N) ; Total Amount Paid
- QUIT $$500(M,N,9)
- 512(M,N) ; Accumulated Deductible Amount
- QUIT $$500(M,N,12)
- 513(M,N) ; Remaining Deductible Amount
- QUIT $$500(M,N,13)
- 514(M,N) ; Remaining Benefit Amount
- QUIT $$500(M,N,14)
- 517(M,N) ; Amt Applied to Periodic Deduct
- QUIT $$500(M,N,17)
- 518(M,N) ; Amount of Copay/CoInsurance
- QUIT $$500(M,N,18)
- 519(M,N) ; Amt Attrib to Prod Selection
- QUIT $$500(M,N,19)
- 520(M,N) ; Amt Exceed Per Benefit Max
- QUIT $$500(M,N,20)
- 521(M,N) ; Incentive Fee Paid
- QUIT $$500(M,N,21)
- 523(M,N) ; Amount Attributed to Sales Tax
- QUIT $$500(M,N,23)
- 500(M,N,J) ; field #500+J signed numeric
- +1 if 'M!'N
- QUIT ""
- +2 NEW X
- SET X=$PIECE($GET(^BPSR(M,1000,N,500)),U,J)
- +3 IF $EXTRACT(X,1,2)?2U
- SET X=$EXTRACT(X,3,$LENGTH(X))
- +4 SET X=$$DFF2EXT(X)
- +5 QUIT X
- +6 ;
- RESPONSE(BPSRX,BPSFILL,BPSCOB) ; Pull fields from response.
- +1 ; MRD;BPS*1.0*20 - Created this API to display additional information
- +2 ; to the user when an RRR is successfully resubmitted.
- +3 ; Input: (r) BPSRX - Rx IEN (#52)
- +4 ; (o) BPSFILL - Refill#
- +5 ; (o) BPSCOB - Payer Sequence
- +6 ; Output: [1] Total Amount Paid, file# 9002313.0301, field #509
- +7 ; [2] Ingredient Cost Paid, field #506
- +8 ; [3] Amount of Copay/Coinsurance, field #518
- +9 ; [4] Dispensing Fee Paid, field #507
- +10 ; [5] Amount Applied to Periodic Deductible, field #517
- +11 ; [6] Remaining Deductible Amount, field #513
- +12 ;
- +13 NEW BPSPOS,BPSRESP,BPSTRAN,BPSX
- +14 ;
- +15 ; If no Rx passed in, Quit with "".
- IF '$GET(BPSRX)
- QUIT ""
- +16 ; Default Fill to 0 if none.
- IF $GET(BPSFILL)=""
- SET BPSFILL=0
- +17 ; Default COB to 1/primary if none.
- IF '$GET(BPSCOB)
- SET BPSCOB=1
- +18 ;
- +19 ; Use $$CLAIM^BPSBUTL to determine the BPS Transaction and BPS Response
- +20 ; based on the Rx, Fill, COB.
- +21 ;
- +22 SET BPSX=$$CLAIM^BPSBUTL(BPSRX,BPSFILL,BPSCOB)
- +23 ; BPS Transaction.
- SET BPSTRAN=$PIECE(BPSX,U,1)
- +24 ; BPS Response.
- SET BPSRESP=$PIECE(BPSX,U,3)
- +25 IF BPSTRAN=""!(BPSRESP="")
- QUIT ""
- +26 ;
- +27 ; Pull the field Position in Claim from the BPS Transaction file.
- +28 ;
- +29 SET BPSPOS=$$GET1^DIQ(9002313.59,BPSTRAN,14)
- +30 IF '$GET(BPSPOS)
- SET BPSPOS=1
- +31 ;
- +32 SET BPSX=$$509(BPSRESP,BPSPOS)_"^"_$$506(BPSRESP,BPSPOS)
- +33 SET BPSX=BPSX_"^"_$$518(BPSRESP,BPSPOS)_"^"_$$507(BPSRESP,BPSPOS)
- +34 SET BPSX=BPSX_"^"_$$517(BPSRESP,BPSPOS)_"^"_$$513(BPSRESP,BPSPOS)
- +35 ;
- +36 QUIT BPSX
- +37 ;