BPSTEST2.m

BPSTEST2 ;AITC/CKB - ECME TESTING TOOL ;5/31/2018

 ;;1.0;E CLAIMS MGMT ENGINE;**24,26,28**;JUN 2004;Build 22

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 Q

 ;

SETOVER ;

 ; the following code was from SETOVER^BPSTEST and is called by SETOVER^BPSTEST

 ;

 ; If a eligibility, check for specific reversal overrides and set

 I BPSTYPE="E1" D  Q

 . S BPSRRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.08,"I")

 . ;

 . ; If the response is Stranded, force an <UNDEF> error

 . I BPSRRESP="T" S BPSXXXX=BPSUNDEF

 . I BPSRRESP]"" S BPSDATA(1,112)=BPSRRESP

 . S BPSDATA(9002313.03,9002313.03,"+1,",501)=$S(BPSRRESP="R":"R",1:"A")

 . ; 

 . ; If the response is accepted, delete the reject code count and codes

 . I BPSRRESP="A" K BPSDATA(1,510),BPSDATA(1,511)

 . ; 

 . ; If the response is rejected, delete the rejections returned by payers

 . ;   and put in the ones entered by the user

 . I BPSRRESP="R" D

 .. K BPSDATA(1,509),BPSDATA(1,511)

 .. S BPSRCNT=0

 .. S BPSRIEN=0 F  S BPSRIEN=$O(^BPS(9002313.32,BPSTIEN,1,BPSRIEN)) Q:+BPSRIEN=0  D

 ... S BPSRCODE=$P($G(^BPS(9002313.32,BPSTIEN,1,BPSRIEN,0)),"^",1)

 ... ; Increment counter and store

 ... I BPSRCODE]"" D

 .... S BPSRCD=$$GET1^DIQ(9002313.93,BPSRCODE_",",.01,"E")

 .... I BPSRCD]"" S BPSRCNT=BPSRCNT+1,BPSDATA(1,511,BPSRCNT)=BPSRCD

 .. ; Store total number of rejections

 .. S BPSDATA(1,510)=BPSRCNT

 ;

 ; If a reversal, check for specific reversal overrides and set

 I BPSTYPE="B2" D

 . S BPSRRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.05,"I")

 . ;

 . ; If the response is Stranded, force an <UNDEF> error

 . I BPSRRESP="T" S BPSXXXX=BPSUNDEF

 . I BPSRRESP]"" S BPSDATA(1,112)=$S(BPSRRESP="D":"T",1:BPSRRESP)

 . S BPSDATA(9002313.03,9002313.03,"+1,",501)=$S(BPSRRESP="R":"R",1:"A")

 . ;

 . ; If the response is accepted or duplicate, kill the reject code count and codes

 . I BPSRRESP="A"!(BPSRRESP="D")!(BPSRRESP="Q")!(BPSRRESP="S") K BPSDATA(1,510),BPSDATA(1,511)

 . ;

 . ; If the response is rejected, set the reject codes

 . I BPSRRESP="R" D SETREJ^BPSTEST(BPSTRANS)

 ;

 ; If a submission, check for specific submission overrides and set

 I BPSTYPE="B1" D

 . ; Get submission response

 . S BPSSRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.03,"I")

 . ;

 . ; If the response is Stranded, force an <UNDEF> error

 . I BPSSRESP="T" S BPSXXXX=BPSUNDEF

 . ;

 . ; If BPSSRESP exists, file it

 . I BPSSRESP]"" D

 .. S BPSDATA(1,112)=BPSSRESP

 .. S BPSDATA(9002313.03,9002313.03,"+1,",501)=$S(BPSSRESP="R":"R",1:"A")

 .. ; If payable or duplicate, get the BPSPAID amount and file it if it

 .. ; exists.  Also delete any reject codes

 .. I BPSSRESP="P"!(BPSSRESP="D")!(BPSSRESP="Q")!(BPSSRESP="S") D

 ... ;

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.1,"I")             ; 505-F5 Patient Pay Amount

 ... I BPSX]"" S BPSDATA(1,505)=$$DFF^BPSECFM(BPSX,10)

 ... ;

 ... S BPSPAID=$$GET1^DIQ(9002313.32,BPSTIEN_",",.04,"I")

 ... I BPSPAID]"" S BPSDATA(1,509)=$$DFF^BPSECFM(BPSPAID,8)         ; 509 Total amount paid

 ... ;

 ... K BPSDATA(1,510),BPSDATA(1,511)      ; kill Reject Count (510) and Reject Code (511)

 ... ;

 ... S BPSCOPAY=$$GET1^DIQ(9002313.32,BPSTIEN_",",.06,"I")

 ... I BPSCOPAY]"" S BPSDATA(1,518)=$$DFF^BPSECFM(BPSCOPAY,8)       ; 518 Copay Amount

 ... ;

 ... S BPS506=$$GET1^DIQ(9002313.32,BPSTIEN_",",.15,"I")

 ... I BPS506]"" S BPSDATA(1,506)=$$DFF^BPSECFM(BPS506,8)           ; 506 Ingredient Cost Paid

 ... ;

 ... S BPS507=$$GET1^DIQ(9002313.32,BPSTIEN_",",.16,"I")

 ... I BPS507]"" S BPSDATA(1,507)=$$DFF^BPSECFM(BPS507,8)           ; 507 Dispensing Fee Paid

 ... ;

 ... S BPS513=$$GET1^DIQ(9002313.32,BPSTIEN_",",.17,"I")

 ... I BPS513]"" S BPSDATA(1,513)=$$DFF^BPSECFM(BPS513,8)           ; 513 Remaining Deductible Amount

 ... ;

 ... S BPS517=$$GET1^DIQ(9002313.32,BPSTIEN_",",.18,"I")

 ... I BPS517]"" S BPSDATA(1,517)=$$DFF^BPSECFM(BPS517,8)           ; 517 Amount Applied to Periodic Deductible

 ... Q

 .. ;

 .. ;if not Stranded (BPSSRESP="T") prompt for the following fields

 .. I BPSSRESP'="T" D

 ... ; D1-D9 fields (BPS*1*15)

 ... S BPSAJPAY=$$GET1^DIQ(9002313.32,BPSTIEN_",",.1,"I")           ; Adjudicated Payment Type

 ... I BPSAJPAY]"" S BPSDATA(1,1028)=$$NFF^BPSECFM(BPSAJPAY,2)

 ... S BPSNFLDT=$$GET1^DIQ(9002313.32,BPSTIEN_",",.09,"I")          ; Override Next Available Fill

 ... I BPSNFLDT]"" S BPSDATA(1,2004)=$$DTF1^BPSECFM(BPSNFLDT)

 ... ;

 ... ; E0-E6 overrides (BPS*1*19)

 ... ; PERCENTAGE SALES TAX BASIS PAID

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.01,"I")

 ... I BPSX]"" S BPSDATA(1,561)=BPSX

 ... ; OTHER AMOUNT PAID QUALIFIER and associated field

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.02,"I")

 ... I BPSX]"" S BPSDATA(1,564,1)=$$NFF^BPSECFM(BPSX,2),BPSDATA(1,565,1)=$$DFF^BPSECFM(5.64,8),BPSDATA(1,563)=1

 ... ; PAYER ID QUALIFIER

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.03,"I")

 ... I BPSX]"" S BPSDATA(9002313.03,9002313.03,"+1,",568)=BPSX

 ... ; HELP DESK TELEPHONE NUMBER EXTENSION

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.04,"I")

 ... I BPSX]"" S BPSDATA(1,2022)=$$NFF^BPSECFM(BPSX,8)

 ... ; PROFESSIONAL SERVICE FEE CONTRACTED/REIMURSEMENT AMOUNT

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.05,"I")

 ... I BPSX]"" S BPSDATA(1,2033)=$$DFF^BPSECFM(BPSX,8)

 ... ; OTHER PAYER HELPDESK TELEPHONE EXTENSION

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.06,"I")

 ... I BPSX]"" S BPSDATA(1,2023,1)=$$NFF^BPSECFM(BPSX,8),BPSDATA(1,338,1)="01"

 ... ; RESPONSE INTERMEDIARY AUTHORIZATION TYPE ID and associated fields

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.07,"I")

 ... I BPSX]"" S BPSDATA(1,2053,1)=$$NFF^BPSECFM(BPSX,2),BPSDATA(1,2052)=1

 ... ; RESPONSE INTERMEDIARY AUTHORIZATION ID and associated fields

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.08,"I")

 ... I BPSX]"" S BPSDATA(1,2054,1)=$$ANFF^BPSECFM(BPSX,20),BPSDATA(1,2052)=1

 ... ; INTERMEDIARY MESSAGE and associated fields

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",3.01,"I")

 ... I BPSX]"" S BPSDATA(1,2051,1)=$$ANFF^BPSECFM(BPSX,200),BPSDATA(1,2052)=1

 ... ; (BPS*1*22)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.09,"I") ; B98-34 reconciliation id

 ... I BPSX]"" S BPSDATA(1,2098)=$$ANFF^BPSECFM(BPSX,30)

 ... ;

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.11,"E") ; 439-E4 reason for service code

 ... I BPSX]"" S BPSDATA(1,439,1)=$$ANFF^BPSECFM(BPSX,4),BPSDATA(1,567,1)=1

 ... ;

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.01,"I") ; 931-F8 maximum age qualifier

 ... I BPSX]"" S BPSDATA(1,931)=$$ANFF^BPSECFM(BPSX,1)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.02,"I") ; 932-GA maximum age

 ... I BPSX]"" S BPSDATA(1,932)=$$NFF^BPSECFM(BPSX,3)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.03,"I") ; 933-GB maximum amount

 ... I BPSX]"" S BPSDATA(1,933)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.04,"I") ; 934-GC maximum amt qualifier

 ... I BPSX]"" S BPSDATA(1,934)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.05,"I") ; 935-GF maximum amt time period

 ... I BPSX]"" S BPSDATA(1,935)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.06,"I") ; 936-GG maximum amt time period start date

 ... I BPSX]"" S BPSDATA(1,936)=$$DTF1^BPSECFM(BPSX)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.07,"I") ; 937-GH maximum amt time period end date

 ... I BPSX]"" S BPSDATA(1,937)=$$DTF1^BPSECFM(BPSX)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.08,"I") ; 938-GJ maximum amt time period units

 ... I BPSX]"" S BPSDATA(1,938)=$$NFF^BPSECFM(BPSX,4)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.09,"I") ; 943-GQ minimum age qualifier

 ... I BPSX]"" S BPSDATA(1,943)=$$ANFF^BPSECFM(BPSX,1)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.1,"I") ; 944-GR minimum age

 ... I BPSX]"" S BPSDATA(1,944)=$$NFF^BPSECFM(BPSX,3)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.11,"I") ; C47-9T other payer adjudicate prog type

 ... I BPSX]"" S BPSDATA(1,2147)=$$ANFF^BPSECFM(BPSX,30)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.12,"I") ; C93-KN patient pay component amount

 ... I BPSX]"" S BPSDATA(1,2193)=$$DFF^BPSECFM(BPSX,8)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.13,"I") ; C94-KP patient pay component count

 ... I BPSX]"" S BPSDATA(1,2194)=$$NFF^BPSECFM(BPSX,4)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.14,"I") ; C95-KQ patient payer component qualifier

 ... I BPSX]"" S BPSDATA(1,2195)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.15,"I") ; D19-M1 minimum amount

 ... I BPSX]"" S BPSDATA(1,2219)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.16,"I") ; D20-M2 minimum amount qualifier

 ... I BPSX]"" S BPSDATA(1,2220)=$$ANFF^BPSECFM(BPSX,3)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.17,"I") ; D23-M5 other payer name

 ... I BPSX]"" S BPSDATA(1,2223)=$$ANFF^BPSECFM(BPSX,30)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.18,"I") ; D24-M6 remaining amount

 ... I BPSX]"" S BPSDATA(1,2224)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.19,"I") ; D25-M7 remaining amount qualifier

 ... I BPSX]"" S BPSDATA(1,2225)=$$ANFF^BPSECFM(BPSX,3)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.2,"I") ; D41-PA other payer relationship type

 ... I BPSX]"" S BPSDATA(1,2241)=$$ANFF^BPSECFM(BPSX,3)

 ... ;

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.01,"I") ; E87-ZV invalid provider data source

 ... I BPSX]"" S BPSDATA(1,2387)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.02,"I") ; E89-ZO formulary alternative eff date

 ... I BPSX]"" S BPSDATA(1,2389)=$$DTF1^BPSECFM(BPSX)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.03,"I") ; E93-ZC dur/due co-agent description

 ... I BPSX]"" S BPSDATA(1,2393)=$$ANFF^BPSECFM(BPSX,40)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.04,"I") ; E94-ZA unit of prior dispensed qty

 ... I BPSX]"" S BPSDATA(1,2394)=$$ANFF^BPSECFM(BPSX,3)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.05,"I") ; E95-Z9 other pharmacy id qualifier

 ... I BPSX]"" S BPSDATA(1,2395)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.06,"I") ; E97-Z7 other pharmacy name

 ... I BPSX]"" S BPSDATA(1,2397)=$$ANFF^BPSECFM(BPSX,70)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.07,"I") ; E98-Z6 other pharmacy telephone 

 ... I BPSX]"" S BPSDATA(1,2398)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.08,"I") ; E99-Z5 other prescriber last name

 ... I BPSX]"" S BPSDATA(1,2399)=$$ANFF^BPSECFM(BPSX,35)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.09,"I") ; F01-Z4 other prescriber id qualifier

 ... I BPSX]"" S BPSDATA(1,2401)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.10,"I") ; F02-Z3 other prescriber id

 ... I BPSX]"" S BPSDATA(1,2402)=$$ANFF^BPSECFM(BPSX,35)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.11,"I") ; F03-Z2 other prescriber phone number

 ... I BPSX]"" S BPSDATA(1,2403)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.12,"I") ; F04-Z1 dur/due compound product id

 ... I BPSX]"" S BPSDATA(1,2404)=$$ANFF^BPSECFM(BPSX,40)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.13,"I") ; F05-Z0 dur/due compound product id qualifier

 ... I BPSX]"" S BPSDATA(1,2405)=$$ANFF^BPSECFM(BPSX,2)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.14,"I") ; F06-YO dur/due maximum daily dose qty

 ... I BPSX]"" S BPSDATA(1,2406)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.15,"I") ; F07-YL dur/due max daily dose - unit

 ... I BPSX]"" S BPSDATA(1,2407)=$$ANFF^BPSECFM(BPSX,3)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.16,"I") ; F08-YJ dur/due minimum daily dose qty

 ... I BPSX]"" S BPSDATA(1,2408)=$$NFF^BPSECFM(BPSX,10)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.17,"I") ; F09-YI dur/due min daily dose - unit

 ... I BPSX]"" S BPSDATA(1,2409)=$$ANFF^BPSECFM(BPSX,3)

 ... ;

 ... ; E7 overrides (BPS*1*20)

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",.11,"I") I BPSX'="" D     ; B88-3R quantity limit per spec time period

 .... S BPSDATA(1,2087)=1                          ; count field

 .... S BPSDATA(1,2088,1)=$$NFF^BPSECFM(BPSX,10)   ; data from override file

 .... Q

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",.12,"I") I BPSX'="" D     ; B89-3S quantity limit time period

 .... S BPSDATA(1,2087)=1                          ; count field

 .... S BPSDATA(1,2089,1)=$$NFF^BPSECFM(BPSX,5)    ; data from override file

 .... Q

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",.13,"I") I BPSX'="" D     ; B91-3W days supply limit per spec time period

 .... S BPSDATA(1,2090)=1                          ; count field

 .... S BPSDATA(1,2091,1)=$$NFF^BPSECFM(BPSX,3)    ; data from override file

 .... Q

 ... S BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",.14,"I") I BPSX'="" D     ; B92-3X days supply limit time period

 .... S BPSDATA(1,2090)=1                          ; count field

 .... S BPSDATA(1,2092,1)=$$NFF^BPSECFM(BPSX,5)    ; data from override file

 .... Q

 ... Q

 .. ;

 .. ; If rejected, get the rejection code and file them

 .. ; Also, delete the BPSPAID amount

 .. I BPSSRESP="R" D

 ... ; Delete old rejections and BPSPAID amount

 ... K BPSDATA(1,509),BPSDATA(1,511)

 ... ; Loop through rejections and store

 ... S BPSRCNT=0

 ... S BPSRIEN=0 F  S BPSRIEN=$O(^BPS(9002313.32,BPSTIEN,1,BPSRIEN)) Q:+BPSRIEN=0  D

 .... S BPSRCODE=$P($G(^BPS(9002313.32,BPSTIEN,1,BPSRIEN,0)),"^",1)

 .... ; Increment counter and store

 .... I BPSRCODE]"" D

 ..... S BPSRCD=$$GET1^DIQ(9002313.93,BPSRCODE_",",.01,"E")

 ..... I BPSRCD]"" S BPSRCNT=BPSRCNT+1,BPSDATA(1,511,BPSRCNT)=BPSRCD

 ... ; Store total number of rejections

 ... S BPSDATA(1,510)=BPSRCNT

 ;

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---BPSTEST2   13769     printed  Apr 23, 2025@18:07:59                                                                                                                                                                                                   Page 2

