BPSRES ;BHAM ISC/BEE - ECME SCREEN RESUBMIT W/EDITS ;3/12/08 14:01
;;1.0;E CLAIMS MGMT ENGINE;**3,5,7,8,10,11,20,21,23,24,30,32,35,40**;JUN 2004;Build 25
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $$RXRLDT^PSOBPSUT in ICR #4701
; Reference to $$RXFLDT^PSOBPSUT in ICR #4701
; Reference to $$FIND^PSOREJUT in ICR #4706
; Reference to GET^PSOREJU2 in ICR #6749
;
;ECME Resubmit w/EDITS Protocol (Hidden) - Called by [BPS USER SCREEN]
;
RESED N BPSEL
;
I '$D(@(VALMAR)) G XRESED
D FULL^VALM1
;
; Select the claim to resubmit
;
W !,"Enter the line number for the claim to be resubmitted."
S BPSEL=$$ASKLINE^BPSRES1("Select item","Please select a SINGLE claim only when using the Resubmit w/EDITS action option.")
I BPSEL<1 S VALMBCK="R" G XRESED
;
; Attempt to resubmit the claim, update the content of the screen,
; and display only if claim submitted successfully
;
I $$DOSELCTD(BPSEL) D REDRAW^BPSSCRUD("Updating screen for resubmitted claim...")
E S VALMBCK="R"
;
XRESED Q
;
; Attempt to Edit and Resubmit Selected Claim
;
; Input Value -> BPRXI - Entry with ptr to BPS TRANSACTION file
;
; Return Value -> 0 - Claim was not resubmitted
; 1 - Claim was resubmitted
;
DOSELCTD(BPRXI) ;
N BP02,BP59,BPADDLTXT,BPBILL,BPCLTOT,BPDFN,BPDOSDT,BPOVRIEN,BPQ
N BPRXIEN,BPRXR,BPSTATUS,BPUPDFLG,BPCOB,BPSURE,BPPTRES,BPPHSRV
N BPDLYRS,COBDATA,BPPRIOPN,BPSPCLS,BPMSG
S BPQ=""
S BPADDLTXT=""
S (BPCLTOT,BPUPDFLG)=0
;
; Pull BPS TRANSACTION/BPS CLAIMS entries
;
S BP59=$P(BPRXI,U,4) I BP59="" W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Re-Submission",! G XRES
;
; Check for non-billable entry
;
I $$NB^BPSSCR03(BP59) W !!,"Entry is NON BILLABLE. There is no claim to edit or resubmit.",! G XRES
;
S BP02=+$P($G(^BPST(BP59,0)),U,4) I 'BP02 W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Re-Submission",! G XRES
;
; Display selected claim and ask to submit
;
W @IOF ; Form feed
S BPDFN=+$P($G(^BPST(BP59,0)),U,6)
W !,"You've chosen to RESUBMIT the following prescription for "_$E($$PATNAME^BPSSCRU2(BPDFN),1,13)
W !,@VALMAR@(+$P(BPRXI,U,5),0)
S BPQ=$$YESNO^BPSSCRRS("Are you sure(Y/N)")
I BPQ'=1 S BPQ="^" G XRES
;
; Check to make sure claim can be Resubmitted w/EDITS
;
S BPRXIEN=$P(BP59,".")
S BPRXR=+$E($P(BP59,".",2),1,4)
I $$RXDEL^BPSOS($P(BP59,".",1),+$E($P(BP59,".",2),1,4)) W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"cannot be Resubmitted w/EDITS because it has been deleted in Pharmacy.",! G XRES
S BPSTATUS=$P($$CLAIMST^BPSSCRU3(BP59),U)
I BPSTATUS["IN PROGRESS" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is still In Progress and cannot be Resubmitted w/EDITS",! G XRES
I '$D(^XUSEC("BPS SUPERVISOR",DUZ)),BPSTATUS'["E REJECTED" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Resubmitted w/EDITS",! G XRES
I $D(^XUSEC("BPS SUPERVISOR",DUZ)),BPSTATUS'["E REJECTED",BPSTATUS'["E PAYABLE" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Resubmitted w/EDITS",! G XRES
I $P($G(^BPST(BP59,0)),U,14)<2,$$PAYABLE^BPSOSRX5(BPSTATUS),$$PAYBLSEC^BPSUTIL2(BP59) D G XRES
. W !,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"cannot be Resubmitted if the secondary claim is payable.",!,"Please reverse the secondary claim first."
;
; Can't resubmit a closed claim. The user must reopen first.
;
I $$CLOSED^BPSSCRU1(BP59) W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is Closed and cannot be Resubmitted w/EDITS.",! G XRES
;
; If this is a secondary, make sure Primary is either Payable or Closed.
;
S BPPRIOPN=0
S BPCOB=$$COB59^BPSUTIL2(BP59)
I BPCOB=2 D G XRES:BPPRIOPN=1
. ; Get Primary claim status
. S BPSPCLS=$$FINDECLM^BPSPRRX5(BPRXIEN,BPRXR,1)
. I $P(BPSPCLS,U)>1 D
. . I $$CLOSED^BPSSCRU1($P(BPSPCLS,U,2)) Q
. . W !,"The secondary claim cannot be Resubmitted unless the primary is either payable",!,"or closed. Please resubmit or close the primary claim first."
. . S BPPRIOPN=1
;
I BPSTATUS["E PAYABLE" D I BPQ="^" G XRES
. S BPQ=$$YESNO^BPSSCRRS("You have selected a PAYABLE claim. Do you want to continue")
. I BPQ'=1 S BPQ="^"
;
; Retrieve Date of Service, then prompt for EDIT Information.
;
S BPDOSDT=$$DOSDATE^BPSSCRRS(BPRXIEN,BPRXR)
S BPOVRIEN=$$PROMPTS(BP59,BP02,BPRXIEN,BPRXR,BPCOB,.BPDOSDT,.COBDATA,.BPADDLTXT) I BPOVRIEN=-1 G XRES
;
; Submit the claim
;
S BPBILL=$$EN^BPSNCPDP(BPRXIEN,BPRXR,BPDOSDT,"ERES","","ECME RESUBMIT","",BPOVRIEN,"","",BPCOB,"F","","",$G(COBDATA("PLAN")),.COBDATA,$G(COBDATA("RTYPE")))
;
; Print Return Value Message. Change Return Message for SC/EI.
;
W !!
I +BPBILL>0 W $S(+BPBILL=10:"Reversal but no Resubmit:",1:"Not Processed:"),!," "
I $P(BPBILL,U,2)="NEEDS SC DETERMINATION" S $P(BPBILL,U,2)="NEEDS SC/EI DETERMINATION"
W $P(BPBILL,U,2)
;
; BPBILL[1] is a number representing the outcome of the attempted
; claim submission.
; 0 Prescription/Fill successfully submitted to ECME
; 1 ECME did not submit prescription/fill
; 2 IB concluded this Rx is not ECME billable, or the data returned
; from IB is not valid
; 3 ECME closed the claim but did not submit it to the payer
; 4 Unable to queue the ECME claim
; 5 Invalid input
; 6 ECME is currently inactive
; 10 Reversal processed but claim was not resubmitted
;
I +BPBILL=0 D
. S BPMSG="ECME RED Resubmit Claim w/Edits"
. ;
. ; If Date of Service additional text exists, create ECME Log entry
. I $P(BPADDLTXT,"^")'="" D
. . S BPMSG=BPMSG_": "_$P(BPADDLTXT,"^")
. . S BPMSG=BPMSG_"-"_$S(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)
. . S BPMSG=$E(BPMSG,1,100)
. . D ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,BPMSG)
. ;
. ; If Diagnosis Code additional text exists, create ECME Log entry
. I $P(BPADDLTXT,"^",2)'="" D
. . S BPMSG="ECME RED Resubmit Claim w/Edits"
. . S BPMSG=BPMSG_": "_$P(BPADDLTXT,"^",2)
. . S BPMSG=BPMSG_"-"_$S(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)
. . S BPMSG=$E(BPMSG,1,100)
. . D ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,BPMSG)
. ;
. ; If neither DOS or Dx Code additional text exist, create ECME Log entry
. I $P(BPADDLTXT,"^")="",$P(BPADDLTXT,"^",2)="" D
. . S BPMSG=BPMSG_"-"_$S(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)
. . S BPMSG=$E(BPMSG,1,100)
. . D ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,BPMSG)
. ;
. S BPUPDFLG=1,BPCLTOT=1
;
XRES ;
I BPCLTOT W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",!
D PAUSE^VALM1
Q BPUPDFLG
;
XRES2 ;
I BPCLTOT W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",!
Q BPUPDFLG
;
;Enter EDIT information for claim
;
; Input Values -> BP59 - The BPS TRANSACTION entry
; BP02 - The BPS CLAIMS entry
; BPRXIEN - Prescription IEN (#52)
; BPRXR - Fill Number
; BPCOB - (optional) payer sequence (1-primary, 2 -secondary)
; BPDOSDT - Date of Service, passed by reference
; BPSECOND - Array, passed by reference, of COB data
; BPADDLTXT - Passed by reference, text to add to ECME Log
; ^ Piece 1 = user chooses to use Date of Service
; on the claim instead of the Release Date.
; ^ Piece 2 = user chooses to submit a Diagnosis Code
; Output Value -> BPQ - -1 - The user chose to quit
; "" - The user completed the EDITS
PROMPTS(BP59,BP02,BPRXIEN,BPRXR,BPCOB,BPDOSDT,BPSECOND,BPADDLTXT) ;
N %,BP300,BP35401,BPSADDLFLDS,BPCLCD1,BPCLCD2,BPCLCD3
N BPCLCDN,BPCLCDX,BPDFN,BPDIAGNOSIS,BPFDA,BPFLD,BPGENDER
N BPMED,BPOVRIEN,BPPSNCD,BPPREAUT,BPPRETYP,BPQ,BPRELCD
N BPRELEASEDT,BPSEX,BPSIG,BPSX,DFLTDX,DIC,DIR,DIROUT
N DIRUT,DTOUT,DUOUT,DUP,X,Y
;
S BPQ=""
I +$G(BPCOB)=0 S BPCOB=1
;
; Pull Information from Claim
;
S BP300=$G(^BPSC(BP02,300))
S BPRELCD=$TR($E($P(BP300,U,6),3,99)," ")
S BPPSNCD=$TR($E($P(BP300,U,3),3,99)," ")
S (BPPRETYP,BPPREAUT,BPDLYRS,BPPHSRV)=""
S BPMED=0
F S BPMED=$O(^BPSC(BP02,400,BPMED)) Q:'BPMED D I BPPREAUT]"" Q
. N BP460
. S BP460=$G(^BPSC(BP02,400,BPMED,460))
. I BPPREAUT="" S BPPREAUT=$TR($E($P(BP460,U,2),3,99)," "),BPPRETYP=$TR($E($P(BP460,U),3,99)," ")
. I BPDLYRS="" S BPDLYRS=$TR($E($P($G(^BPSC(BP02,400,BPMED,350)),U,7),3,99)," ")
. I BPDLYRS]"" S BPDLYRS=+BPDLYRS
. I BPPHSRV="" S BPPHSRV=$TR($E($P($G(^BPSC(BP02,400,BPMED,140)),U,7),3,99)," ")
. F BP35401=1:1:3 S @("BPCLCD"_BP35401)=$TR($E($P($G(^BPSC(BP02,400,BPMED,354.01,BP35401,1)),U),3,99)," ")
. S BPCLCD1=+BPCLCD1 I BPCLCD1=0 S BPCLCD1=1
. Q
S BPPTRES=$TR($E($P($G(^BPSC(BP02,380)),U,4),3,99)," ")
I BPPTRES="" S BPPTRES=1
I BPPHSRV="" S BPPHSRV=1
;
; Relationship Code
;
S DIC("B")=BPRELCD
S DIC(0)="QEAM",DIC=9002313.19,DIC("A")="Pharmacy Relationship Code: "
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPRELCD=$P(Y,U,2)
K X,DIC,Y
;
; Person Code
;
K DIR("?") S DIR(0)="FO^1:3",DIR("A")="Pharmacy Person Code",DIR("?")="Enter the Specific Person Code Assigned to the Patient by the Payer"
S DIR("B")=BPPSNCD
D ^DIR
I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS
S BPPSNCD=Y
;
; Pre-Authorization
;
K DIR("?") S DIR(0)="FO^1:11",DIR("A")="Prior Authorization Number",DIR("?")="Enter the Number Submitted by the Provider to Identify the Prior Authorization"
S DIR("B")=BPPREAUT
D ^DIR
I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS
S BPPREAUT=Y
;
; Prior-Authorization Type Code
;
N X,DIC,Y
S DIC("B")=+BPPRETYP
S DIC(0)="QEAM",DIC=9002313.26,DIC("A")="Prior Authorization Type Code: "
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPPRETYP=$P(Y,U,2)
K X,DIC,Y
;
; If there is a pending reject on the Pharmacists Worklist, or there
; is a resolved or unresolved reject 79 or 88 or 943, then only display
; Submission Clarification Codes and do not allow enter/edit.
;
I $$BPSKIP(BPRXIEN,BPRXR) D G P1
. F BP35401=1:1:3 I @("BPCLCD"_BP35401) D
. . S BPSX=+@("BPCLCD"_BP35401)
. . W !,"Submission Clarification Code ",BP35401,": ",BPSX
. . S BPCLCDX=$O(^BPS(9002313.25,"B",BPSX,"")),BPCLCDN=$P(^BPS(9002313.25,BPCLCDX,0),U,2)
. . W ?44,BPCLCDN
. . Q
. W !," **OPECC cannot edit Sub. Clar. Code field for this reject - refer to Pharmacist"
. Q
;
; Submission Clarification Code 1
;
S DIC("B")=BPCLCD1
S DIC(0)="QEAM",DIC=9002313.25,DIC("A")="Submission Clarification Code 1: "
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPCLCD1=$P(Y,U,2)
K X,DIC,Y
;
; Submission Clarification Code 2
;
I +BPCLCD2 S BPCLCD2=+BPCLCD2 S DIC("B")=BPCLCD2
S DIC(0)="QEAM",DIC=9002313.25,DIC("A")="Submission Clarification Code 2: ",DUP=0
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
F D Q:BPQ=-1 Q:'DUP
. D ^DIC
. I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 Q
. S BPCLCD2=$P(Y,U,2)
. S DUP=0 I BPCLCD2=BPCLCD1 S BPCLCD2="" W !," Duplicates not allowed" S DUP=1
K X,DIC,Y
I BPQ=-1 G XPROMPTS
;
; Submission Clarification Code 3
;
I BPCLCD2'="" D I BPQ=-1 G XPROMPTS
. I +BPCLCD3 S BPCLCD3=+BPCLCD3 S DIC("B")=BPCLCD3
. S DIC(0)="QEAM",DIC=9002313.25,DIC("A")="Submission Clarification Code 3: ",DUP=0
. S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
. F D Q:'DUP I BPQ=-1 Q
. . D ^DIC
. . I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 Q
. . S BPCLCD3=$P(Y,U,2)
. . S DUP=0 I BPCLCD3=BPCLCD1!(BPCLCD3=BPCLCD2) S BPCLCD3="" W !," Duplicates not allowed" S DUP=1
. K X,DIC,Y
;
P1 ;
;
; If the user opts to use the Date of Service instead of the
; Release Date, then set BPADDLTXT, which will be used when creating
; an entry in the Activity Log.
;
S BPADDLTXT=""
S BPRELEASEDT=$$RELDATE^BPSBCKJ(+BPRXIEN,+BPRXR)
I BPRELEASEDT]"" D I BPQ=-1 G XPROMPTS
. S BPDOSDT=$$EDITDT^BPSRES1(1,BPRXIEN,BPRXR,BP02)
. I BPDOSDT="^" S BPQ=-1 Q
. I BPDOSDT'=(BPRELEASEDT\1) S $P(BPADDLTXT,"^")="Date of Service ("_$$FMTE^XLFDT(BPDOSDT,5)_")"
. Q
;
; Patient Residence Code
;
N X,DIC,Y
S DIC("B")=+BPPTRES
S DIC(0)="QEAM",DIC=9002313.27,DIC("A")="Patient Residence Code: "
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPPTRES=$P(Y,U,2)
K X,DIC,Y
;
; Pharmacy Service Type Code
;
N X,DIC,Y
S DIC("B")=+BPPHSRV
S DIC(0)="QEAM",DIC=9002313.28,DIC("A")="Pharmacy Service Type Code: "
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPPHSRV=$P(Y,U,2)
K X,DIC,Y
;
; Delay Reason Code
;
N X,DIC,Y
S DIC("B")=BPDLYRS
S DIC(0)="QEAM",DIC=9002313.29,DIC("A")="Delay Reason Code: "
S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
D ^DIC
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPDLYRS=$P(Y,U,2)
K X,DIC,Y
;
; Patient Gender Code, 305-C5
; Limit valid entries to the values in the fields SEX and SELF
; IDENTIFIED GENDER (if populated), then determine the Patient
; Gender Code based on the value selected.
;
S BPGENDER=""
S BPDFN=$$GET1^DIQ(9002313.59,BP59,5,"I")
I BPDFN'="" D I BPQ=-1 G XPROMPTS
. N X,DIR,Y
. S BPSEX=$$GET1^DIQ(2,BPDFN,.02,"I")
. S BPSEX=BPSEX_":"_$S(BPSEX="M":"Male",BPSEX="F":"Female",1:"")_" (Birth Sex)"
. S BPSIG=$$GET1^DIQ(2,BPDFN,.024,"I")_":"_$$GET1^DIQ(2,BPDFN,.024,"E")_" (Self-Identified Gender)"
. S DIR("B")=$P(BPSIG,":",2)
. S DIR(0)="SA^"_BPSEX_";"_BPSIG
. I $P(BPSIG,":",1)="" S DIR("B")=$P(BPSEX,":",2),$P(DIR(0),"^",2)=BPSEX
. S DIR("A")="Patient Gender Code: "
. S DIR("?")="Available Gender Codes are determined by the VistA Patient file."
. ;
. D ^DIR
. ;
. I $D(DUOUT)!$D(DTOUT) S BPQ=-1 Q
. S BPGENDER=$S(Y="M":1,Y="F":2,Y="N":0,1:3)
. Q
;
; Diagnosis Code, 424-DO
; Default Diagnosis Code from BPS CLAIMS file, field 424
; Only ICD-10-CM codes are allowed for selection
;
S BPDIAGNOSIS=""
N DIR,X,Y
S DIR(0)="PO^80:AEQMZ"
S DFLTDX=$P($E($$GET1^DIQ(9002313.0201,1_","_BP02_",",424),3,17)," ")
I $G(DFLTDX)'="" S DFLTDX=$E(DFLTDX,1,3)_"."_$E(DFLTDX,4,10)
S DIR("B")=DFLTDX
S DIR("S")="I $P($G(^ICDS($P(^(1),""^"",1),0)),""^"",1)=""ICD-10-CM"""
D ^DIR
I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 G XPROMPTS
S BPDIAGNOSIS=$P(Y,U,2)
I $D(DIRUT),X="@" D I $D(DIRUT) S BPQ=-1 G XPROMPTS
. K DIR,DIRUT,X,Y
. I DFLTDX="" S BPDIAGNOSIS="" Q
. S DIR(0)="Y^E"
. S DIR("A")=" Are you sure you want to delete "_DFLTDX
. S DIR("B")="No"
. S BPDIAGNOSIS=DFLTDX
. D ^DIR
. I Y S BPDIAGNOSIS="REMOVED"
;
I BPDIAGNOSIS'="" D
. I BPDIAGNOSIS="REMOVED" S $P(BPADDLTXT,"^",2)="Diagnosis Code (Removed)"
. E S $P(BPADDLTXT,"^",2)="Diagnosis Code ("_BPDIAGNOSIS_")"
;
; If secondary claim, setup secondary data and allow user to edit.
;
I BPCOB=2 D I BPQ=-1 G XPROMPTS
. N BPSPL59,BPRTTP59
. ;
. ; Get data from the primary claim, if it exists.
. ; If the primary claim data is missing, get data from the
. ; most recent secondary claim
. ;
. S BPRET=$$PRIMDATA^BPSPRRX6(BPRXIEN,BPRXR,.BPSECOND)
. I 'BPRET,$$SECDATA^BPSPRRX6(BPRXIEN,BPRXR,.BPSPL59,.BPSECOND,.BPRTTP59)
. ;
. ; The PRIMARY BILL element is set by $$SECDATA. If SECDATA is not
. ; called, this element will be missing and we will need to create it.
. ;
. I '$D(BPSECOND("PRIMARY BILL")) D
. . N BPBILL
. . S BPBILL=$$PAYBLPRI^BPSUTIL2(BP59)
. . I BPBILL>0 S BPSECOND("PRIMARY BILL")=BPBILL
. ;
. ; Set flag telling BPSNCPDP not to recompile the data from the BPS
. ; Transaction and the secondary claim.
. ;
. S BPSECOND("NEW COB DATA")=1
. ;
. ; $$PROMPTS displays the data and allows the user to edit the data.
. ;
. S BPQ=$$PROMPTS^BPSPRRX3(BPRXIEN,BPRXR,BPDOSDT,.BPSECOND)
;
; Allow user to add to the claim additional fields which are
; not on the payer sheet. $$ADDLFLDS will return 0 if no
; additional fields were selected or -1 if the user exited out.
;
S BPQ=$$ADDLFLDS^BPSRES1(BP02,BP59,.BPSADDLFLDS)
I BPQ=-1 G XPROMPTS
;
; Ask to proceed
;
W !
S BPQ=$$YESNO^BPSSCRRS("Are you sure(Y/N)")
I BPQ'=1 S BPQ=-1 G XPROMPTS
S BPQ=1
;
; Save the override values and the list of additional fields
; in file# 9002313.511, BPS NCPDP OVERRIDES.
;
I '$$SAVE^BPSRES1("RED",BP59,.BPSADDLFLDS,.BPOVRIEN) S BPQ=-1
;
XPROMPTS ;
S BPOVRIEN=$S(BPQ=-1:BPQ,$G(BPOVRIEN(1))]"":BPOVRIEN(1),1:-1)
Q BPOVRIEN
;
BPSKIP(BPSRX,BPSFILL) ; Determine whether to skip the enter/edit of Submission Clarification Codes
; This function will return a '1' if the enter/edit of Submission
; Clarification Codes should be skipped (not allowed).
;
N BPS7988DATE,BPSACTIVITY,BPSECMEDATE,BPSREJECT,BPSX
;
; If any open/unresolved rejects are on the pharmacist worklist, Quit with 1.
;
I $$FIND^PSOREJUT(BPSRX,BPSFILL) Q 1
;
; If there are any closed/resolved 79/88/943 rejects for this Rx/Fill,
; pull the latest detected date/time.
; If there has not been any ECME activity since that date/time, then
; disallow the edit of Submission Clarification Codes, Quit with 1.
;
S BPS7988DATE=0
;
; Loop through the REJECTS multiple.
;
S BPSREJECT=0
F S BPSREJECT=$O(^PSRX(BPSRX,"REJ",BPSREJECT)) Q:'BPSREJECT D
. ;
. ; If a reject is not for the current fill, skip this one.
. I $$GET1^DIQ(52.25,BPSREJECT_","_BPSRX,5)'=BPSFILL Q
. ;
. ; If not a 79 or 88 or 943, skip this one.
. I ",79,88,943,"'[(","_$$GET1^DIQ(52.25,BPSREJECT_","_BPSRX,.01)_",") Q
. ;
. ; Pull DATE/TIME DETECTED. If the date/time is later than
. ; BPS7988DATE, then reset BPS7988DATE to that date/time.
. S BPSX=$$GET1^DIQ(52.25,BPSREJECT_","_BPSRX,1,"I")
. I BPSX>BPS7988DATE S BPS7988DATE=BPSX
. Q
;
; If <blank> then Quit with 0.
;
I BPS7988DATE=0 Q 0
;
; Once we have the most recent DATE/TIME DETECTED, determine whether
; there is ECME activity later than that.
;
; Loop through entries the ACTIVITY LOG multiple.
;
S (BPSX,BPSACTIVITY,BPSECMEDATE)=0
F S BPSACTIVITY=$O(^PSRX(BPSRX,"A",BPSACTIVITY)) Q:'BPSACTIVITY D
. ;
. ; If the REASON is not "M" (=ECME), skip.
. I $$GET1^DIQ(52.3,BPSACTIVITY_","_BPSRX,.02,"I")'="M" Q
. ;
. ; Pull the date/time stamp from the activity log entry. If later
. ; than what we found so far, update BPSECMEDATE.
. S BPSX=$$GET1^DIQ(52.3,BPSACTIVITY_","_BPSRX,.01,"I")
. I BPSX>BPSECMEDATE S BPSECMEDATE=BPSX
. Q
;
; If the BPSECMEDATE is later than BPS7988DATE, then Quit with 0
; to allow the edit of Submission Clarification Codes. Otherwise,
; Quit with 1 to skip, not allow, the enter/edit of those codes.
; When a claim is rejected, the time stamp on the Activity Log may
; be a second or two later than the time stamp on the Reject.
; Therefore, we add 60 seconds to the time stamp on the reject when
; making this comparison.
;
I BPSECMEDATE>(BPS7988DATE+.00006) Q 0
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSRES 19251 printed Sep 23, 2025@19:28:45 Page 2
BPSRES ;BHAM ISC/BEE - ECME SCREEN RESUBMIT W/EDITS ;3/12/08 14:01
+1 ;;1.0;E CLAIMS MGMT ENGINE;**3,5,7,8,10,11,20,21,23,24,30,32,35,40**;JUN 2004;Build 25
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $$RXRLDT^PSOBPSUT in ICR #4701
+5 ; Reference to $$RXFLDT^PSOBPSUT in ICR #4701
+6 ; Reference to $$FIND^PSOREJUT in ICR #4706
+7 ; Reference to GET^PSOREJU2 in ICR #6749
+8 ;
+9 ;ECME Resubmit w/EDITS Protocol (Hidden) - Called by [BPS USER SCREEN]
+10 ;
RESED NEW BPSEL
+1 ;
+2 IF '$DATA(@(VALMAR))
GOTO XRESED
+3 DO FULL^VALM1
+4 ;
+5 ; Select the claim to resubmit
+6 ;
+7 WRITE !,"Enter the line number for the claim to be resubmitted."
+8 SET BPSEL=$$ASKLINE^BPSRES1("Select item","Please select a SINGLE claim only when using the Resubmit w/EDITS action option.")
+9 IF BPSEL<1
SET VALMBCK="R"
GOTO XRESED
+10 ;
+11 ; Attempt to resubmit the claim, update the content of the screen,
+12 ; and display only if claim submitted successfully
+13 ;
+14 IF $$DOSELCTD(BPSEL)
DO REDRAW^BPSSCRUD("Updating screen for resubmitted claim...")
+15 IF '$TEST
SET VALMBCK="R"
+16 ;
XRESED QUIT
+1 ;
+2 ; Attempt to Edit and Resubmit Selected Claim
+3 ;
+4 ; Input Value -> BPRXI - Entry with ptr to BPS TRANSACTION file
+5 ;
+6 ; Return Value -> 0 - Claim was not resubmitted
+7 ; 1 - Claim was resubmitted
+8 ;
DOSELCTD(BPRXI) ;
+1 NEW BP02,BP59,BPADDLTXT,BPBILL,BPCLTOT,BPDFN,BPDOSDT,BPOVRIEN,BPQ
+2 NEW BPRXIEN,BPRXR,BPSTATUS,BPUPDFLG,BPCOB,BPSURE,BPPTRES,BPPHSRV
+3 NEW BPDLYRS,COBDATA,BPPRIOPN,BPSPCLS,BPMSG
+4 SET BPQ=""
+5 SET BPADDLTXT=""
+6 SET (BPCLTOT,BPUPDFLG)=0
+7 ;
+8 ; Pull BPS TRANSACTION/BPS CLAIMS entries
+9 ;
+10 SET BP59=$PIECE(BPRXI,U,4)
IF BP59=""
WRITE !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Re-Submission",!
GOTO XRES
+11 ;
+12 ; Check for non-billable entry
+13 ;
+14 IF $$NB^BPSSCR03(BP59)
WRITE !!,"Entry is NON BILLABLE. There is no claim to edit or resubmit.",!
GOTO XRES
+15 ;
+16 SET BP02=+$PIECE($GET(^BPST(BP59,0)),U,4)
IF 'BP02
WRITE !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Re-Submission",!
GOTO XRES
+17 ;
+18 ; Display selected claim and ask to submit
+19 ;
+20 ; Form feed
WRITE @IOF
+21 SET BPDFN=+$PIECE($GET(^BPST(BP59,0)),U,6)
+22 WRITE !,"You've chosen to RESUBMIT the following prescription for "_$EXTRACT($$PATNAME^BPSSCRU2(BPDFN),1,13)
+23 WRITE !,@VALMAR@(+$PIECE(BPRXI,U,5),0)
+24 SET BPQ=$$YESNO^BPSSCRRS("Are you sure(Y/N)")
+25 IF BPQ'=1
SET BPQ="^"
GOTO XRES
+26 ;
+27 ; Check to make sure claim can be Resubmitted w/EDITS
+28 ;
+29 SET BPRXIEN=$PIECE(BP59,".")
+30 SET BPRXR=+$EXTRACT($PIECE(BP59,".",2),1,4)
+31 IF $$RXDEL^BPSOS($PIECE(BP59,".",1),+$EXTRACT($PIECE(BP59,".",2),1,4))
WRITE !!,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"cannot be Resubmitted w/EDITS because it has been deleted in Pharmacy.",!
GOTO XRES
+32 SET BPSTATUS=$PIECE($$CLAIMST^BPSSCRU3(BP59),U)
+33 IF BPSTATUS["IN PROGRESS"
WRITE !!,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"is still In Progress and cannot be Resubmitted w/EDITS",!
GOTO XRES
+34 IF '$DATA(^XUSEC("BPS SUPERVISOR",DUZ))
IF BPSTATUS'["E REJECTED"
WRITE !!,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Resubmitted w/EDITS",!
GOTO XRES
+35 IF $DATA(^XUSEC("BPS SUPERVISOR",DUZ))
IF BPSTATUS'["E REJECTED"
IF BPSTATUS'["E PAYABLE"
WRITE !!,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Resubmitted w/EDITS",!
GOTO XRES
+36 IF $PIECE($GET(^BPST(BP59,0)),U,14)<2
IF $$PAYABLE^BPSOSRX5(BPSTATUS)
IF $$PAYBLSEC^BPSUTIL2(BP59)
Begin DoDot:1
+37 WRITE !,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"cannot be Resubmitted if the secondary claim is payable.",!,"Please reverse the secondary claim first."
End DoDot:1
GOTO XRES
+38 ;
+39 ; Can't resubmit a closed claim. The user must reopen first.
+40 ;
+41 IF $$CLOSED^BPSSCRU1(BP59)
WRITE !!,"The claim: ",!,@VALMAR@(+$PIECE(BPRXI,U,5),0),!,"is Closed and cannot be Resubmitted w/EDITS.",!
GOTO XRES
+42 ;
+43 ; If this is a secondary, make sure Primary is either Payable or Closed.
+44 ;
+45 SET BPPRIOPN=0
+46 SET BPCOB=$$COB59^BPSUTIL2(BP59)
+47 IF BPCOB=2
Begin DoDot:1
+48 ; Get Primary claim status
+49 SET BPSPCLS=$$FINDECLM^BPSPRRX5(BPRXIEN,BPRXR,1)
+50 IF $PIECE(BPSPCLS,U)>1
Begin DoDot:2
+51 IF $$CLOSED^BPSSCRU1($PIECE(BPSPCLS,U,2))
QUIT
+52 WRITE !,"The secondary claim cannot be Resubmitted unless the primary is either payable",!,"or closed. Please resubmit or close the primary claim first."
+53 SET BPPRIOPN=1
End DoDot:2
End DoDot:1
if BPPRIOPN=1
GOTO XRES
+54 ;
+55 IF BPSTATUS["E PAYABLE"
Begin DoDot:1
+56 SET BPQ=$$YESNO^BPSSCRRS("You have selected a PAYABLE claim. Do you want to continue")
+57 IF BPQ'=1
SET BPQ="^"
End DoDot:1
IF BPQ="^"
GOTO XRES
+58 ;
+59 ; Retrieve Date of Service, then prompt for EDIT Information.
+60 ;
+61 SET BPDOSDT=$$DOSDATE^BPSSCRRS(BPRXIEN,BPRXR)
+62 SET BPOVRIEN=$$PROMPTS(BP59,BP02,BPRXIEN,BPRXR,BPCOB,.BPDOSDT,.COBDATA,.BPADDLTXT)
IF BPOVRIEN=-1
GOTO XRES
+63 ;
+64 ; Submit the claim
+65 ;
+66 SET BPBILL=$$EN^BPSNCPDP(BPRXIEN,BPRXR,BPDOSDT,"ERES","","ECME RESUBMIT","",BPOVRIEN,"","",BPCOB,"F","","",$GET(COBDATA("PLAN")),.COBDATA,$GET(COBDATA("RTYPE")))
+67 ;
+68 ; Print Return Value Message. Change Return Message for SC/EI.
+69 ;
+70 WRITE !!
+71 IF +BPBILL>0
WRITE $SELECT(+BPBILL=10:"Reversal but no Resubmit:",1:"Not Processed:"),!," "
+72 IF $PIECE(BPBILL,U,2)="NEEDS SC DETERMINATION"
SET $PIECE(BPBILL,U,2)="NEEDS SC/EI DETERMINATION"
+73 WRITE $PIECE(BPBILL,U,2)
+74 ;
+75 ; BPBILL[1] is a number representing the outcome of the attempted
+76 ; claim submission.
+77 ; 0 Prescription/Fill successfully submitted to ECME
+78 ; 1 ECME did not submit prescription/fill
+79 ; 2 IB concluded this Rx is not ECME billable, or the data returned
+80 ; from IB is not valid
+81 ; 3 ECME closed the claim but did not submit it to the payer
+82 ; 4 Unable to queue the ECME claim
+83 ; 5 Invalid input
+84 ; 6 ECME is currently inactive
+85 ; 10 Reversal processed but claim was not resubmitted
+86 ;
+87 IF +BPBILL=0
Begin DoDot:1
+88 SET BPMSG="ECME RED Resubmit Claim w/Edits"
+89 ;
+90 ; If Date of Service additional text exists, create ECME Log entry
+91 IF $PIECE(BPADDLTXT,"^")'=""
Begin DoDot:2
+92 SET BPMSG=BPMSG_": "_$PIECE(BPADDLTXT,"^")
+93 SET BPMSG=BPMSG_"-"_$SELECT(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)
+94 SET BPMSG=$EXTRACT(BPMSG,1,100)
+95 DO ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,BPMSG)
End DoDot:2
+96 ;
+97 ; If Diagnosis Code additional text exists, create ECME Log entry
+98 IF $PIECE(BPADDLTXT,"^",2)'=""
Begin DoDot:2
+99 SET BPMSG="ECME RED Resubmit Claim w/Edits"
+100 SET BPMSG=BPMSG_": "_$PIECE(BPADDLTXT,"^",2)
+101 SET BPMSG=BPMSG_"-"_$SELECT(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)
+102 SET BPMSG=$EXTRACT(BPMSG,1,100)
+103 DO ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,BPMSG)
End DoDot:2
+104 ;
+105 ; If neither DOS or Dx Code additional text exist, create ECME Log entry
+106 IF $PIECE(BPADDLTXT,"^")=""
IF $PIECE(BPADDLTXT,"^",2)=""
Begin DoDot:2
+107 SET BPMSG=BPMSG_"-"_$SELECT(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)
+108 SET BPMSG=$EXTRACT(BPMSG,1,100)
+109 DO ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,BPMSG)
End DoDot:2
+110 ;
+111 SET BPUPDFLG=1
SET BPCLTOT=1
End DoDot:1
+112 ;
XRES ;
+1 IF BPCLTOT
WRITE !,BPCLTOT," claim",$SELECT(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",!
+2 DO PAUSE^VALM1
+3 QUIT BPUPDFLG
+4 ;
XRES2 ;
+1 IF BPCLTOT
WRITE !,BPCLTOT," claim",$SELECT(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",!
+2 QUIT BPUPDFLG
+3 ;
+4 ;Enter EDIT information for claim
+5 ;
+6 ; Input Values -> BP59 - The BPS TRANSACTION entry
+7 ; BP02 - The BPS CLAIMS entry
+8 ; BPRXIEN - Prescription IEN (#52)
+9 ; BPRXR - Fill Number
+10 ; BPCOB - (optional) payer sequence (1-primary, 2 -secondary)
+11 ; BPDOSDT - Date of Service, passed by reference
+12 ; BPSECOND - Array, passed by reference, of COB data
+13 ; BPADDLTXT - Passed by reference, text to add to ECME Log
+14 ; ^ Piece 1 = user chooses to use Date of Service
+15 ; on the claim instead of the Release Date.
+16 ; ^ Piece 2 = user chooses to submit a Diagnosis Code
+17 ; Output Value -> BPQ - -1 - The user chose to quit
+18 ; "" - The user completed the EDITS
PROMPTS(BP59,BP02,BPRXIEN,BPRXR,BPCOB,BPDOSDT,BPSECOND,BPADDLTXT) ;
+1 NEW %,BP300,BP35401,BPSADDLFLDS,BPCLCD1,BPCLCD2,BPCLCD3
+2 NEW BPCLCDN,BPCLCDX,BPDFN,BPDIAGNOSIS,BPFDA,BPFLD,BPGENDER
+3 NEW BPMED,BPOVRIEN,BPPSNCD,BPPREAUT,BPPRETYP,BPQ,BPRELCD
+4 NEW BPRELEASEDT,BPSEX,BPSIG,BPSX,DFLTDX,DIC,DIR,DIROUT
+5 NEW DIRUT,DTOUT,DUOUT,DUP,X,Y
+6 ;
+7 SET BPQ=""
+8 IF +$GET(BPCOB)=0
SET BPCOB=1
+9 ;
+10 ; Pull Information from Claim
+11 ;
+12 SET BP300=$GET(^BPSC(BP02,300))
+13 SET BPRELCD=$TRANSLATE($EXTRACT($PIECE(BP300,U,6),3,99)," ")
+14 SET BPPSNCD=$TRANSLATE($EXTRACT($PIECE(BP300,U,3),3,99)," ")
+15 SET (BPPRETYP,BPPREAUT,BPDLYRS,BPPHSRV)=""
+16 SET BPMED=0
+17 FOR
SET BPMED=$ORDER(^BPSC(BP02,400,BPMED))
if 'BPMED
QUIT
Begin DoDot:1
+18 NEW BP460
+19 SET BP460=$GET(^BPSC(BP02,400,BPMED,460))
+20 IF BPPREAUT=""
SET BPPREAUT=$TRANSLATE($EXTRACT($PIECE(BP460,U,2),3,99)," ")
SET BPPRETYP=$TRANSLATE($EXTRACT($PIECE(BP460,U),3,99)," ")
+21 IF BPDLYRS=""
SET BPDLYRS=$TRANSLATE($EXTRACT($PIECE($GET(^BPSC(BP02,400,BPMED,350)),U,7),3,99)," ")
+22 IF BPDLYRS]""
SET BPDLYRS=+BPDLYRS
+23 IF BPPHSRV=""
SET BPPHSRV=$TRANSLATE($EXTRACT($PIECE($GET(^BPSC(BP02,400,BPMED,140)),U,7),3,99)," ")
+24 FOR BP35401=1:1:3
SET @("BPCLCD"_BP35401)=$TRANSLATE($EXTRACT($PIECE($GET(^BPSC(BP02,400,BPMED,354.01,BP35401,1)),U),3,99)," ")
+25 SET BPCLCD1=+BPCLCD1
IF BPCLCD1=0
SET BPCLCD1=1
+26 QUIT
End DoDot:1
IF BPPREAUT]""
QUIT
+27 SET BPPTRES=$TRANSLATE($EXTRACT($PIECE($GET(^BPSC(BP02,380)),U,4),3,99)," ")
+28 IF BPPTRES=""
SET BPPTRES=1
+29 IF BPPHSRV=""
SET BPPHSRV=1
+30 ;
+31 ; Relationship Code
+32 ;
+33 SET DIC("B")=BPRELCD
+34 SET DIC(0)="QEAM"
SET DIC=9002313.19
SET DIC("A")="Pharmacy Relationship Code: "
+35 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+36 DO ^DIC
+37 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+38 SET BPRELCD=$PIECE(Y,U,2)
+39 KILL X,DIC,Y
+40 ;
+41 ; Person Code
+42 ;
+43 KILL DIR("?")
SET DIR(0)="FO^1:3"
SET DIR("A")="Pharmacy Person Code"
SET DIR("?")="Enter the Specific Person Code Assigned to the Patient by the Payer"
+44 SET DIR("B")=BPPSNCD
+45 DO ^DIR
+46 IF $DATA(DTOUT)!$DATA(DUOUT)
SET BPQ=-1
GOTO XPROMPTS
+47 SET BPPSNCD=Y
+48 ;
+49 ; Pre-Authorization
+50 ;
+51 KILL DIR("?")
SET DIR(0)="FO^1:11"
SET DIR("A")="Prior Authorization Number"
SET DIR("?")="Enter the Number Submitted by the Provider to Identify the Prior Authorization"
+52 SET DIR("B")=BPPREAUT
+53 DO ^DIR
+54 IF $DATA(DTOUT)!$DATA(DUOUT)
SET BPQ=-1
GOTO XPROMPTS
+55 SET BPPREAUT=Y
+56 ;
+57 ; Prior-Authorization Type Code
+58 ;
+59 NEW X,DIC,Y
+60 SET DIC("B")=+BPPRETYP
+61 SET DIC(0)="QEAM"
SET DIC=9002313.26
SET DIC("A")="Prior Authorization Type Code: "
+62 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+63 DO ^DIC
+64 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+65 SET BPPRETYP=$PIECE(Y,U,2)
+66 KILL X,DIC,Y
+67 ;
+68 ; If there is a pending reject on the Pharmacists Worklist, or there
+69 ; is a resolved or unresolved reject 79 or 88 or 943, then only display
+70 ; Submission Clarification Codes and do not allow enter/edit.
+71 ;
+72 IF $$BPSKIP(BPRXIEN,BPRXR)
Begin DoDot:1
+73 FOR BP35401=1:1:3
IF @("BPCLCD"_BP35401)
Begin DoDot:2
+74 SET BPSX=+@("BPCLCD"_BP35401)
+75 WRITE !,"Submission Clarification Code ",BP35401,": ",BPSX
+76 SET BPCLCDX=$ORDER(^BPS(9002313.25,"B",BPSX,""))
SET BPCLCDN=$PIECE(^BPS(9002313.25,BPCLCDX,0),U,2)
+77 WRITE ?44,BPCLCDN
+78 QUIT
End DoDot:2
+79 WRITE !," **OPECC cannot edit Sub. Clar. Code field for this reject - refer to Pharmacist"
+80 QUIT
End DoDot:1
GOTO P1
+81 ;
+82 ; Submission Clarification Code 1
+83 ;
+84 SET DIC("B")=BPCLCD1
+85 SET DIC(0)="QEAM"
SET DIC=9002313.25
SET DIC("A")="Submission Clarification Code 1: "
+86 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+87 DO ^DIC
+88 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+89 SET BPCLCD1=$PIECE(Y,U,2)
+90 KILL X,DIC,Y
+91 ;
+92 ; Submission Clarification Code 2
+93 ;
+94 IF +BPCLCD2
SET BPCLCD2=+BPCLCD2
SET DIC("B")=BPCLCD2
+95 SET DIC(0)="QEAM"
SET DIC=9002313.25
SET DIC("A")="Submission Clarification Code 2: "
SET DUP=0
+96 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+97 FOR
Begin DoDot:1
+98 DO ^DIC
+99 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
QUIT
+100 SET BPCLCD2=$PIECE(Y,U,2)
+101 SET DUP=0
IF BPCLCD2=BPCLCD1
SET BPCLCD2=""
WRITE !," Duplicates not allowed"
SET DUP=1
End DoDot:1
if BPQ=-1
QUIT
if 'DUP
QUIT
+102 KILL X,DIC,Y
+103 IF BPQ=-1
GOTO XPROMPTS
+104 ;
+105 ; Submission Clarification Code 3
+106 ;
+107 IF BPCLCD2'=""
Begin DoDot:1
+108 IF +BPCLCD3
SET BPCLCD3=+BPCLCD3
SET DIC("B")=BPCLCD3
+109 SET DIC(0)="QEAM"
SET DIC=9002313.25
SET DIC("A")="Submission Clarification Code 3: "
SET DUP=0
+110 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+111 FOR
Begin DoDot:2
+112 DO ^DIC
+113 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
QUIT
+114 SET BPCLCD3=$PIECE(Y,U,2)
+115 SET DUP=0
IF BPCLCD3=BPCLCD1!(BPCLCD3=BPCLCD2)
SET BPCLCD3=""
WRITE !," Duplicates not allowed"
SET DUP=1
End DoDot:2
if 'DUP
QUIT
IF BPQ=-1
QUIT
+116 KILL X,DIC,Y
End DoDot:1
IF BPQ=-1
GOTO XPROMPTS
+117 ;
P1 ;
+1 ;
+2 ; If the user opts to use the Date of Service instead of the
+3 ; Release Date, then set BPADDLTXT, which will be used when creating
+4 ; an entry in the Activity Log.
+5 ;
+6 SET BPADDLTXT=""
+7 SET BPRELEASEDT=$$RELDATE^BPSBCKJ(+BPRXIEN,+BPRXR)
+8 IF BPRELEASEDT]""
Begin DoDot:1
+9 SET BPDOSDT=$$EDITDT^BPSRES1(1,BPRXIEN,BPRXR,BP02)
+10 IF BPDOSDT="^"
SET BPQ=-1
QUIT
+11 IF BPDOSDT'=(BPRELEASEDT\1)
SET $PIECE(BPADDLTXT,"^")="Date of Service ("_$$FMTE^XLFDT(BPDOSDT,5)_")"
+12 QUIT
End DoDot:1
IF BPQ=-1
GOTO XPROMPTS
+13 ;
+14 ; Patient Residence Code
+15 ;
+16 NEW X,DIC,Y
+17 SET DIC("B")=+BPPTRES
+18 SET DIC(0)="QEAM"
SET DIC=9002313.27
SET DIC("A")="Patient Residence Code: "
+19 DO ^DIC
+20 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+21 SET BPPTRES=$PIECE(Y,U,2)
+22 KILL X,DIC,Y
+23 ;
+24 ; Pharmacy Service Type Code
+25 ;
+26 NEW X,DIC,Y
+27 SET DIC("B")=+BPPHSRV
+28 SET DIC(0)="QEAM"
SET DIC=9002313.28
SET DIC("A")="Pharmacy Service Type Code: "
+29 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+30 DO ^DIC
+31 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+32 SET BPPHSRV=$PIECE(Y,U,2)
+33 KILL X,DIC,Y
+34 ;
+35 ; Delay Reason Code
+36 ;
+37 NEW X,DIC,Y
+38 SET DIC("B")=BPDLYRS
+39 SET DIC(0)="QEAM"
SET DIC=9002313.29
SET DIC("A")="Delay Reason Code: "
+40 SET DIC("S")="I $P($G(^(0)),""^"",3)'=1"
+41 DO ^DIC
+42 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+43 SET BPDLYRS=$PIECE(Y,U,2)
+44 KILL X,DIC,Y
+45 ;
+46 ; Patient Gender Code, 305-C5
+47 ; Limit valid entries to the values in the fields SEX and SELF
+48 ; IDENTIFIED GENDER (if populated), then determine the Patient
+49 ; Gender Code based on the value selected.
+50 ;
+51 SET BPGENDER=""
+52 SET BPDFN=$$GET1^DIQ(9002313.59,BP59,5,"I")
+53 IF BPDFN'=""
Begin DoDot:1
+54 NEW X,DIR,Y
+55 SET BPSEX=$$GET1^DIQ(2,BPDFN,.02,"I")
+56 SET BPSEX=BPSEX_":"_$SELECT(BPSEX="M":"Male",BPSEX="F":"Female",1:"")_" (Birth Sex)"
+57 SET BPSIG=$$GET1^DIQ(2,BPDFN,.024,"I")_":"_$$GET1^DIQ(2,BPDFN,.024,"E")_" (Self-Identified Gender)"
+58 SET DIR("B")=$PIECE(BPSIG,":",2)
+59 SET DIR(0)="SA^"_BPSEX_";"_BPSIG
+60 IF $PIECE(BPSIG,":",1)=""
SET DIR("B")=$PIECE(BPSEX,":",2)
SET $PIECE(DIR(0),"^",2)=BPSEX
+61 SET DIR("A")="Patient Gender Code: "
+62 SET DIR("?")="Available Gender Codes are determined by the VistA Patient file."
+63 ;
+64 DO ^DIR
+65 ;
+66 IF $DATA(DUOUT)!$DATA(DTOUT)
SET BPQ=-1
QUIT
+67 SET BPGENDER=$SELECT(Y="M":1,Y="F":2,Y="N":0,1:3)
+68 QUIT
End DoDot:1
IF BPQ=-1
GOTO XPROMPTS
+69 ;
+70 ; Diagnosis Code, 424-DO
+71 ; Default Diagnosis Code from BPS CLAIMS file, field 424
+72 ; Only ICD-10-CM codes are allowed for selection
+73 ;
+74 SET BPDIAGNOSIS=""
+75 NEW DIR,X,Y
+76 SET DIR(0)="PO^80:AEQMZ"
+77 SET DFLTDX=$PIECE($EXTRACT($$GET1^DIQ(9002313.0201,1_","_BP02_",",424),3,17)," ")
+78 IF $GET(DFLTDX)'=""
SET DFLTDX=$EXTRACT(DFLTDX,1,3)_"."_$EXTRACT(DFLTDX,4,10)
+79 SET DIR("B")=DFLTDX
+80 SET DIR("S")="I $P($G(^ICDS($P(^(1),""^"",1),0)),""^"",1)=""ICD-10-CM"""
+81 DO ^DIR
+82 IF ($DATA(DUOUT))!($DATA(DTOUT))
SET BPQ=-1
GOTO XPROMPTS
+83 SET BPDIAGNOSIS=$PIECE(Y,U,2)
+84 IF $DATA(DIRUT)
IF X="@"
Begin DoDot:1
+85 KILL DIR,DIRUT,X,Y
+86 IF DFLTDX=""
SET BPDIAGNOSIS=""
QUIT
+87 SET DIR(0)="Y^E"
+88 SET DIR("A")=" Are you sure you want to delete "_DFLTDX
+89 SET DIR("B")="No"
+90 SET BPDIAGNOSIS=DFLTDX
+91 DO ^DIR
+92 IF Y
SET BPDIAGNOSIS="REMOVED"
End DoDot:1
IF $DATA(DIRUT)
SET BPQ=-1
GOTO XPROMPTS
+93 ;
+94 IF BPDIAGNOSIS'=""
Begin DoDot:1
+95 IF BPDIAGNOSIS="REMOVED"
SET $PIECE(BPADDLTXT,"^",2)="Diagnosis Code (Removed)"
+96 IF '$TEST
SET $PIECE(BPADDLTXT,"^",2)="Diagnosis Code ("_BPDIAGNOSIS_")"
End DoDot:1
+97 ;
+98 ; If secondary claim, setup secondary data and allow user to edit.
+99 ;
+100 IF BPCOB=2
Begin DoDot:1
+101 NEW BPSPL59,BPRTTP59
+102 ;
+103 ; Get data from the primary claim, if it exists.
+104 ; If the primary claim data is missing, get data from the
+105 ; most recent secondary claim
+106 ;
+107 SET BPRET=$$PRIMDATA^BPSPRRX6(BPRXIEN,BPRXR,.BPSECOND)
+108 IF 'BPRET
IF $$SECDATA^BPSPRRX6(BPRXIEN,BPRXR,.BPSPL59,.BPSECOND,.BPRTTP59)
+109 ;
+110 ; The PRIMARY BILL element is set by $$SECDATA. If SECDATA is not
+111 ; called, this element will be missing and we will need to create it.
+112 ;
+113 IF '$DATA(BPSECOND("PRIMARY BILL"))
Begin DoDot:2
+114 NEW BPBILL
+115 SET BPBILL=$$PAYBLPRI^BPSUTIL2(BP59)
+116 IF BPBILL>0
SET BPSECOND("PRIMARY BILL")=BPBILL
End DoDot:2
+117 ;
+118 ; Set flag telling BPSNCPDP not to recompile the data from the BPS
+119 ; Transaction and the secondary claim.
+120 ;
+121 SET BPSECOND("NEW COB DATA")=1
+122 ;
+123 ; $$PROMPTS displays the data and allows the user to edit the data.
+124 ;
+125 SET BPQ=$$PROMPTS^BPSPRRX3(BPRXIEN,BPRXR,BPDOSDT,.BPSECOND)
End DoDot:1
IF BPQ=-1
GOTO XPROMPTS
+126 ;
+127 ; Allow user to add to the claim additional fields which are
+128 ; not on the payer sheet. $$ADDLFLDS will return 0 if no
+129 ; additional fields were selected or -1 if the user exited out.
+130 ;
+131 SET BPQ=$$ADDLFLDS^BPSRES1(BP02,BP59,.BPSADDLFLDS)
+132 IF BPQ=-1
GOTO XPROMPTS
+133 ;
+134 ; Ask to proceed
+135 ;
+136 WRITE !
+137 SET BPQ=$$YESNO^BPSSCRRS("Are you sure(Y/N)")
+138 IF BPQ'=1
SET BPQ=-1
GOTO XPROMPTS
+139 SET BPQ=1
+140 ;
+141 ; Save the override values and the list of additional fields
+142 ; in file# 9002313.511, BPS NCPDP OVERRIDES.
+143 ;
+144 IF '$$SAVE^BPSRES1("RED",BP59,.BPSADDLFLDS,.BPOVRIEN)
SET BPQ=-1
+145 ;
XPROMPTS ;
+1 SET BPOVRIEN=$SELECT(BPQ=-1:BPQ,$GET(BPOVRIEN(1))]"":BPOVRIEN(1),1:-1)
+2 QUIT BPOVRIEN
+3 ;
BPSKIP(BPSRX,BPSFILL) ; Determine whether to skip the enter/edit of Submission Clarification Codes
+1 ; This function will return a '1' if the enter/edit of Submission
+2 ; Clarification Codes should be skipped (not allowed).
+3 ;
+4 NEW BPS7988DATE,BPSACTIVITY,BPSECMEDATE,BPSREJECT,BPSX
+5 ;
+6 ; If any open/unresolved rejects are on the pharmacist worklist, Quit with 1.
+7 ;
+8 IF $$FIND^PSOREJUT(BPSRX,BPSFILL)
QUIT 1
+9 ;
+10 ; If there are any closed/resolved 79/88/943 rejects for this Rx/Fill,
+11 ; pull the latest detected date/time.
+12 ; If there has not been any ECME activity since that date/time, then
+13 ; disallow the edit of Submission Clarification Codes, Quit with 1.
+14 ;
+15 SET BPS7988DATE=0
+16 ;
+17 ; Loop through the REJECTS multiple.
+18 ;
+19 SET BPSREJECT=0
+20 FOR
SET BPSREJECT=$ORDER(^PSRX(BPSRX,"REJ",BPSREJECT))
if 'BPSREJECT
QUIT
Begin DoDot:1
+21 ;
+22 ; If a reject is not for the current fill, skip this one.
+23 IF $$GET1^DIQ(52.25,BPSREJECT_","_BPSRX,5)'=BPSFILL
QUIT
+24 ;
+25 ; If not a 79 or 88 or 943, skip this one.
+26 IF ",79,88,943,"'[(","_$$GET1^DIQ(52.25,BPSREJECT_","_BPSRX,.01)_",")
QUIT
+27 ;
+28 ; Pull DATE/TIME DETECTED. If the date/time is later than
+29 ; BPS7988DATE, then reset BPS7988DATE to that date/time.
+30 SET BPSX=$$GET1^DIQ(52.25,BPSREJECT_","_BPSRX,1,"I")
+31 IF BPSX>BPS7988DATE
SET BPS7988DATE=BPSX
+32 QUIT
End DoDot:1
+33 ;
+34 ; If <blank> then Quit with 0.
+35 ;
+36 IF BPS7988DATE=0
QUIT 0
+37 ;
+38 ; Once we have the most recent DATE/TIME DETECTED, determine whether
+39 ; there is ECME activity later than that.
+40 ;
+41 ; Loop through entries the ACTIVITY LOG multiple.
+42 ;
+43 SET (BPSX,BPSACTIVITY,BPSECMEDATE)=0
+44 FOR
SET BPSACTIVITY=$ORDER(^PSRX(BPSRX,"A",BPSACTIVITY))
if 'BPSACTIVITY
QUIT
Begin DoDot:1
+45 ;
+46 ; If the REASON is not "M" (=ECME), skip.
+47 IF $$GET1^DIQ(52.3,BPSACTIVITY_","_BPSRX,.02,"I")'="M"
QUIT
+48 ;
+49 ; Pull the date/time stamp from the activity log entry. If later
+50 ; than what we found so far, update BPSECMEDATE.
+51 SET BPSX=$$GET1^DIQ(52.3,BPSACTIVITY_","_BPSRX,.01,"I")
+52 IF BPSX>BPSECMEDATE
SET BPSECMEDATE=BPSX
+53 QUIT
End DoDot:1
+54 ;
+55 ; If the BPSECMEDATE is later than BPS7988DATE, then Quit with 0
+56 ; to allow the edit of Submission Clarification Codes. Otherwise,
+57 ; Quit with 1 to skip, not allow, the enter/edit of those codes.
+58 ; When a claim is rejected, the time stamp on the Activity Log may
+59 ; be a second or two later than the time stamp on the Reject.
+60 ; Therefore, we add 60 seconds to the time stamp on the reject when
+61 ; making this comparison.
+62 ;
+63 IF BPSECMEDATE>(BPS7988DATE+.00006)
QUIT 0
+64 QUIT 1
+65 ;
