BPSPRRX3 ;ALB/SS - ePharmacy secondary billing ;16-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.
;
;External reference to file 399.3 supported by IA 3822
;External reference to $$INSUR^IBBAPI supported by IA 4419
;External reference to $$PLANEPS^IBNCPDPU supported by IA 5572
;
PROMPTS(RX,FILL,DOS,BPSPRARR) ;
;BPSPRARR - array to pass values determined earlier (if any) and to return user's input/corrections
;Input:
; RX - Prescription IEN
; FILL - Fill Number
; DOS - Date of Service
; BPSPRARR - Array of data passed by reference
;Returns
; 1 = the data is correct
; -1 = the data is not correct - Do not create the claim
;
; Check paramters
I '$G(RX) Q -1
I $G(FILL)="" Q -1
I '$G(DOS) Q -1
;
;
N BPQ,BPSQ,IEN59PR,DFN,BPSPLAN,BPX,BPSDFLT,BPSSET
N BPSPIEN,BPSSET,BPCNT,BPSRJ,BPSPAID,RETV,TOTAL
N BPRATTYP,BPSPDRJ,BPSPLNSL,BPX1,BPSFIEN,BPSPSARR,BPSPSHV
N IEN59SEC,BPSRET,BPSINS
;
S (BPQ,BPSQ)=0
;
; Other Payer IEN defaults to 1 since we don't do tertiary
S BPSPIEN=1
;
; Get Primary BPS Transaction
S IEN59PR=$$IEN59^BPSOSRX(RX,FILL,1)
;
; Get/validate Patient DFN
S DFN=$P($G(^BPST(IEN59PR,0)),U,6)
I DFN="" S DFN=$$RXAPI1^BPSUTIL1(RX,2,"I")
I DFN="" Q -1
;
; Get patient insurances
S BPSRET=$$INSUR^IBBAPI(DFN,DOS,"E",.BPSINS,"1,7,8")
;
; Get the first Secondary insurance for default
S BPSPRARR("PLAN")="",BPSPRARR("INS NAME")="",(BPX,BPQ)=0
F S BPX=$O(BPSINS("IBBAPI","INSUR",BPX)) Q:'BPX D Q:BPQ
. I $P(BPSINS("IBBAPI","INSUR",BPX,7),U)'=2 Q
. S BPSPRARR("PLAN")=$P(BPSINS("IBBAPI","INSUR",BPX,8),U)
. S BPSPRARR("INS NAME")=$P(BPSINS("IBBAPI","INSUR",BPX,1),U,2)
. S BPQ=1
. Q
;
; Get Rate Type for the Secondary Insurance
S IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2)
S BPSPRARR("RTYPE")=$$GETRTP59^BPSPRRX5(IEN59SEC)
I BPSPRARR("RTYPE")="" S BPSPRARR("RTYPE")=8
;
; Display current COB fields
D DISPSEC(.BPSPRARR)
;
S BPQ=0
I $G(BPSPRARR("PLAN"))=""!($G(BPSPRARR("RTYPE"))="")!($G(BPSPRARR("308-C8"))="") S BPQ=1
I BPSQ=0 F BPX=4,5 I $P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,BPX)="" S BPQ=1
I BPQ=0,'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")),'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) S BPQ=1
;
; Prompt to continue or not
W !
I BPQ=1 W !,"Required secondary claim information is missing. Enter all required information",!
E S BPQ=$$YESNO^BPSSCRRS("Do you want to edit this Secondary Claim Information (Y/N)","N") Q:BPQ=-1 -1 G:BPQ=0 END
;
; Prompt for Secondary Insurance Plan
W !
F D Q:BPSQ'=0
. S BPSPLAN=$$SELECTPL^BPSPRRX1(DFN,DOS,.BPSPLNSL,"SECONDARY INSURANCE POLICY",$G(BPSPRARR("PLAN")))
. I BPSPLAN=0 S BPSQ=-1 Q
. I $P(BPSPLNSL(7),U)'=2 W !,"Must select a Secondary insurance plan." Q
. S BPSPRARR("PLAN")=BPSPLAN
. S BPSPRARR("INS NAME")=$P(BPSPLNSL(1),U,2)
. S BPSPSHV=$$PAYSHTV(BPSPLAN)
. S BPSQ=1
Q:BPSQ=-1 -1
;
; Prompt for Rate Type and store in BPSPRARR("RTYPE")
F S BPRATTYP=$$RATETYPE^BPSPRRX2($S($G(BPSPRARR("RTYPE"))]"":BPSPRARR("RTYPE"),1:8)) Q:BPRATTYP'=""
I BPRATTYP=-1 Q -1
S BPSPRARR("RTYPE")=BPRATTYP
;
; Prompt for OTHER COVERAGE CODE
I $G(BPSPRARR("308-C8"))="" S BPSPRARR("308-C8")="04"
S BPSSET="" D SET308(.BPSSET)
S RETV=$$PROMPT("SRA"_U_BPSSET,"OTHER COVERAGE CODE: ",$G(BPSPRARR("308-C8")),"Indicate whether or not the patient has other insurance coverage")
Q:RETV<0 -1
S BPSPRARR("308-C8")=RETV
;
; Prompt for OTHER PAYER ID
S BPSDFLT=$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4)
S RETV=$$PROMPT("FR"_U_"0:10:","OTHER PAYER ID",$G(BPSDFLT),"ID assigned to the payer") Q:RETV<0 -1
Q:RETV=-1 -1
S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,4)=RETV
;
; Prompt for OTHER PAYER DATE
S BPSDFLT=$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5)
S RETV=$$PROMPT("DR"_U_"","OTHER PAYER DATE",$$FMTE^XLFDT($G(BPSDFLT)),"Payment or denial date of the claim submitted to the other payer. Used for coordination of benefits.")
Q:RETV=-1 -1
S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,5)=RETV
;
; Prompt for OTHER PAYER RECONCILIATION ID
S BPSDFLT=+$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,11)
S RETV=$$PROMPT("Fr"_U_"0:30:","OTHER PAYER RECONCILIATION ID",$G(BPSDFLT),"ID assigned to the Payer Reconciliation") Q:RETV<0 -1
Q:RETV=-1 -1
S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,11)=RETV
;
; Prompt for Paid Amount or Reject Codes
S BPSSET="PAID:PAID AMOUNTS;REJECT:REJECT CODES"
S BPSDFLT=""
I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) S BPSDFLT="PAID AMOUNTS"
I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) S BPSDFLT=$S(BPSDFLT="PAID AMOUNTS":"",1:"REJECT CODES")
S BPSPDRJ=$$PROMPT("SRA"_U_BPSSET,"Edit Paid Amounts or Reject Codes (PAID AMOUNTS/REJECT CODES): ",BPSDFLT,"Edit the Paid Amounts or Reject Codes")
Q:BPSPDRJ=-1 -1
;
; Prompt to edit paid amounts
D:BPSPDRJ="PAID"
. ; Remove reject codes.
. K BPSPRARR("OTHER PAYER",BPSPIEN,"R")
. S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=""
. ;
. K BPSPAID
. S (BPCNT,BPX,BPQ,TOTAL)=0
. ; BPS NCPDP FIELD DEFS for field 342 codes
. S BPSSET=$$GETCDLST(BPSPSHV)
. F BPX1=0:1 S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX)) Q:'BPX D Q:BPQ=1
. . S BPSQUAL=$P(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,2)
. . S BPSQUAL=$$GET1^DIQ(9002313.2,BPSQUAL,.01)
. . S BPSAMT=$P(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,1)
. . S BPQ=$$ASKPAID(BPSSET,BPSQUAL,BPSAMT,.BPCNT,.BPSPAID)
. ;
. I 'BPQ F S BPQ=$$ASKPAID(BPSSET,"","",.BPCNT,.BPSPAID) Q:BPQ=1
. ; Enter updated values into the BPSPRARR array
. K BPSPRARR("OTHER PAYER",BPSPIEN,"P")
. S BPX=0 F BPX1=0:1 S BPX=$O(BPSPAID(1,BPX)) Q:BPX="" D
. . S BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)=BPSPAID(1,BPX)
. . S TOTAL=TOTAL+BPSPAID(1,BPX)
. . ;
. ; Set the OTHER PAYER AMOUNT PAID COUNT
. S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=BPX1
. Q
;
; Edit/add reject codes
D:BPSPDRJ="REJECT"
. ; Remove paid amounts on the prior claim.
. K BPSPRARR("OTHER PAYER",BPSPIEN,"P")
. S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=""
. ;
. K BPSRJ
. S (BPCNT,BPX)=0
. F BPX1=0:1 S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX)) Q:'BPX D Q:BPCNT>4
. . S BPSDFLT=BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)
. . S RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE",$G(BPSDFLT),"Enter the reject code returned by the previous payer")
. . Q:RETV=-1
. . S BPCNT=BPCNT+1,BPSRJ(BPCNT)=$P(RETV,U,2)
. I BPCNT=5 W !,"Maximum of 5 OTHER PAYER REJECT CODES reached."
. I BPCNT<5 F S RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE","","Enter the reject code returned by the previous payer") Q:RETV=-1 D Q:BPCNT>4
. . S BPCNT=BPCNT+1
. . S BPSRJ(BPCNT)=$P(RETV,U,2)
. . I BPCNT>4 W !,"Maximum of 5 OTHER PAYER REJECT CODES reached."
. K BPSPRARR("OTHER PAYER",BPSPIEN,"R")
. S BPX=0 F BPX1=0:1 S BPX=$O(BPSRJ(BPX)) Q:BPX="" S BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)=BPSRJ(BPX)
. ; Set the OTHER PAYER REJECT COUNT
. S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=BPX1
. Q
;
I '$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")),'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) W !,"No Paid Amounts or Reject Codes entered" Q -1
;
; Default OTHER PAYER COVERAGE TYPE to PRIMARY
S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,2)="01"
;
; Default OTHER PAYER ID QUALIFIER to BIN
S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,3)="03"
;
; If the PRIOR PAYMENT is 0 but the user entered paid amounts, update the PRIOR PAYMENT
I +$G(BPSPRARR("PRIOR PAYMENT"))=0,$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) D
. S BPSPRARR("PRIOR PAYMENT")=TOTAL
. I TOTAL>0 S BPSPRARR("308-C8")="02"
. E S BPSPRARR("308-C8")="04"
;
END ;
Q 1
;
;
ASKPAID(BPSSET,BPSQUAL,BPSAMT,BPCNT,BPSPAID) ;
N RETV1,RETV2,BPSX,BPSPRA,BPSQ S BPSQ=0
I BPCNT>8 W !," Maximum of 9 OTHER PAYER AMOUNT PAID reached." Q 1
ASK1 S RETV1=$$PROMPT("SOA"_U_BPSSET,"OTHER PAYER AMOUNT PAID QUALIFIER: ",$G(BPSQUAL),"Type of payment from other sources (including coupons)")
I RETV1=-1!(RETV1="") Q 1
I RETV1="08",$D(BPSPAID(2)) W !," Qualifier '08' cannot be entered with other qualifiers" G ASK1
S RETV2=$$PROMPT("NO"_U_"0:999999.99:2","OTHER PAYER AMOUNT PAID",$G(BPSAMT),"Amount of any payment from other sources (including coupons)")
I RETV2=-1!(RETV2="") Q 1
; Check for duplicate qualifiers and add Amount Paid to previous amount entered
I $D(BPSPAID(2,RETV1)) D Q 0
. S BPSX="" F S BPSX=$O(BPSPAID(1,BPSX)) Q:BPSX="" D Q:BPSQ
. . I $P(BPSPAID(1,BPSX),U,2)=RETV1 D
. . . S BPSPRA=$P(BPSPAID(1,BPSX),U),$P(BPSPAID(1,BPSX),U)=BPSPRA+RETV2,BPSQ=1
. . . W !," $",$FN(RETV2,",",2)," has been added to amount $",$FN(BPSPRA,",",2)," for Qualifier ",RETV1
S BPCNT=BPCNT+1
S BPSPAID(1,BPCNT)=RETV2_U_$$GETPDIEN^BPSPRRX6(RETV1)
S BPSPAID(2,RETV1)=""
I RETV1="08" Q 1
Q 0
;
DISPSEC(BPSPRARR) ;
; Validate and Display the current secondary insurance information and prompt to edit.
; Input:
; BPSPRARR - Array of COB data, passed by reference
;
N BPSPIEN,BPSCOB,BPSCOV,BPX,BPSCOV,DATA
;
; Other Payer IEN defaults to 1 since we don't do tertiary
S BPSPIEN=1,BPSCOB="SECONDARY"
;
; Get Coverage Code
S BPSCOV=$G(BPSPRARR("308-C8"))
I BPSCOV="02" S BPSCOV="02 (OTHER COVERAGE EXISTS - PAYMENT COLLECTED)"
E I BPSCOV="03" S BPSCOV="03 (OTHER COVERAGE EXISTS - THIS CLAIM NOT COVERED)"
E S BPSCOV="04 (OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED)"
;
; Write Data
W !!,"Data for Secondary Claim"
W !,"------------------------"
W !,"Insurance: "_$G(BPSPRARR("INS NAME"))_" COB: "_BPSCOB
W !,"Rate Type: "_$$GET1^DIQ(399.3,$G(BPSPRARR("RTYPE"))_",",.01,,,,)
W !,"Other Coverage Code: "_BPSCOV
W !,"Other Payer Coverage Type: 01 (PRIMARY)"
W !,"Other Payer ID Qualifier: 03 (BANK INFORMATION NUMBER (BIN))"
W !,"Other Payer ID: "_$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4)
W !,"Other Payer Date: "_$$FMTE^XLFDT($P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5))
W !,"Other Payer Reconciliation ID: "_$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,11)
;
; Write Paid Amounts if previous claim if they are there
I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) D
. S BPX=0 F S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX)) Q:BPX="" D
. . S DATA=BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)
. . W !,"Other Payer Paid Qualifier: "_$$GET1^DIQ(9002313.2,$P(DATA,U,2),.01)_" ("_$$GET1^DIQ(9002313.2,$P(DATA,U,2),.02)_")"
. . W !,"Other Payer Amount Paid: $"_$FN($P(DATA,U,1),",",2)
. . I $P(DATA,U,3)'="" D
. . . W !,"Other Payer Patient Resp Amount Qualifier: 06 (AMT REPORTED BY PRIOR PAYER)"
. . . W !,"Other Payer Patient Resp Amount: $"_$FN($P(DATA,U,3),",",2)
;
; Write Reject Codes if previous claims if they are there
I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) D
. S BPX=0 F S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX)) Q:BPX="" D
. . W !,"Other Payer Reject Code: "_$$TRANREJ^BPSECFM($G(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)))
Q
;
PROMPT(ZERONODE,PRMTMSG,DFLTVAL,BPSHLP) ;
;prompts for selection
;returns selection
;OR -1 when timeout and uparrow
;
N Y,DUOUT,DTOUT,BPQUIT,DIROUT
N DIR
S DIR(0)=ZERONODE
S DIR("A")=PRMTMSG
I BPSHLP]"" S DIR("?")=BPSHLP
S:$L($G(DFLTVAL))>0 DIR("B")=DFLTVAL
D ^DIR
I (Y=-1)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) Q -1
Q Y
;
GETCDLST(VERSION) ; Returns a list of codes by field/version for use in PROMPTS
N CSUB,VSUB,ARRAY,X,BPSSET,BPSCD,BPSV,BPSOK
S VERSION=$G(VERSION)
S VERSION=$S(VERSION=5.1:51,VERSION=51:51,VERSION="D.0":"D0",VERSION="D0":"D0",1:"D0")
S BPSSET=""
S BPSCD=0 F S BPSCD=$O(^BPS(9002313.2,BPSCD)) Q:BPSCD="" D
. S (BPSOK,BPSV)=0 F S BPSV=$O(^BPS(9002313.2,BPSCD,1,BPSV)) Q:BPSV="" D Q:BPSOK
. . I $P($G(^BPS(9002313.2,BPSCD,1,BPSV,0)),U)=VERSION S BPSOK=1
. I BPSOK S ARRAY(BPSCD)=$P(^BPS(9002313.2,BPSCD,0),U,1)_U_$P(^BPS(9002313.2,BPSCD,0),U,2)
S X=0 F S X=$O(ARRAY(X)) Q:X="" D
. S BPSSET=BPSSET_$P(ARRAY(X),U)_":"_$P(ARRAY(X),U,2)_";"
Q BPSSET
;
PAYSHTV(BPSPLAN) ;Get the Billing Payer Sheet version for this plan
; BPSPLAN = IEN to GROUP INSURANCE PLAN file #355.3
N BPSPSH,BPSBPSH
; Get Payer Sheets
S BPSPSH=$$PLANEPS^IBNCPDPU(BPSPLAN)
; Get Billing Payer Sheet
I +BPSPSH S BPSBPSH=$P($P(BPSPSH,"^",2),",")
I $G(BPSBPSH)']"" Q ""
Q $P(^BPSF(9002313.92,BPSBPSH,1),U,2)
;
;because the set of codes is too long to fit the MUMPS code line - use a special code to populte set of codes
SET308(BPSSET) ;
N BPX,BPZ
F BPX=2:1 S BPZ=$P($T(SET308C8+BPX),";;",2) Q:BPZ="" D
. S BPSSET=BPSSET_$P(BPZ,U)_";"
Q
;
SET308C8 ;set of codes for 308-C8
; set of codes
;;00:NOT SPECIFIED BY PATIENT
;;01:NO OTHER COVERAGE IDENTIFIED
;;02:OTHER COVERAGE EXISTS - PAYMENT COLLECTED
;;03:OTHER COVERAGE BILLED - CLAIM NOT COVERED
;;04:OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED
;;08:CLAIM IS BILLING FOR PATIENT FINANCIAL RESPONSIBILITY ONLY
;;
;
;BPSPRRX3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSPRRX3 13051 printed Oct 16, 2024@17:53:11 Page 2
BPSPRRX3 ;ALB/SS - ePharmacy secondary billing ;16-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 ;External reference to file 399.3 supported by IA 3822
+5 ;External reference to $$INSUR^IBBAPI supported by IA 4419
+6 ;External reference to $$PLANEPS^IBNCPDPU supported by IA 5572
+7 ;
PROMPTS(RX,FILL,DOS,BPSPRARR) ;
+1 ;BPSPRARR - array to pass values determined earlier (if any) and to return user's input/corrections
+2 ;Input:
+3 ; RX - Prescription IEN
+4 ; FILL - Fill Number
+5 ; DOS - Date of Service
+6 ; BPSPRARR - Array of data passed by reference
+7 ;Returns
+8 ; 1 = the data is correct
+9 ; -1 = the data is not correct - Do not create the claim
+10 ;
+11 ; Check paramters
+12 IF '$GET(RX)
QUIT -1
+13 IF $GET(FILL)=""
QUIT -1
+14 IF '$GET(DOS)
QUIT -1
+15 ;
+16 ;
+17 NEW BPQ,BPSQ,IEN59PR,DFN,BPSPLAN,BPX,BPSDFLT,BPSSET
+18 NEW BPSPIEN,BPSSET,BPCNT,BPSRJ,BPSPAID,RETV,TOTAL
+19 NEW BPRATTYP,BPSPDRJ,BPSPLNSL,BPX1,BPSFIEN,BPSPSARR,BPSPSHV
+20 NEW IEN59SEC,BPSRET,BPSINS
+21 ;
+22 SET (BPQ,BPSQ)=0
+23 ;
+24 ; Other Payer IEN defaults to 1 since we don't do tertiary
+25 SET BPSPIEN=1
+26 ;
+27 ; Get Primary BPS Transaction
+28 SET IEN59PR=$$IEN59^BPSOSRX(RX,FILL,1)
+29 ;
+30 ; Get/validate Patient DFN
+31 SET DFN=$PIECE($GET(^BPST(IEN59PR,0)),U,6)
+32 IF DFN=""
SET DFN=$$RXAPI1^BPSUTIL1(RX,2,"I")
+33 IF DFN=""
QUIT -1
+34 ;
+35 ; Get patient insurances
+36 SET BPSRET=$$INSUR^IBBAPI(DFN,DOS,"E",.BPSINS,"1,7,8")
+37 ;
+38 ; Get the first Secondary insurance for default
+39 SET BPSPRARR("PLAN")=""
SET BPSPRARR("INS NAME")=""
SET (BPX,BPQ)=0
+40 FOR
SET BPX=$ORDER(BPSINS("IBBAPI","INSUR",BPX))
if 'BPX
QUIT
Begin DoDot:1
+41 IF $PIECE(BPSINS("IBBAPI","INSUR",BPX,7),U)'=2
QUIT
+42 SET BPSPRARR("PLAN")=$PIECE(BPSINS("IBBAPI","INSUR",BPX,8),U)
+43 SET BPSPRARR("INS NAME")=$PIECE(BPSINS("IBBAPI","INSUR",BPX,1),U,2)
+44 SET BPQ=1
+45 QUIT
End DoDot:1
if BPQ
QUIT
+46 ;
+47 ; Get Rate Type for the Secondary Insurance
+48 SET IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2)
+49 SET BPSPRARR("RTYPE")=$$GETRTP59^BPSPRRX5(IEN59SEC)
+50 IF BPSPRARR("RTYPE")=""
SET BPSPRARR("RTYPE")=8
+51 ;
+52 ; Display current COB fields
+53 DO DISPSEC(.BPSPRARR)
+54 ;
+55 SET BPQ=0
+56 IF $GET(BPSPRARR("PLAN"))=""!($GET(BPSPRARR("RTYPE"))="")!($GET(BPSPRARR("308-C8"))="")
SET BPQ=1
+57 IF BPSQ=0
FOR BPX=4,5
IF $PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,BPX)=""
SET BPQ=1
+58 IF BPQ=0
IF '$DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"P"))
IF '$DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"R"))
SET BPQ=1
+59 ;
+60 ; Prompt to continue or not
+61 WRITE !
+62 IF BPQ=1
WRITE !,"Required secondary claim information is missing. Enter all required information",!
+63 IF '$TEST
SET BPQ=$$YESNO^BPSSCRRS("Do you want to edit this Secondary Claim Information (Y/N)","N")
if BPQ=-1
QUIT -1
if BPQ=0
GOTO END
+64 ;
+65 ; Prompt for Secondary Insurance Plan
+66 WRITE !
+67 FOR
Begin DoDot:1
+68 SET BPSPLAN=$$SELECTPL^BPSPRRX1(DFN,DOS,.BPSPLNSL,"SECONDARY INSURANCE POLICY",$GET(BPSPRARR("PLAN")))
+69 IF BPSPLAN=0
SET BPSQ=-1
QUIT
+70 IF $PIECE(BPSPLNSL(7),U)'=2
WRITE !,"Must select a Secondary insurance plan."
QUIT
+71 SET BPSPRARR("PLAN")=BPSPLAN
+72 SET BPSPRARR("INS NAME")=$PIECE(BPSPLNSL(1),U,2)
+73 SET BPSPSHV=$$PAYSHTV(BPSPLAN)
+74 SET BPSQ=1
End DoDot:1
if BPSQ'=0
QUIT
+75 if BPSQ=-1
QUIT -1
+76 ;
+77 ; Prompt for Rate Type and store in BPSPRARR("RTYPE")
+78 FOR
SET BPRATTYP=$$RATETYPE^BPSPRRX2($SELECT($GET(BPSPRARR("RTYPE"))]"":BPSPRARR("RTYPE"),1:8))
if BPRATTYP'=""
QUIT
+79 IF BPRATTYP=-1
QUIT -1
+80 SET BPSPRARR("RTYPE")=BPRATTYP
+81 ;
+82 ; Prompt for OTHER COVERAGE CODE
+83 IF $GET(BPSPRARR("308-C8"))=""
SET BPSPRARR("308-C8")="04"
+84 SET BPSSET=""
DO SET308(.BPSSET)
+85 SET RETV=$$PROMPT("SRA"_U_BPSSET,"OTHER COVERAGE CODE: ",$GET(BPSPRARR("308-C8")),"Indicate whether or not the patient has other insurance coverage")
+86 if RETV<0
QUIT -1
+87 SET BPSPRARR("308-C8")=RETV
+88 ;
+89 ; Prompt for OTHER PAYER ID
+90 SET BPSDFLT=$PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4)
+91 SET RETV=$$PROMPT("FR"_U_"0:10:","OTHER PAYER ID",$GET(BPSDFLT),"ID assigned to the payer")
if RETV<0
QUIT -1
+92 if RETV=-1
QUIT -1
+93 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,4)=RETV
+94 ;
+95 ; Prompt for OTHER PAYER DATE
+96 SET BPSDFLT=$PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5)
+97 SET RETV=$$PROMPT("DR"_U_"","OTHER PAYER DATE",$$FMTE^XLFDT($GET(BPSDFLT)),"Payment or denial date of the claim submitted to the other payer. Used for coordination of benefits.")
+98 if RETV=-1
QUIT -1
+99 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,5)=RETV
+100 ;
+101 ; Prompt for OTHER PAYER RECONCILIATION ID
+102 SET BPSDFLT=+$PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,11)
+103 SET RETV=$$PROMPT("Fr"_U_"0:30:","OTHER PAYER RECONCILIATION ID",$GET(BPSDFLT),"ID assigned to the Payer Reconciliation")
if RETV<0
QUIT -1
+104 if RETV=-1
QUIT -1
+105 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,11)=RETV
+106 ;
+107 ; Prompt for Paid Amount or Reject Codes
+108 SET BPSSET="PAID:PAID AMOUNTS;REJECT:REJECT CODES"
+109 SET BPSDFLT=""
+110 IF $DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"P"))
SET BPSDFLT="PAID AMOUNTS"
+111 IF $DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"R"))
SET BPSDFLT=$SELECT(BPSDFLT="PAID AMOUNTS":"",1:"REJECT CODES")
+112 SET BPSPDRJ=$$PROMPT("SRA"_U_BPSSET,"Edit Paid Amounts or Reject Codes (PAID AMOUNTS/REJECT CODES): ",BPSDFLT,"Edit the Paid Amounts or Reject Codes")
+113 if BPSPDRJ=-1
QUIT -1
+114 ;
+115 ; Prompt to edit paid amounts
+116 if BPSPDRJ="PAID"
Begin DoDot:1
+117 ; Remove reject codes.
+118 KILL BPSPRARR("OTHER PAYER",BPSPIEN,"R")
+119 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=""
+120 ;
+121 KILL BPSPAID
+122 SET (BPCNT,BPX,BPQ,TOTAL)=0
+123 ; BPS NCPDP FIELD DEFS for field 342 codes
+124 SET BPSSET=$$GETCDLST(BPSPSHV)
+125 FOR BPX1=0:1
SET BPX=$ORDER(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX))
if 'BPX
QUIT
Begin DoDot:2
+126 SET BPSQUAL=$PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,2)
+127 SET BPSQUAL=$$GET1^DIQ(9002313.2,BPSQUAL,.01)
+128 SET BPSAMT=$PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,1)
+129 SET BPQ=$$ASKPAID(BPSSET,BPSQUAL,BPSAMT,.BPCNT,.BPSPAID)
End DoDot:2
if BPQ=1
QUIT
+130 ;
+131 IF 'BPQ
FOR
SET BPQ=$$ASKPAID(BPSSET,"","",.BPCNT,.BPSPAID)
if BPQ=1
QUIT
+132 ; Enter updated values into the BPSPRARR array
+133 KILL BPSPRARR("OTHER PAYER",BPSPIEN,"P")
+134 SET BPX=0
FOR BPX1=0:1
SET BPX=$ORDER(BPSPAID(1,BPX))
if BPX=""
QUIT
Begin DoDot:2
+135 SET BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)=BPSPAID(1,BPX)
+136 SET TOTAL=TOTAL+BPSPAID(1,BPX)
+137 ;
End DoDot:2
+138 ; Set the OTHER PAYER AMOUNT PAID COUNT
+139 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=BPX1
+140 QUIT
End DoDot:1
+141 ;
+142 ; Edit/add reject codes
+143 if BPSPDRJ="REJECT"
Begin DoDot:1
+144 ; Remove paid amounts on the prior claim.
+145 KILL BPSPRARR("OTHER PAYER",BPSPIEN,"P")
+146 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=""
+147 ;
+148 KILL BPSRJ
+149 SET (BPCNT,BPX)=0
+150 FOR BPX1=0:1
SET BPX=$ORDER(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX))
if 'BPX
QUIT
Begin DoDot:2
+151 SET BPSDFLT=BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)
+152 SET RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE",$GET(BPSDFLT),"Enter the reject code returned by the previous payer")
+153 if RETV=-1
QUIT
+154 SET BPCNT=BPCNT+1
SET BPSRJ(BPCNT)=$PIECE(RETV,U,2)
End DoDot:2
if BPCNT>4
QUIT
+155 IF BPCNT=5
WRITE !,"Maximum of 5 OTHER PAYER REJECT CODES reached."
+156 IF BPCNT<5
FOR
SET RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE","","Enter the reject code returned by the previous payer")
if RETV=-1
QUIT
Begin DoDot:2
+157 SET BPCNT=BPCNT+1
+158 SET BPSRJ(BPCNT)=$PIECE(RETV,U,2)
+159 IF BPCNT>4
WRITE !,"Maximum of 5 OTHER PAYER REJECT CODES reached."
End DoDot:2
if BPCNT>4
QUIT
+160 KILL BPSPRARR("OTHER PAYER",BPSPIEN,"R")
+161 SET BPX=0
FOR BPX1=0:1
SET BPX=$ORDER(BPSRJ(BPX))
if BPX=""
QUIT
SET BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)=BPSRJ(BPX)
+162 ; Set the OTHER PAYER REJECT COUNT
+163 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=BPX1
+164 QUIT
End DoDot:1
+165 ;
+166 IF '$DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"P"))
IF '$DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"R"))
WRITE !,"No Paid Amounts or Reject Codes entered"
QUIT -1
+167 ;
+168 ; Default OTHER PAYER COVERAGE TYPE to PRIMARY
+169 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,2)="01"
+170 ;
+171 ; Default OTHER PAYER ID QUALIFIER to BIN
+172 SET $PIECE(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,3)="03"
+173 ;
+174 ; If the PRIOR PAYMENT is 0 but the user entered paid amounts, update the PRIOR PAYMENT
+175 IF +$GET(BPSPRARR("PRIOR PAYMENT"))=0
IF $DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"P"))
Begin DoDot:1
+176 SET BPSPRARR("PRIOR PAYMENT")=TOTAL
+177 IF TOTAL>0
SET BPSPRARR("308-C8")="02"
+178 IF '$TEST
SET BPSPRARR("308-C8")="04"
End DoDot:1
+179 ;
END ;
+1 QUIT 1
+2 ;
+3 ;
ASKPAID(BPSSET,BPSQUAL,BPSAMT,BPCNT,BPSPAID) ;
+1 NEW RETV1,RETV2,BPSX,BPSPRA,BPSQ
SET BPSQ=0
+2 IF BPCNT>8
WRITE !," Maximum of 9 OTHER PAYER AMOUNT PAID reached."
QUIT 1
ASK1 SET RETV1=$$PROMPT("SOA"_U_BPSSET,"OTHER PAYER AMOUNT PAID QUALIFIER: ",$GET(BPSQUAL),"Type of payment from other sources (including coupons)")
+1 IF RETV1=-1!(RETV1="")
QUIT 1
+2 IF RETV1="08"
IF $DATA(BPSPAID(2))
WRITE !," Qualifier '08' cannot be entered with other qualifiers"
GOTO ASK1
+3 SET RETV2=$$PROMPT("NO"_U_"0:999999.99:2","OTHER PAYER AMOUNT PAID",$GET(BPSAMT),"Amount of any payment from other sources (including coupons)")
+4 IF RETV2=-1!(RETV2="")
QUIT 1
+5 ; Check for duplicate qualifiers and add Amount Paid to previous amount entered
+6 IF $DATA(BPSPAID(2,RETV1))
Begin DoDot:1
+7 SET BPSX=""
FOR
SET BPSX=$ORDER(BPSPAID(1,BPSX))
if BPSX=""
QUIT
Begin DoDot:2
+8 IF $PIECE(BPSPAID(1,BPSX),U,2)=RETV1
Begin DoDot:3
+9 SET BPSPRA=$PIECE(BPSPAID(1,BPSX),U)
SET $PIECE(BPSPAID(1,BPSX),U)=BPSPRA+RETV2
SET BPSQ=1
+10 WRITE !," $",$FNUMBER(RETV2,",",2)," has been added to amount $",$FNUMBER(BPSPRA,",",2)," for Qualifier ",RETV1
End DoDot:3
End DoDot:2
if BPSQ
QUIT
End DoDot:1
QUIT 0
+11 SET BPCNT=BPCNT+1
+12 SET BPSPAID(1,BPCNT)=RETV2_U_$$GETPDIEN^BPSPRRX6(RETV1)
+13 SET BPSPAID(2,RETV1)=""
+14 IF RETV1="08"
QUIT 1
+15 QUIT 0
+16 ;
DISPSEC(BPSPRARR) ;
+1 ; Validate and Display the current secondary insurance information and prompt to edit.
+2 ; Input:
+3 ; BPSPRARR - Array of COB data, passed by reference
+4 ;
+5 NEW BPSPIEN,BPSCOB,BPSCOV,BPX,BPSCOV,DATA
+6 ;
+7 ; Other Payer IEN defaults to 1 since we don't do tertiary
+8 SET BPSPIEN=1
SET BPSCOB="SECONDARY"
+9 ;
+10 ; Get Coverage Code
+11 SET BPSCOV=$GET(BPSPRARR("308-C8"))
+12 IF BPSCOV="02"
SET BPSCOV="02 (OTHER COVERAGE EXISTS - PAYMENT COLLECTED)"
+13 IF '$TEST
IF BPSCOV="03"
SET BPSCOV="03 (OTHER COVERAGE EXISTS - THIS CLAIM NOT COVERED)"
+14 IF '$TEST
SET BPSCOV="04 (OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED)"
+15 ;
+16 ; Write Data
+17 WRITE !!,"Data for Secondary Claim"
+18 WRITE !,"------------------------"
+19 WRITE !,"Insurance: "_$GET(BPSPRARR("INS NAME"))_" COB: "_BPSCOB
+20 WRITE !,"Rate Type: "_$$GET1^DIQ(399.3,$GET(BPSPRARR("RTYPE"))_",",.01,,,,)
+21 WRITE !,"Other Coverage Code: "_BPSCOV
+22 WRITE !,"Other Payer Coverage Type: 01 (PRIMARY)"
+23 WRITE !,"Other Payer ID Qualifier: 03 (BANK INFORMATION NUMBER (BIN))"
+24 WRITE !,"Other Payer ID: "_$PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4)
+25 WRITE !,"Other Payer Date: "_$$FMTE^XLFDT($PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5))
+26 WRITE !,"Other Payer Reconciliation ID: "_$PIECE($GET(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,11)
+27 ;
+28 ; Write Paid Amounts if previous claim if they are there
+29 IF $DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"P"))
Begin DoDot:1
+30 SET BPX=0
FOR
SET BPX=$ORDER(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX))
if BPX=""
QUIT
Begin DoDot:2
+31 SET DATA=BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)
+32 WRITE !,"Other Payer Paid Qualifier: "_$$GET1^DIQ(9002313.2,$PIECE(DATA,U,2),.01)_" ("_$$GET1^DIQ(9002313.2,$PIECE(DATA,U,2),.02)_")"
+33 WRITE !,"Other Payer Amount Paid: $"_$FNUMBER($PIECE(DATA,U,1),",",2)
+34 IF $PIECE(DATA,U,3)'=""
Begin DoDot:3
+35 WRITE !,"Other Payer Patient Resp Amount Qualifier: 06 (AMT REPORTED BY PRIOR PAYER)"
+36 WRITE !,"Other Payer Patient Resp Amount: $"_$FNUMBER($PIECE(DATA,U,3),",",2)
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 ; Write Reject Codes if previous claims if they are there
+39 IF $DATA(BPSPRARR("OTHER PAYER",BPSPIEN,"R"))
Begin DoDot:1
+40 SET BPX=0
FOR
SET BPX=$ORDER(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX))
if BPX=""
QUIT
Begin DoDot:2
+41 WRITE !,"Other Payer Reject Code: "_$$TRANREJ^BPSECFM($GET(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)))
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
PROMPT(ZERONODE,PRMTMSG,DFLTVAL,BPSHLP) ;
+1 ;prompts for selection
+2 ;returns selection
+3 ;OR -1 when timeout and uparrow
+4 ;
+5 NEW Y,DUOUT,DTOUT,BPQUIT,DIROUT
+6 NEW DIR
+7 SET DIR(0)=ZERONODE
+8 SET DIR("A")=PRMTMSG
+9 IF BPSHLP]""
SET DIR("?")=BPSHLP
+10 if $LENGTH($GET(DFLTVAL))>0
SET DIR("B")=DFLTVAL
+11 DO ^DIR
+12 IF (Y=-1)!$DATA(DIROUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT -1
+13 QUIT Y
+14 ;
GETCDLST(VERSION) ; Returns a list of codes by field/version for use in PROMPTS
+1 NEW CSUB,VSUB,ARRAY,X,BPSSET,BPSCD,BPSV,BPSOK
+2 SET VERSION=$GET(VERSION)
+3 SET VERSION=$SELECT(VERSION=5.1:51,VERSION=51:51,VERSION="D.0":"D0",VERSION="D0":"D0",1:"D0")
+4 SET BPSSET=""
+5 SET BPSCD=0
FOR
SET BPSCD=$ORDER(^BPS(9002313.2,BPSCD))
if BPSCD=""
QUIT
Begin DoDot:1
+6 SET (BPSOK,BPSV)=0
FOR
SET BPSV=$ORDER(^BPS(9002313.2,BPSCD,1,BPSV))
if BPSV=""
QUIT
Begin DoDot:2
+7 IF $PIECE($GET(^BPS(9002313.2,BPSCD,1,BPSV,0)),U)=VERSION
SET BPSOK=1
End DoDot:2
if BPSOK
QUIT
+8 IF BPSOK
SET ARRAY(BPSCD)=$PIECE(^BPS(9002313.2,BPSCD,0),U,1)_U_$PIECE(^BPS(9002313.2,BPSCD,0),U,2)
End DoDot:1
+9 SET X=0
FOR
SET X=$ORDER(ARRAY(X))
if X=""
QUIT
Begin DoDot:1
+10 SET BPSSET=BPSSET_$PIECE(ARRAY(X),U)_":"_$PIECE(ARRAY(X),U,2)_";"
End DoDot:1
+11 QUIT BPSSET
+12 ;
PAYSHTV(BPSPLAN) ;Get the Billing Payer Sheet version for this plan
+1 ; BPSPLAN = IEN to GROUP INSURANCE PLAN file #355.3
+2 NEW BPSPSH,BPSBPSH
+3 ; Get Payer Sheets
+4 SET BPSPSH=$$PLANEPS^IBNCPDPU(BPSPLAN)
+5 ; Get Billing Payer Sheet
+6 IF +BPSPSH
SET BPSBPSH=$PIECE($PIECE(BPSPSH,"^",2),",")
+7 IF $GET(BPSBPSH)']""
QUIT ""
+8 QUIT $PIECE(^BPSF(9002313.92,BPSBPSH,1),U,2)
+9 ;
+10 ;because the set of codes is too long to fit the MUMPS code line - use a special code to populte set of codes
SET308(BPSSET) ;
+1 NEW BPX,BPZ
+2 FOR BPX=2:1
SET BPZ=$PIECE($TEXT(SET308C8+BPX),";;",2)
if BPZ=""
QUIT
Begin DoDot:1
+3 SET BPSSET=BPSSET_$PIECE(BPZ,U)_";"
End DoDot:1
+4 QUIT
+5 ;
SET308C8 ;set of codes for 308-C8
+1 ; set of codes
+2 ;;00:NOT SPECIFIED BY PATIENT
+3 ;;01:NO OTHER COVERAGE IDENTIFIED
+4 ;;02:OTHER COVERAGE EXISTS - PAYMENT COLLECTED
+5 ;;03:OTHER COVERAGE BILLED - CLAIM NOT COVERED
+6 ;;04:OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED
+7 ;;08:CLAIM IS BILLING FOR PATIENT FINANCIAL RESPONSIBILITY ONLY
+8 ;;
+9 ;
+10 ;BPSPRRX3