BPSTEST2  ;AITC/CKB - ECME TESTING TOOL ;5/31/2018

 +1       ;;1.0;E CLAIMS MGMT ENGINE;**24,26,28**;JUN 2004;Build 22

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4        QUIT 

 +5       ;

SETOVER   ;

 +1       ; the following code was from SETOVER^BPSTEST and is called by SETOVER^BPSTEST

 +2       ;

 +3       ; If a eligibility, check for specific reversal overrides and set

 +4        IF BPSTYPE="E1"

               Begin DoDot:1

 +5                SET BPSRRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.08,"I")

 +6       ;

 +7       ; If the response is Stranded, force an <UNDEF> error

 +8                IF BPSRRESP="T"

                       SET BPSXXXX=BPSUNDEF

 +9                IF BPSRRESP]""

                       SET BPSDATA(1,112)=BPSRRESP

 +10               SET BPSDATA(9002313.03,9002313.03,"+1,",501)=$SELECT(BPSRRESP="R":"R",1:"A")

 +11      ; 

 +12      ; If the response is accepted, delete the reject code count and codes

 +13               IF BPSRRESP="A"

                       KILL BPSDATA(1,510),BPSDATA(1,511)

 +14      ; 

 +15      ; If the response is rejected, delete the rejections returned by payers

 +16      ;   and put in the ones entered by the user

 +17               IF BPSRRESP="R"

                       Begin DoDot:2

 +18                       KILL BPSDATA(1,509),BPSDATA(1,511)

 +19                       SET BPSRCNT=0

 +20                       SET BPSRIEN=0

                           FOR 

                               SET BPSRIEN=$ORDER(^BPS(9002313.32,BPSTIEN,1,BPSRIEN))

                               if +BPSRIEN=0

                                   QUIT 

                               Begin DoDot:3

 +21                               SET BPSRCODE=$PIECE($GET(^BPS(9002313.32,BPSTIEN,1,BPSRIEN,0)),"^",1)

 +22      ; Increment counter and store

 +23                               IF BPSRCODE]""

                                       Begin DoDot:4

 +24                                       SET BPSRCD=$$GET1^DIQ(9002313.93,BPSRCODE_",",.01,"E")

 +25                                       IF BPSRCD]""

                                               SET BPSRCNT=BPSRCNT+1

                                               SET BPSDATA(1,511,BPSRCNT)=BPSRCD

                                       End DoDot:4

                               End DoDot:3

 +26      ; Store total number of rejections

 +27                       SET BPSDATA(1,510)=BPSRCNT

                       End DoDot:2

               End DoDot:1

               QUIT 

 +28      ;

 +29      ; If a reversal, check for specific reversal overrides and set

 +30       IF BPSTYPE="B2"

               Begin DoDot:1

 +31               SET BPSRRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.05,"I")

 +32      ;

 +33      ; If the response is Stranded, force an <UNDEF> error

 +34               IF BPSRRESP="T"

                       SET BPSXXXX=BPSUNDEF

 +35               IF BPSRRESP]""

                       SET BPSDATA(1,112)=$SELECT(BPSRRESP="D":"T",1:BPSRRESP)

 +36               SET BPSDATA(9002313.03,9002313.03,"+1,",501)=$SELECT(BPSRRESP="R":"R",1:"A")

 +37      ;

 +38      ; If the response is accepted or duplicate, kill the reject code count and codes

 +39               IF BPSRRESP="A"!(BPSRRESP="D")!(BPSRRESP="Q")!(BPSRRESP="S")

                       KILL BPSDATA(1,510),BPSDATA(1,511)

 +40      ;

 +41      ; If the response is rejected, set the reject codes

 +42               IF BPSRRESP="R"

                       DO SETREJ^BPSTEST(BPSTRANS)

               End DoDot:1

 +43      ;

 +44      ; If a submission, check for specific submission overrides and set

 +45       IF BPSTYPE="B1"

               Begin DoDot:1

 +46      ; Get submission response

 +47               SET BPSSRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.03,"I")

 +48      ;

 +49      ; If the response is Stranded, force an <UNDEF> error

 +50               IF BPSSRESP="T"

                       SET BPSXXXX=BPSUNDEF

 +51      ;

 +52      ; If BPSSRESP exists, file it

 +53               IF BPSSRESP]""

                       Begin DoDot:2

 +54                       SET BPSDATA(1,112)=BPSSRESP

 +55                       SET BPSDATA(9002313.03,9002313.03,"+1,",501)=$SELECT(BPSSRESP="R":"R",1:"A")

 +56      ; If payable or duplicate, get the BPSPAID amount and file it if it

 +57      ; exists.  Also delete any reject codes

 +58                       IF BPSSRESP="P"!(BPSSRESP="D")!(BPSSRESP="Q")!(BPSSRESP="S")

                               Begin DoDot:3

 +59      ;

 +60      ; 505-F5 Patient Pay Amount

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.1,"I")

 +61                               IF BPSX]""

                                       SET BPSDATA(1,505)=$$DFF^BPSECFM(BPSX,10)

 +62      ;

 +63                               SET BPSPAID=$$GET1^DIQ(9002313.32,BPSTIEN_",",.04,"I")

 +64      ; 509 Total amount paid

                                   IF BPSPAID]""

                                       SET BPSDATA(1,509)=$$DFF^BPSECFM(BPSPAID,8)

 +65      ;

 +66      ; kill Reject Count (510) and Reject Code (511)

                                   KILL BPSDATA(1,510),BPSDATA(1,511)

 +67      ;

 +68                               SET BPSCOPAY=$$GET1^DIQ(9002313.32,BPSTIEN_",",.06,"I")

 +69      ; 518 Copay Amount

                                   IF BPSCOPAY]""

                                       SET BPSDATA(1,518)=$$DFF^BPSECFM(BPSCOPAY,8)

 +70      ;

 +71                               SET BPS506=$$GET1^DIQ(9002313.32,BPSTIEN_",",.15,"I")

 +72      ; 506 Ingredient Cost Paid

                                   IF BPS506]""

                                       SET BPSDATA(1,506)=$$DFF^BPSECFM(BPS506,8)

 +73      ;

 +74                               SET BPS507=$$GET1^DIQ(9002313.32,BPSTIEN_",",.16,"I")

 +75      ; 507 Dispensing Fee Paid

                                   IF BPS507]""

                                       SET BPSDATA(1,507)=$$DFF^BPSECFM(BPS507,8)

 +76      ;

 +77                               SET BPS513=$$GET1^DIQ(9002313.32,BPSTIEN_",",.17,"I")

 +78      ; 513 Remaining Deductible Amount

                                   IF BPS513]""

                                       SET BPSDATA(1,513)=$$DFF^BPSECFM(BPS513,8)

 +79      ;

 +80                               SET BPS517=$$GET1^DIQ(9002313.32,BPSTIEN_",",.18,"I")

 +81      ; 517 Amount Applied to Periodic Deductible

                                   IF BPS517]""

                                       SET BPSDATA(1,517)=$$DFF^BPSECFM(BPS517,8)

 +82                               QUIT 

                               End DoDot:3

 +83      ;

 +84      ;if not Stranded (BPSSRESP="T") prompt for the following fields

 +85                       IF BPSSRESP'="T"

                               Begin DoDot:3

 +86      ; D1-D9 fields (BPS*1*15)

 +87      ; Adjudicated Payment Type

                                   SET BPSAJPAY=$$GET1^DIQ(9002313.32,BPSTIEN_",",.1,"I")

 +88                               IF BPSAJPAY]""

                                       SET BPSDATA(1,1028)=$$NFF^BPSECFM(BPSAJPAY,2)

 +89      ; Override Next Available Fill

                                   SET BPSNFLDT=$$GET1^DIQ(9002313.32,BPSTIEN_",",.09,"I")

 +90                               IF BPSNFLDT]""

                                       SET BPSDATA(1,2004)=$$DTF1^BPSECFM(BPSNFLDT)

 +91      ;

 +92      ; E0-E6 overrides (BPS*1*19)

 +93      ; PERCENTAGE SALES TAX BASIS PAID

 +94                               SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.01,"I")

 +95                               IF BPSX]""

                                       SET BPSDATA(1,561)=BPSX

 +96      ; OTHER AMOUNT PAID QUALIFIER and associated field

 +97                               SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.02,"I")

 +98                               IF BPSX]""

                                       SET BPSDATA(1,564,1)=$$NFF^BPSECFM(BPSX,2)

                                       SET BPSDATA(1,565,1)=$$DFF^BPSECFM(5.64,8)

                                       SET BPSDATA(1,563)=1

 +99      ; PAYER ID QUALIFIER

 +100                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.03,"I")

 +101                              IF BPSX]""

                                       SET BPSDATA(9002313.03,9002313.03,"+1,",568)=BPSX

 +102     ; HELP DESK TELEPHONE NUMBER EXTENSION

 +103                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.04,"I")

 +104                              IF BPSX]""

                                       SET BPSDATA(1,2022)=$$NFF^BPSECFM(BPSX,8)

 +105     ; PROFESSIONAL SERVICE FEE CONTRACTED/REIMURSEMENT AMOUNT

 +106                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.05,"I")

 +107                              IF BPSX]""

                                       SET BPSDATA(1,2033)=$$DFF^BPSECFM(BPSX,8)

 +108     ; OTHER PAYER HELPDESK TELEPHONE EXTENSION

 +109                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.06,"I")

 +110                              IF BPSX]""

                                       SET BPSDATA(1,2023,1)=$$NFF^BPSECFM(BPSX,8)

                                       SET BPSDATA(1,338,1)="01"

 +111     ; RESPONSE INTERMEDIARY AUTHORIZATION TYPE ID and associated fields

 +112                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.07,"I")

 +113                              IF BPSX]""

                                       SET BPSDATA(1,2053,1)=$$NFF^BPSECFM(BPSX,2)

                                       SET BPSDATA(1,2052)=1

 +114     ; RESPONSE INTERMEDIARY AUTHORIZATION ID and associated fields

 +115                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.08,"I")

 +116                              IF BPSX]""

                                       SET BPSDATA(1,2054,1)=$$ANFF^BPSECFM(BPSX,20)

                                       SET BPSDATA(1,2052)=1

 +117     ; INTERMEDIARY MESSAGE and associated fields

 +118                              SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",3.01,"I")

 +119                              IF BPSX]""

                                       SET BPSDATA(1,2051,1)=$$ANFF^BPSECFM(BPSX,200)

                                       SET BPSDATA(1,2052)=1

 +120     ; (BPS*1*22)

 +121     ; B98-34 reconciliation id

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.09,"I")

 +122                              IF BPSX]""

                                       SET BPSDATA(1,2098)=$$ANFF^BPSECFM(BPSX,30)

 +123     ;

 +124     ; 439-E4 reason for service code

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",2.11,"E")

 +125                              IF BPSX]""

                                       SET BPSDATA(1,439,1)=$$ANFF^BPSECFM(BPSX,4)

                                       SET BPSDATA(1,567,1)=1

 +126     ;

 +127     ; 931-F8 maximum age qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.01,"I")

 +128                              IF BPSX]""

                                       SET BPSDATA(1,931)=$$ANFF^BPSECFM(BPSX,1)

 +129     ; 932-GA maximum age

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.02,"I")

 +130                              IF BPSX]""

                                       SET BPSDATA(1,932)=$$NFF^BPSECFM(BPSX,3)

 +131     ; 933-GB maximum amount

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.03,"I")

 +132                              IF BPSX]""

                                       SET BPSDATA(1,933)=$$NFF^BPSECFM(BPSX,10)

 +133     ; 934-GC maximum amt qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.04,"I")

 +134                              IF BPSX]""

                                       SET BPSDATA(1,934)=$$ANFF^BPSECFM(BPSX,2)

 +135     ; 935-GF maximum amt time period

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.05,"I")

 +136                              IF BPSX]""

                                       SET BPSDATA(1,935)=$$ANFF^BPSECFM(BPSX,2)

 +137     ; 936-GG maximum amt time period start date

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.06,"I")

 +138                              IF BPSX]""

                                       SET BPSDATA(1,936)=$$DTF1^BPSECFM(BPSX)

 +139     ; 937-GH maximum amt time period end date

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.07,"I")

 +140                              IF BPSX]""

                                       SET BPSDATA(1,937)=$$DTF1^BPSECFM(BPSX)

 +141     ; 938-GJ maximum amt time period units

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.08,"I")

 +142                              IF BPSX]""

                                       SET BPSDATA(1,938)=$$NFF^BPSECFM(BPSX,4)

 +143     ; 943-GQ minimum age qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.09,"I")

 +144                              IF BPSX]""

                                       SET BPSDATA(1,943)=$$ANFF^BPSECFM(BPSX,1)

 +145     ; 944-GR minimum age

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.1,"I")

 +146                              IF BPSX]""

                                       SET BPSDATA(1,944)=$$NFF^BPSECFM(BPSX,3)

 +147     ; C47-9T other payer adjudicate prog type

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.11,"I")

 +148                              IF BPSX]""

                                       SET BPSDATA(1,2147)=$$ANFF^BPSECFM(BPSX,30)

 +149     ; C93-KN patient pay component amount

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.12,"I")

 +150                              IF BPSX]""

                                       SET BPSDATA(1,2193)=$$DFF^BPSECFM(BPSX,8)

 +151     ; C94-KP patient pay component count

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.13,"I")

 +152                              IF BPSX]""

                                       SET BPSDATA(1,2194)=$$NFF^BPSECFM(BPSX,4)

 +153     ; C95-KQ patient payer component qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.14,"I")

 +154                              IF BPSX]""

                                       SET BPSDATA(1,2195)=$$ANFF^BPSECFM(BPSX,2)

 +155     ; D19-M1 minimum amount

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.15,"I")

 +156                              IF BPSX]""

                                       SET BPSDATA(1,2219)=$$NFF^BPSECFM(BPSX,10)

 +157     ; D20-M2 minimum amount qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.16,"I")

 +158                              IF BPSX]""

                                       SET BPSDATA(1,2220)=$$ANFF^BPSECFM(BPSX,3)

 +159     ; D23-M5 other payer name

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.17,"I")

 +160                              IF BPSX]""

                                       SET BPSDATA(1,2223)=$$ANFF^BPSECFM(BPSX,30)

 +161     ; D24-M6 remaining amount

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.18,"I")

 +162                              IF BPSX]""

                                       SET BPSDATA(1,2224)=$$NFF^BPSECFM(BPSX,10)

 +163     ; D25-M7 remaining amount qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.19,"I")

 +164                              IF BPSX]""

                                       SET BPSDATA(1,2225)=$$ANFF^BPSECFM(BPSX,3)

 +165     ; D41-PA other payer relationship type

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",4.2,"I")

 +166                              IF BPSX]""

                                       SET BPSDATA(1,2241)=$$ANFF^BPSECFM(BPSX,3)

 +167     ;

 +168     ; E87-ZV invalid provider data source

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.01,"I")

 +169                              IF BPSX]""

                                       SET BPSDATA(1,2387)=$$ANFF^BPSECFM(BPSX,2)

 +170     ; E89-ZO formulary alternative eff date

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.02,"I")

 +171                              IF BPSX]""

                                       SET BPSDATA(1,2389)=$$DTF1^BPSECFM(BPSX)

 +172     ; E93-ZC dur/due co-agent description

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.03,"I")

 +173                              IF BPSX]""

                                       SET BPSDATA(1,2393)=$$ANFF^BPSECFM(BPSX,40)

 +174     ; E94-ZA unit of prior dispensed qty

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.04,"I")

 +175                              IF BPSX]""

                                       SET BPSDATA(1,2394)=$$ANFF^BPSECFM(BPSX,3)

 +176     ; E95-Z9 other pharmacy id qualifier

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.05,"I")

 +177                              IF BPSX]""

                                       SET BPSDATA(1,2395)=$$ANFF^BPSECFM(BPSX,2)

 +178     ; E97-Z7 other pharmacy name

                                   SET BPSX=$$GET1^DIQ(9002313.32,BPSTIEN_",",5.06,"I")