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

BPSPRRX3.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;External reference to file 399.3 supported by IA 3822
  1.  ;External reference to $$INSUR^IBBAPI supported by IA 4419
  1.  ;External reference to $$PLANEPS^IBNCPDPU supported by IA 5572
  1.  ;
  1. PROMPTS(RX,FILL,DOS,BPSPRARR) ;
  1.  ;BPSPRARR - array to pass values determined earlier (if any) and to return user's input/corrections
  1.  ;Input:
  1.  ;  RX - Prescription IEN
  1.  ;  FILL - Fill Number
  1.  ;  DOS - Date of Service
  1.  ;  BPSPRARR - Array of data passed by reference
  1.  ;Returns 
  1.  ;   1 = the data is correct
  1.  ;  -1 = the data is not correct - Do not create the claim
  1.  ;
  1.  ; Check paramters
  1.  I '$G(RX) Q -1
  1.  I $G(FILL)="" Q -1
  1.  I '$G(DOS) Q -1
  1.  ;
  1.  ;
  1.  N BPQ,BPSQ,IEN59PR,DFN,BPSPLAN,BPX,BPSDFLT,BPSSET
  1.  N BPSPIEN,BPSSET,BPCNT,BPSRJ,BPSPAID,RETV,TOTAL
  1.  N BPRATTYP,BPSPDRJ,BPSPLNSL,BPX1,BPSFIEN,BPSPSARR,BPSPSHV
  1.  N IEN59SEC,BPSRET,BPSINS
  1.  ;
  1.  S (BPQ,BPSQ)=0
  1.  ;
  1.  ; Other Payer IEN defaults to 1 since we don't do tertiary
  1.  S BPSPIEN=1
  1.  ;
  1.  ; Get Primary BPS Transaction
  1.  S IEN59PR=$$IEN59^BPSOSRX(RX,FILL,1)
  1.  ;
  1.  ; Get/validate Patient DFN
  1.  S DFN=$P($G(^BPST(IEN59PR,0)),U,6)
  1.  I DFN="" S DFN=$$RXAPI1^BPSUTIL1(RX,2,"I")
  1.  I DFN="" Q -1
  1.  ;
  1.  ; Get patient insurances
  1.  S BPSRET=$$INSUR^IBBAPI(DFN,DOS,"E",.BPSINS,"1,7,8")
  1.  ;
  1.  ; Get the first Secondary insurance for default
  1.  S BPSPRARR("PLAN")="",BPSPRARR("INS NAME")="",(BPX,BPQ)=0
  1.  F  S BPX=$O(BPSINS("IBBAPI","INSUR",BPX)) Q:'BPX  D  Q:BPQ
  1.  . I $P(BPSINS("IBBAPI","INSUR",BPX,7),U)'=2 Q
  1.  . S BPSPRARR("PLAN")=$P(BPSINS("IBBAPI","INSUR",BPX,8),U)
  1.  . S BPSPRARR("INS NAME")=$P(BPSINS("IBBAPI","INSUR",BPX,1),U,2)
  1.  . S BPQ=1
  1.  . Q
  1.  ;
  1.  ; Get Rate Type for the Secondary Insurance
  1.  S IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2)
  1.  S BPSPRARR("RTYPE")=$$GETRTP59^BPSPRRX5(IEN59SEC)
  1.  I BPSPRARR("RTYPE")="" S BPSPRARR("RTYPE")=8
  1.  ;
  1.  ; Display current COB fields
  1.  D DISPSEC(.BPSPRARR)
  1.  ;
  1.  S BPQ=0
  1.  I $G(BPSPRARR("PLAN"))=""!($G(BPSPRARR("RTYPE"))="")!($G(BPSPRARR("308-C8"))="") S BPQ=1
  1.  I BPSQ=0 F BPX=4,5 I $P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,BPX)="" S BPQ=1
  1.  I BPQ=0,'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")),'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) S BPQ=1
  1.  ;
  1.  ; Prompt to continue or not
  1.  W !
  1.  I BPQ=1 W !,"Required secondary claim information is missing. Enter all required information",!
  1.  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
  1.  ;
  1.  ; Prompt for Secondary Insurance Plan
  1.  W !
  1.  F  D  Q:BPSQ'=0
  1.  . S BPSPLAN=$$SELECTPL^BPSPRRX1(DFN,DOS,.BPSPLNSL,"SECONDARY INSURANCE POLICY",$G(BPSPRARR("PLAN")))
  1.  . I BPSPLAN=0 S BPSQ=-1 Q
  1.  . I $P(BPSPLNSL(7),U)'=2 W !,"Must select a Secondary insurance plan." Q
  1.  . S BPSPRARR("PLAN")=BPSPLAN
  1.  . S BPSPRARR("INS NAME")=$P(BPSPLNSL(1),U,2)
  1.  . S BPSPSHV=$$PAYSHTV(BPSPLAN)
  1.  . S BPSQ=1
  1.  Q:BPSQ=-1 -1
  1.  ;
  1.  ; Prompt for Rate Type and store in BPSPRARR("RTYPE")
  1.  F  S BPRATTYP=$$RATETYPE^BPSPRRX2($S($G(BPSPRARR("RTYPE"))]"":BPSPRARR("RTYPE"),1:8)) Q:BPRATTYP'=""
  1.  I BPRATTYP=-1 Q -1
  1.  S BPSPRARR("RTYPE")=BPRATTYP
  1.  ;
  1.  ; Prompt for OTHER COVERAGE CODE
  1.  I $G(BPSPRARR("308-C8"))="" S BPSPRARR("308-C8")="04"
  1.  S BPSSET="" D SET308(.BPSSET)
  1.  S RETV=$$PROMPT("SRA"_U_BPSSET,"OTHER COVERAGE CODE:  ",$G(BPSPRARR("308-C8")),"Indicate whether or not the patient has other insurance coverage")
  1.  Q:RETV<0 -1
  1.  S BPSPRARR("308-C8")=RETV
  1.  ;
  1.  ; Prompt for OTHER PAYER ID
  1.  S BPSDFLT=$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4)
  1.  S RETV=$$PROMPT("FR"_U_"0:10:","OTHER PAYER ID",$G(BPSDFLT),"ID assigned to the payer") Q:RETV<0 -1
  1.  Q:RETV=-1 -1
  1.  S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,4)=RETV
  1.  ;
  1.  ; Prompt for OTHER PAYER DATE
  1.  S BPSDFLT=$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5)
  1.  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.")
  1.  Q:RETV=-1 -1
  1.  S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,5)=RETV
  1.  ;
  1.  ; Prompt for OTHER PAYER RECONCILIATION ID
  1.  S BPSDFLT=+$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,11)
  1.  S RETV=$$PROMPT("Fr"_U_"0:30:","OTHER PAYER RECONCILIATION ID",$G(BPSDFLT),"ID assigned to the Payer Reconciliation") Q:RETV<0 -1
  1.  Q:RETV=-1 -1
  1.  S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,11)=RETV
  1.  ;
  1.  ; Prompt for Paid Amount or Reject Codes
  1.  S BPSSET="PAID:PAID AMOUNTS;REJECT:REJECT CODES"
  1.  S BPSDFLT=""
  1.  I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) S BPSDFLT="PAID AMOUNTS"
  1.  I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) S BPSDFLT=$S(BPSDFLT="PAID AMOUNTS":"",1:"REJECT CODES")
  1.  S BPSPDRJ=$$PROMPT("SRA"_U_BPSSET,"Edit Paid Amounts or Reject Codes (PAID AMOUNTS/REJECT CODES):  ",BPSDFLT,"Edit the Paid Amounts or Reject Codes")
  1.  Q:BPSPDRJ=-1 -1
  1.  ;
  1.  ; Prompt to edit paid amounts
  1.  D:BPSPDRJ="PAID"
  1.  . ; Remove reject codes.
  1.  . K BPSPRARR("OTHER PAYER",BPSPIEN,"R")
  1.  . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=""
  1.  . ;
  1.  . K BPSPAID
  1.  . S (BPCNT,BPX,BPQ,TOTAL)=0
  1.  . ; BPS NCPDP FIELD DEFS for field 342 codes
  1.  . S BPSSET=$$GETCDLST(BPSPSHV)
  1.  . F BPX1=0:1 S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX)) Q:'BPX  D  Q:BPQ=1
  1.  . . S BPSQUAL=$P(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,2)
  1.  . . S BPSQUAL=$$GET1^DIQ(9002313.2,BPSQUAL,.01)
  1.  . . S BPSAMT=$P(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,1)
  1.  . . S BPQ=$$ASKPAID(BPSSET,BPSQUAL,BPSAMT,.BPCNT,.BPSPAID)
  1.  . ;
  1.  . I 'BPQ F  S BPQ=$$ASKPAID(BPSSET,"","",.BPCNT,.BPSPAID) Q:BPQ=1
  1.  . ; Enter updated values into the BPSPRARR array
  1.  . K BPSPRARR("OTHER PAYER",BPSPIEN,"P")
  1.  . S BPX=0 F BPX1=0:1 S BPX=$O(BPSPAID(1,BPX)) Q:BPX=""  D
  1.  . . S BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)=BPSPAID(1,BPX)
  1.  . . S TOTAL=TOTAL+BPSPAID(1,BPX)
  1.  . . ;
  1.  . ; Set the OTHER PAYER AMOUNT PAID COUNT
  1.  . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=BPX1
  1.  . Q
  1.  ;
  1.  ; Edit/add reject codes
  1.  D:BPSPDRJ="REJECT"
  1.  . ; Remove paid amounts on the prior claim.
  1.  . K BPSPRARR("OTHER PAYER",BPSPIEN,"P")
  1.  . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=""
  1.  . ;
  1.  . K BPSRJ
  1.  . S (BPCNT,BPX)=0
  1.  . F BPX1=0:1 S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX)) Q:'BPX  D  Q:BPCNT>4
  1.  . . S BPSDFLT=BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)
  1.  . . S RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE",$G(BPSDFLT),"Enter the reject code returned by the previous payer")
  1.  . . Q:RETV=-1
  1.  . . S BPCNT=BPCNT+1,BPSRJ(BPCNT)=$P(RETV,U,2)
  1.  . I BPCNT=5 W !,"Maximum of 5 OTHER PAYER REJECT CODES reached."
  1.  . 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
  1.  . . S BPCNT=BPCNT+1
  1.  . . S BPSRJ(BPCNT)=$P(RETV,U,2)
  1.  . . I BPCNT>4 W !,"Maximum of 5 OTHER PAYER REJECT CODES reached."
  1.  . K BPSPRARR("OTHER PAYER",BPSPIEN,"R")
  1.  . S BPX=0 F BPX1=0:1 S BPX=$O(BPSRJ(BPX)) Q:BPX=""  S BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)=BPSRJ(BPX)
  1.  . ; Set the OTHER PAYER REJECT COUNT
  1.  . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=BPX1
  1.  . Q
  1.  ;
  1.  I '$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")),'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) W !,"No Paid Amounts or Reject Codes entered" Q -1
  1.  ;
  1.  ; Default OTHER PAYER COVERAGE TYPE to PRIMARY
  1.  S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,2)="01"
  1.  ;
  1.  ; Default OTHER PAYER ID QUALIFIER to BIN
  1.  S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,3)="03"
  1.  ;
  1.  ; If the PRIOR PAYMENT is 0 but the user entered paid amounts, update the PRIOR PAYMENT
  1.  I +$G(BPSPRARR("PRIOR PAYMENT"))=0,$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) D
  1.  . S BPSPRARR("PRIOR PAYMENT")=TOTAL
  1.  . I TOTAL>0 S BPSPRARR("308-C8")="02"
  1.  . E  S BPSPRARR("308-C8")="04"
  1.  ;
  1. END ;
  1.  Q 1
  1.  ;
  1.  ; 
  1. ASKPAID(BPSSET,BPSQUAL,BPSAMT,BPCNT,BPSPAID) ;
  1.  N RETV1,RETV2,BPSX,BPSPRA,BPSQ S BPSQ=0
  1.  I BPCNT>8 W !,"  Maximum of 9 OTHER PAYER AMOUNT PAID reached." Q 1
  1. ASK1 S RETV1=$$PROMPT("SOA"_U_BPSSET,"OTHER PAYER AMOUNT PAID QUALIFIER:  ",$G(BPSQUAL),"Type of payment from other sources (including coupons)")
  1.  I RETV1=-1!(RETV1="") Q 1
  1.  I RETV1="08",$D(BPSPAID(2)) W !,"  Qualifier '08' cannot be entered with other qualifiers" G ASK1
  1.  S RETV2=$$PROMPT("NO"_U_"0:999999.99:2","OTHER PAYER AMOUNT PAID",$G(BPSAMT),"Amount of any payment from other sources (including coupons)")
  1.  I RETV2=-1!(RETV2="") Q 1
  1.  ; Check for duplicate qualifiers and add Amount Paid to previous amount entered
  1.  I $D(BPSPAID(2,RETV1)) D  Q 0
  1.  . S BPSX="" F  S BPSX=$O(BPSPAID(1,BPSX)) Q:BPSX=""  D  Q:BPSQ
  1.  . . I $P(BPSPAID(1,BPSX),U,2)=RETV1 D
  1.  . . . S BPSPRA=$P(BPSPAID(1,BPSX),U),$P(BPSPAID(1,BPSX),U)=BPSPRA+RETV2,BPSQ=1
  1.  . . . W !,"  $",$FN(RETV2,",",2)," has been added to amount $",$FN(BPSPRA,",",2)," for Qualifier ",RETV1
  1.  S BPCNT=BPCNT+1
  1.  S BPSPAID(1,BPCNT)=RETV2_U_$$GETPDIEN^BPSPRRX6(RETV1)
  1.  S BPSPAID(2,RETV1)=""
  1.  I RETV1="08" Q 1
  1.  Q 0
  1.  ;
  1. DISPSEC(BPSPRARR) ;
  1.  ; Validate and Display the current secondary insurance information and prompt to edit.
  1.  ; Input:
  1.  ;   BPSPRARR - Array of COB data, passed by reference
  1.  ;
  1.  N BPSPIEN,BPSCOB,BPSCOV,BPX,BPSCOV,DATA
  1.  ;
  1.  ; Other Payer IEN defaults to 1 since we don't do tertiary
  1.  S BPSPIEN=1,BPSCOB="SECONDARY"
  1.  ;
  1.  ; Get Coverage Code
  1.  S BPSCOV=$G(BPSPRARR("308-C8"))
  1.  I BPSCOV="02" S BPSCOV="02 (OTHER COVERAGE EXISTS - PAYMENT COLLECTED)"
  1.  E  I BPSCOV="03" S BPSCOV="03 (OTHER COVERAGE EXISTS - THIS CLAIM NOT COVERED)"
  1.  E  S BPSCOV="04 (OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED)"
  1.  ;
  1.  ; Write Data
  1.  W !!,"Data for Secondary Claim"
  1.  W !,"------------------------"
  1.  W !,"Insurance:  "_$G(BPSPRARR("INS NAME"))_"    COB: "_BPSCOB
  1.  W !,"Rate Type:  "_$$GET1^DIQ(399.3,$G(BPSPRARR("RTYPE"))_",",.01,,,,)
  1.  W !,"Other Coverage Code:  "_BPSCOV
  1.  W !,"Other Payer Coverage Type:  01 (PRIMARY)"
  1.  W !,"Other Payer ID Qualifier:  03 (BANK INFORMATION NUMBER (BIN))"
  1.  W !,"Other Payer ID:  "_$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4)
  1.  W !,"Other Payer Date:  "_$$FMTE^XLFDT($P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5))
  1.  W !,"Other Payer Reconciliation ID: "_$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,11)
  1.  ;
  1.  ; Write Paid Amounts if previous claim if they are there
  1.  I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) D
  1.  . S BPX=0 F  S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX)) Q:BPX=""  D
  1.  . . S DATA=BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)
  1.  . . W !,"Other Payer Paid Qualifier:  "_$$GET1^DIQ(9002313.2,$P(DATA,U,2),.01)_" ("_$$GET1^DIQ(9002313.2,$P(DATA,U,2),.02)_")"
  1.  . . W !,"Other Payer Amount Paid:  $"_$FN($P(DATA,U,1),",",2)
  1.  . . I $P(DATA,U,3)'="" D
  1.  . . . W !,"Other Payer Patient Resp Amount Qualifier:  06 (AMT REPORTED BY PRIOR PAYER)"
  1.  . . . W !,"Other Payer Patient Resp Amount:  $"_$FN($P(DATA,U,3),",",2)
  1.  ;
  1.  ; Write Reject Codes if previous claims if they are there
  1.  I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) D
  1.  . S BPX=0 F  S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX)) Q:BPX=""  D
  1.  . . W !,"Other Payer Reject Code:  "_$$TRANREJ^BPSECFM($G(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)))
  1.  Q
  1.  ;
  1. PROMPT(ZERONODE,PRMTMSG,DFLTVAL,BPSHLP) ;
  1.  ;prompts for selection
  1.  ;returns selection
  1.  ;OR -1 when timeout and uparrow
  1.  ;
  1.  N Y,DUOUT,DTOUT,BPQUIT,DIROUT
  1.  N DIR
  1.  S DIR(0)=ZERONODE
  1.  S DIR("A")=PRMTMSG
  1.  I BPSHLP]"" S DIR("?")=BPSHLP
  1.  S:$L($G(DFLTVAL))>0 DIR("B")=DFLTVAL
  1.  D ^DIR
  1.  I (Y=-1)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) Q -1
  1.  Q Y
  1.  ;
  1. GETCDLST(VERSION) ; Returns a list of codes by field/version for use in PROMPTS
  1.  N CSUB,VSUB,ARRAY,X,BPSSET,BPSCD,BPSV,BPSOK
  1.  S VERSION=$G(VERSION)
  1.  S VERSION=$S(VERSION=5.1:51,VERSION=51:51,VERSION="D.0":"D0",VERSION="D0":"D0",1:"D0")
  1.  S BPSSET=""
  1.  S BPSCD=0 F  S BPSCD=$O(^BPS(9002313.2,BPSCD)) Q:BPSCD=""  D
  1.  . S (BPSOK,BPSV)=0 F  S BPSV=$O(^BPS(9002313.2,BPSCD,1,BPSV)) Q:BPSV=""  D  Q:BPSOK
  1.  . . I $P($G(^BPS(9002313.2,BPSCD,1,BPSV,0)),U)=VERSION S BPSOK=1
  1.  . I BPSOK S ARRAY(BPSCD)=$P(^BPS(9002313.2,BPSCD,0),U,1)_U_$P(^BPS(9002313.2,BPSCD,0),U,2)
  1.  S X=0 F  S X=$O(ARRAY(X)) Q:X=""  D
  1.  . S BPSSET=BPSSET_$P(ARRAY(X),U)_":"_$P(ARRAY(X),U,2)_";"
  1.  Q BPSSET
  1.  ;
  1. PAYSHTV(BPSPLAN) ;Get the Billing Payer Sheet version for this plan
  1.  ; BPSPLAN = IEN to GROUP INSURANCE PLAN file #355.3
  1.  N BPSPSH,BPSBPSH
  1.  ; Get Payer Sheets
  1.  S BPSPSH=$$PLANEPS^IBNCPDPU(BPSPLAN)
  1.  ; Get Billing Payer Sheet
  1.  I +BPSPSH S BPSBPSH=$P($P(BPSPSH,"^",2),",")
  1.  I $G(BPSBPSH)']"" Q ""
  1.  Q $P(^BPSF(9002313.92,BPSBPSH,1),U,2)
  1.  ;
  1.  ;because the set of codes is too long to fit the MUMPS code line - use a special code to populte set of codes
  1. SET308(BPSSET) ;
  1.  N BPX,BPZ
  1.  F BPX=2:1 S BPZ=$P($T(SET308C8+BPX),";;",2) Q:BPZ=""  D
  1.  . S BPSSET=BPSSET_$P(BPZ,U)_";"
  1.  Q
  1.  ;
  1. SET308C8 ;set of codes for 308-C8
  1.  ; set of codes
  1.  ;;00:NOT SPECIFIED BY PATIENT
  1.  ;;01:NO OTHER COVERAGE IDENTIFIED
  1.  ;;02:OTHER COVERAGE EXISTS - PAYMENT COLLECTED
  1.  ;;03:OTHER COVERAGE BILLED - CLAIM NOT COVERED
  1.  ;;04:OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED
  1.  ;;08:CLAIM IS BILLING FOR PATIENT FINANCIAL RESPONSIBILITY ONLY
  1.  ;;
  1.  ;
  1.  ;BPSPRRX3