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

BPSOS03.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. ; General utilities for retrieval from 9002313.03, Claim Response
  1. ; $$INSPAID is used by BPSOSQL
  1. INSPAID(N) ;EP - from BPSOSQL - total amount paid by insurer
  1. N RX,TOT,X S (TOT,RX)=0
  1. F S RX=$O(^BPSR(N,1000,RX)) Q:'RX D
  1. . ; Try Gross Amount Due, and if that's zero, Usual and Customary
  1. . S X=$$INSPAID1(N,RX)
  1. . S TOT=TOT+X
  1. Q TOT
  1. INSPAID1(N,RX) ;EP -
  1. N X S X=$$509(N,RX) Q X
  1. NETPAID1(N,RX) ; EP - computed field in 9002313.57 and 9002313.59
  1. N X S X=$$509(N,RX) ; X = (#509) Total Amount Paid
  1. N SUB S SUB=1 ; Do we need to subtract (#505) Patient Pay Amount?
  1. N IEN02,INS,FMT S IEN02=$P(^BPSR(RESP,0),U)
  1. I IEN02 D
  1. . S INS=$P($G(^BPSC(IEN02,0)),U,2) Q:'INS ;IHS/SD/lwj 9/11/02
  1. . S FMT=INS
  1. . N X S X=$P(^BPSF(9002313.92,FMT,1),U,10)
  1. . I X S SUB=0 ; Total paid means total paid by insurance
  1. I SUB S X=X-$$505(N,RX)
  1. I X<0,SUB D ; apparently this format is supposed to be excl.
  1. . Q:'$G(FMT)
  1. . S $P(^BPSF(9002313.92,FMT,1),U,10)=1
  1. . S X=X+$$505(N,RX) ;*1.26*1*
  1. Q X
  1. REJTEXT(RESP,POS,ARR) ; EP - fills array (passed by ref)
  1. K ARR
  1. N A,I,X,R S (A,I)=0
  1. F S A=$O(^BPSR(RESP,1000,POS,511,A)) Q:'A D
  1. . S R=$P(^BPSR(RESP,1000,POS,511,A,0),U)
  1. . Q:R=""
  1. . N S S S=$O(^BPSF(9002313.93,"B",R,0))
  1. . I S S X=$TR($G(^BPSF(9002313.93,S,0)),U,":")
  1. . E S X=R_" unrecognized reject code"
  1. . S I=I+1,ARR(I)=X
  1. Q
  1. MESSAGE(RESP,POS,N) ; EP - get additional message from response
  1. I '$G(RESP) Q ""
  1. I '$G(POS) S POS=1
  1. I $G(N)=1 Q $P($G(^BPSR(RESP,504)),U)
  1. I $G(N)=2 N MSG S MSG="" D Q MSG
  1. . N ADDMESS,N
  1. . D ADDMESS^BPSSCRLG(RESP,POS,.ADDMESS)
  1. . S N="" F S N=$O(ADDMESS(N)) Q:'N S MSG=MSG_$S(N=1:"",1:"~")_ADDMESS(N)
  1. Q $$MESSAGE(RESP,POS,1)_$$MESSAGE(RESP,POS,2)
  1. ;
  1. DFF2EXT(X) Q $$DFF2EXT^BPSECFM(X)
  1. 505(M,N) Q $$500(M,N,5) ; Patient Pay Amount
  1. 506(M,N) Q $$500(M,N,6) ; Ingredient Cost Paid
  1. 507(M,N) Q $$500(M,N,7) ; Dispensing Fee Paid
  1. 508(M,N) Q $$500(M,N,8) ; Sales Tax Paid
  1. 509(M,N) Q $$500(M,N,9) ; Total Amount Paid
  1. 512(M,N) Q $$500(M,N,12) ; Accumulated Deductible Amount
  1. 513(M,N) Q $$500(M,N,13) ; Remaining Deductible Amount
  1. 514(M,N) Q $$500(M,N,14) ; Remaining Benefit Amount
  1. 517(M,N) Q $$500(M,N,17) ; Amt Applied to Periodic Deduct
  1. 518(M,N) Q $$500(M,N,18) ; Amount of Copay/CoInsurance
  1. 519(M,N) Q $$500(M,N,19) ; Amt Attrib to Prod Selection
  1. 520(M,N) Q $$500(M,N,20) ; Amt Exceed Per Benefit Max
  1. 521(M,N) Q $$500(M,N,21) ; Incentive Fee Paid
  1. 523(M,N) Q $$500(M,N,23) ; Amount Attributed to Sales Tax
  1. 500(M,N,J) ; field #500+J signed numeric
  1. Q:'M!'N ""
  1. N X S X=$P($G(^BPSR(M,1000,N,500)),U,J)
  1. I $E(X,1,2)?2U S X=$E(X,3,$L(X))
  1. S X=$$DFF2EXT(X)
  1. Q X
  1. ;
  1. RESPONSE(BPSRX,BPSFILL,BPSCOB) ; Pull fields from response.
  1. ; MRD;BPS*1.0*20 - Created this API to display additional information
  1. ; to the user when an RRR is successfully resubmitted.
  1. ; Input: (r) BPSRX - Rx IEN (#52)
  1. ; (o) BPSFILL - Refill#
  1. ; (o) BPSCOB - Payer Sequence
  1. ; Output: [1] Total Amount Paid, file# 9002313.0301, field #509
  1. ; [2] Ingredient Cost Paid, field #506
  1. ; [3] Amount of Copay/Coinsurance, field #518
  1. ; [4] Dispensing Fee Paid, field #507
  1. ; [5] Amount Applied to Periodic Deductible, field #517
  1. ; [6] Remaining Deductible Amount, field #513
  1. ;
  1. N BPSPOS,BPSRESP,BPSTRAN,BPSX
  1. ;
  1. I '$G(BPSRX) Q "" ; If no Rx passed in, Quit with "".
  1. I $G(BPSFILL)="" S BPSFILL=0 ; Default Fill to 0 if none.
  1. I '$G(BPSCOB) S BPSCOB=1 ; Default COB to 1/primary if none.
  1. ;
  1. ; Use $$CLAIM^BPSBUTL to determine the BPS Transaction and BPS Response
  1. ; based on the Rx, Fill, COB.
  1. ;
  1. S BPSX=$$CLAIM^BPSBUTL(BPSRX,BPSFILL,BPSCOB)
  1. S BPSTRAN=$P(BPSX,U,1) ; BPS Transaction.
  1. S BPSRESP=$P(BPSX,U,3) ; BPS Response.
  1. I BPSTRAN=""!(BPSRESP="") Q ""
  1. ;
  1. ; Pull the field Position in Claim from the BPS Transaction file.
  1. ;
  1. S BPSPOS=$$GET1^DIQ(9002313.59,BPSTRAN,14)
  1. I '$G(BPSPOS) S BPSPOS=1
  1. ;
  1. S BPSX=$$509(BPSRESP,BPSPOS)_"^"_$$506(BPSRESP,BPSPOS)
  1. S BPSX=BPSX_"^"_$$518(BPSRESP,BPSPOS)_"^"_$$507(BPSRESP,BPSPOS)
  1. S BPSX=BPSX_"^"_$$517(BPSRESP,BPSPOS)_"^"_$$513(BPSRESP,BPSPOS)
  1. ;
  1. Q BPSX
  1. ;