BPSSCRRJ ;ALB/ESG - ECME OPECC Reject Information ;02-SEP-2015
;;1.0;E CLAIMS MGMT ENGINE;**20,22,33,37**;JUN 2004;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $$RXSITE^PSOBPSUT in ICR #4701
; Reference to $$GETNDC^PSONDCUT in ICR #4705
; Reference to DP^PSORXVW in ICR #4711
; Reference to REJCOM^PSOREJU4 in ICR #6227
; Reference to MP^PSOREJU4 and PI^PSOREJU4 in ICR #6228
; Reference to $$TAXID^IBCEF75 in ICR #6768
;
Q
;
EN ; -- main entry point for BPS OPECC REJECT INFORMATION
N BPSEL,DFN,PSODFN,BPINSIEN,BPORI59,RXREF,RXIEN,RXFIL,LINE,VALMHDR,RX,FILL
W "OPECC Reject Information"
D FULL^VALM1
S BPSEL=$$ASKLINE^BPSSCRU4("Select item","C","Please select a single Rx line.")
I BPSEL<1 G ENX
S (DFN,PSODFN)=+$P(BPSEL,U,2) ; patient DFN
S BPINSIEN=+$P(BPSEL,U,3) ; insurance ien
S BPORI59=$P(BPSEL,U,4) I 'BPORI59 G ENX ; BPS Transaction ien
S RXREF=$$RXREF^BPSSCRU2(BPORI59)
S RXIEN=$P(RXREF,U,1) I 'RXIEN G ENX ; prescription ien
S RXFIL=$P(RXREF,U,2) ; fill#
;
; the claim must either be rejected or non-billable to be eligible for this action
I '$$REJECTED^BPSSCR02(BPORI59),'$$NB^BPSSCR03(BPORI59) D G ENX
. W !!,"This claim is not a valid selection for the OPECC Reject Information screen."
. W !,"This screen is for either rejected claims or non-billable claims."
. D PAUSE^VALM1
. Q
;
D EN^VALM("BPS OPECC REJECT INFORMATION")
ENX ;
S VALMBCK="R"
Q
;
;
INIT ; -- init variables and list array
;
K ^TMP("BPSSCRRJ",$J),^TMP("PSOPI",$J)
S LINE=0,VALMCNT=0
S (DFN,PSODFN)=+$P($G(^BPST(BPORI59,0)),U,6)
;
D REJ ; main reject information
D BPSCOM ; ecme opecc comments
D PSOCOM ; pso pharmacist comments
D INS ; insurance information
;
INITX ;
Q
;
REJ ; main reject information data capture and display
;
N BBTXT,RXCOB,ELIG,STATUS,RESPIEN,BPPOS,BPRJ,BPN,RSPREC,Z,DG,CODE,DESC,BPSNAF,BPPMSG,BPARR,PREFIX,TXTLN,BPADDMSG,PAMSG,TX
S BBTXT=""
S RXCOB=+$P($G(^BPST(BPORI59,0)),U,14) I 'RXCOB S RXCOB=1
I $$BBILL^BPSBUTL(RXIEN,RXFIL,RXCOB) S BBTXT=" BACK-BILL"
E I $$RESUBMIT^BPSBUTL(RXIEN,RXFIL,RXCOB) S BBTXT=" RESUBMISSION"
S ELIG=$P($G(^BPST(BPORI59,9)),U,4)
S ELIG=$S(ELIG="C":"CHAMPVA",ELIG="T":"TRICARE",1:"Veteran")
D SETLN("REJECT Information ("_ELIG_") "_BBTXT,1,1)
;
; for non-billable entries display some custom information and get out
; most of this section will not work for non-billables because there is no ECME claim or response
I $$NB^BPSSCR03(BPORI59) D G REJX
. D SETLN("Current ECME Status: N/A for Non-Billable Entry")
. D SETLN($$EREJTXT^BPSSCR03(BPORI59))
. Q
;
; the rest of this procedure is for a normal rejected claim/response
;
S STATUS=$P($$STATUS^BPSOSRX(RXIEN,RXFIL,,,RXCOB),U,1)
D SETLN("Current ECME Status: "_STATUS)
;
I '$$GRESPPOS^BPSSCRU3(BPORI59,.RESPIEN,.BPPOS) D G INITX
. D SETLN("No ECME Response information can be found.")
. Q
;
I '$G(RESPIEN) D G INITX
. D SETLN("SYSTEM ERROR: No ECME Response information can be found.")
. Q
;
; get the number of rejects on file and the reject codes/descriptions
K BPRJ S BPN=0
D GETRJCOD^BPSSCRU3(BPORI59,.BPRJ,.BPN,74,"")
I BPN D ; if there are rejects
. S RSPREC=$P($G(^BPSR(RESPIEN,0)),U,2) ; date/time response received
. D SETLN("Reject"_$S(BPN>1:"s",1:"")_" received from Payer on "_$$FMTE^XLFDT(RSPREC,"5ZPS")_"."),SETLN(" ")
. D SETLN(" Code Description")
. S Z=0 F S Z=$O(BPRJ(Z)) Q:'Z D
.. S DG=$G(BPRJ(Z)),CODE=$P(DG,":",1),DESC=$P(DG,":",2,99)
.. D SETLN($J(CODE,5)_" - "_DESC)
.. Q
. D SETLN(" ")
. Q
I 'BPN D SETLN("No Reject Information was found."),SETLN(" ")
;
; get and display next available fill date from the response file
S BPSNAF=$$NFLDT^BPSBUTL(RXIEN,RXFIL,RXCOB)
I BPSNAF'="" D SETLN("Next Avail Fill: "_$$FMTE^XLFDT(BPSNAF,"5DZ"))
;
; get and display payer message (504-F4)
S BPPMSG=$$MESSAGE^BPSSCRLG(RESPIEN) ; payer message (504-F4)
D WRAPTXT(BPPMSG,62,.BPARR)
S BPN=0 F S BPN=$O(BPARR(BPN)) Q:'BPN D
. S PREFIX=$S(BPN=1:"Payer Message :",1:"")
. S TXTLN=$$LJ^XLFSTR(PREFIX,17)_$G(BPARR(BPN,0))
. D SETLN(TXTLN)
. Q
;
; get and display payer additional message (526-FQ)
K BPADDMSG
D ADDMESS^BPSSCRLG(RESPIEN,1,.BPADDMSG)
S PAMSG=""
S BPN=0 F S BPN=$O(BPADDMSG(BPN)) Q:'BPN S TX=$G(BPADDMSG(BPN)),PAMSG=$S(PAMSG="":TX,1:PAMSG_" "_TX)
D WRAPTXT(PAMSG,62,.BPARR)
S BPN=0 F S BPN=$O(BPARR(BPN)) Q:'BPN D
. S PREFIX=$S(BPN=1:"Payer Addl Msg :",1:"")
. S TXTLN=$$LJ^XLFSTR(PREFIX,17)_$G(BPARR(BPN,0))
. D SETLN(TXTLN)
. Q
;
REJX ;
D SETLN(" "),SETLN(" ")
Q
;
BPSCOM ; display full opecc comments here
N CMTDT,ZN,CDAT,CDATE,CUSER,RXFLG,TXT,CTXT,L,TXTLN
D SETLN("OPECC COMMENTS",1,1)
;
I '$O(^BPST(BPORI59,11,0)) D SETLN(" There are no comments found for this section.") G BPSCOMX
;
S CMTDT=" " F S CMTDT=$O(^BPST(BPORI59,11,"B",CMTDT),-1) Q:'CMTDT S ZN=" " F S ZN=$O(^BPST(BPORI59,11,"B",CMTDT,ZN),-1) Q:'ZN D
. S CDAT=$G(^BPST(BPORI59,11,ZN,0))
. S CDATE=$$FMTE^XLFDT(CMTDT,"2ZMP") ; external date/time of comment
. S CUSER=$P($G(^VA(200,+$P(CDAT,U,2),0)),U,1) ; user name who entered comment
. S RXFLG=$S($P(CDAT,U,4):" (Pharm)",1:"") ; flag that says if opecc comment should be displayed on PSO RI screen
. S TXT=CDATE_RXFLG_" - "_$P(CDAT,U,3)_" ("_CUSER_")"
. D WRAPTXT(TXT,76,.CTXT)
. S L=0 F S L=$O(CTXT(L)) Q:'L D
.. S TXTLN=$S(L=1:"- ",1:" ")_$G(CTXT(L,0))
.. D SETLN(TXTLN)
.. Q
. Q
;
BPSCOMX ;
D SETLN(" "),SETLN(" ")
Q
;
PSOCOM ; display the PSO comments from the pharmacist
N RXCOB,COM,REJ,NUMREJ,REJIEN,REJDESC,COMDT,Z1,CDAT,CDATE,CUSER,TXT,CTXT,L,TXTLN
;
S RXCOB=+$P($G(^BPST(BPORI59,0)),U,14) I 'RXCOB S RXCOB=1
D REJCOM^PSOREJU4(RXIEN,RXFIL,RXCOB,.COM) ; build the PSO comments array for this Rx/fill/cob (ICR# 6227)
;
D SETLN("PHARMACIST COMMENTS",1,1)
;
S REJ="" F NUMREJ=0:1 S REJ=$O(COM(REJ)) Q:REJ="" ; count the number of reject codes that have PSO comments
I 'NUMREJ D SETLN(" There are no comments found for this section.") G PSOCOMX
;
S REJ="" F S REJ=$O(COM(REJ)) Q:REJ="" D
. ;
. ; if there are 2 or more reject codes that have comments, then display the reject code/description here
. I NUMREJ>1 D
.. S REJIEN=+$O(^BPSF(9002313.93,"B",REJ,""),-1) ; reject code internal IEN
.. S REJDESC=$P($G(^BPSF(9002313.93,REJIEN,0)),U,2) ; reject description
.. D SETLN(REJ_" - "_REJDESC)
.. Q
. ;
. S COMDT=" " F S COMDT=$O(COM(REJ,COMDT),-1) Q:'COMDT S Z1=" " F S Z1=$O(COM(REJ,COMDT,Z1),-1) Q:'Z1 D
.. S CDAT=$G(COM(REJ,COMDT,Z1))
.. S CDATE=$$FMTE^XLFDT($P(CDAT,U,1),"2ZMP")
.. S CUSER=$P($G(^VA(200,+$P(CDAT,U,2),0)),U,1)
.. S TXT=CDATE_" - "_$P(CDAT,U,3)_" ("_CUSER_")"
.. D WRAPTXT(TXT,76,.CTXT)
.. S L=0 F S L=$O(CTXT(L)) Q:'L D
... S TXTLN=$S(L=1:"- ",1:" ")_$G(CTXT(L,0))
... D SETLN(TXTLN)
... Q
.. Q
. ;
. ; if there are more reject codes, display a blank line here before the next reject code
. I $O(COM(REJ))'="" D SETLN(" ")
. Q
;
PSOCOMX ;
D SETLN(" "),SETLN(" ")
Q
;
INS ; gather and show insurance information
N BPSINS,IENS,INSNAME,RXCOB,BPSPOL,BPSEFDT
S BPSINS=+$$GET1^DIQ(9002313.59,BPORI59,901,"I") I 'BPSINS S BPSINS=1
S IENS=BPSINS_","_BPORI59_","
S RXCOB=+$P($G(^BPST(BPORI59,0)),U,14) I 'RXCOB S RXCOB=1
;
S INSNAME=$$LJ^XLFSTR($$GET1^DIQ(9002313.59902,IENS,902.24),32)
I RXCOB=2 S INSNAME=INSNAME_"Coord. Of Benefits: SECONDARY"
S BPSPOL=+$$GET1^DIQ(9002313.59902,IENS,902.35,"I") ; pt insurance 2.312 subfile ien
S BPSEFDT=$S(BPSPOL:+$P($G(^DPT(DFN,.312,BPSPOL,0)),U,8)\1,1:"") ; policy effective date
I BPSEFDT S BPSEFDT=$$FMTE^XLFDT(BPSEFDT,"5DZ") ; external policy effective date
;
D SETLN("INSURANCE Information",1,1)
D SETLN("Insurance : "_INSNAME)
D SETLN("Contact : "_$$GET1^DIQ(9002313.59902,IENS,902.26))
D SETLN("BIN : "_$$GET1^DIQ(9002313.59902,IENS,902.03))
D SETLN("PCN : "_$$GET1^DIQ(9002313.59902,IENS,902.04))
D SETLN("Group Number : "_$$GET1^DIQ(9002313.59902,IENS,902.05))
D SETLN("Cardholder ID : "_$$GET1^DIQ(9002313.59902,IENS,902.06))
D SETLN("Effective Date : "_BPSEFDT)
;
INSX ;
D SETLN(" "),SETLN(" ")
Q
;
WRAPTXT(X,DIWR,RET) ; wrap text in variable X with right margin DIWR, return in array RET
N %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,DN,I,Z
K ^UTILITY($J,"W"),RET
S DIWL=1
D ^DIWP
M RET=^UTILITY($J,"W",1)
K ^UTILITY($J,"W")
WRAPX ;
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BPSSCRRJ",$J),^TMP("PSOPI",$J)
Q
;
SETLN(TEXT,REV,UND,HIG) ; set a line into the ListMan array
I $G(TEXT)="" S TEXT=" "
I $L(TEXT)>80 S TEXT=$E(TEXT,1,80)
S LINE=LINE+1
D SET^VALM10(LINE,TEXT)
S VALMCNT=LINE
;
I $G(REV) D G SETLNX
. D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM)
. I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM)
. Q
;
I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
;
I $G(HIG) D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM)
;
SETLNX ;
Q
;
HDR ; -- header code
N PTINFO
S VALMHDR(1)=$$DVINFO(RXIEN,RXFIL) ; division, npi, ncpdp data
S PTINFO=$$PTINFO(RXIEN)
S VALMHDR(2)=$P(PTINFO,U,1) ; Patient data
S VALMHDR(3)=$P(PTINFO,U,2) ; Patient sex
S VALMHDR(4)=$$RXINFO1(RXIEN,RXFIL) ; Rx data part 1
S VALMHDR(5)=$$RXINFO2(RXIEN,RXFIL) ; Rx data part 2
Q
;
DVINFO(RX,RFL) ; header division data
;Input: (r) RX - Rx IEN (#52)
; (o) RFL - Refill #
N BPSTAXID,DVIEN,DVINFO,NCPNPI
S DVINFO="Division : "_$E($$GET1^DIQ(9002313.59,BPORI59,11),1,15) ; Pharmacy Division name from BPS Transaction
;Display both NPI and NCPDP numbers
S DVIEN=+$$RXSITE^PSOBPSUT(RX,RFL) ; ICR# 4701
;
; Check for Controlled Substance Drug and if a BPS Pharmacy for CS has
; been defined. If so, use NCPDP# & NPI for the CS Pharmacy.
S NCPNPI=$$CSNPI^BPSUTIL(RX,RFL)
;
; If not a Controlled Substance, use NCDPD# & NPI info based on Division.
I +NCPNPI=-1 S NCPNPI=$$DIVNCPDP^BPSBUTL(DVIEN)
S $E(DVINFO,28)="NPI: "_$P(NCPNPI,U,2)
S $E(DVINFO,44)="NCPDP: "_$P(NCPNPI,U,1)
S BPSTAXID=$P($$TAXID^IBCEF75,U,2) ; ICR# 6768
S $E(DVINFO,62)="TAX ID: "_$E(BPSTAXID,1,2)_"-"_$E(BPSTAXID,3,$L(BPSTAXID))
Q DVINFO
;
PTINFO(RX) ; header patient data
;Input: (r) RX - Rx IEN (#52)
N DFN,PTINFO,SEX,SSN4,VADM
S DFN=+$P($G(^BPST(BPORI59,0)),U,6)
D DEM^VADPT S SSN4=$P($G(VADM(2)),U,2)
S PTINFO="Patient : "_$E($G(VADM(1)),1,24)_"("_$E(SSN4,$L(SSN4)-3,$L(SSN4))_")"
S $E(PTINFO,61)="DOB: "_$P($G(VADM(3)),U,2)_"("_$P($G(VADM(4)),U,1)_")"
S SEX="Birth Sex: "_$P($G(VADM(5)),U,1)
S $E(SEX,32)="Self-Identified Gender: "_$E($P($G(VADM(14,5)),U,1),1,24)
Q PTINFO_U_SEX
;
RXINFO1(RX,FILL) ; header Rx data part 1
N RXINFO,RXDOS,PSOET
D GETDAT^BPSBUTL(RX,FILL,,.RXDOS) ; Get Date of Service from BPS CLAIM field 401
S RXINFO="Rx# : "_$$RXNUM^BPSSCRU2(RX)_"/"_FILL
S PSOET=$$NB^BPSSCR03(BPORI59) ; TRI/CVA non-billable entry
S $E(RXINFO,27)="ECME#: "_$S(PSOET:"",1:$P($$CLAIM^BPSBUTL(RX,FILL),U,6))
S $E(RXINFO,49)="Date of Service: "_$S(PSOET:"",1:$$FMTE^XLFDT(RXDOS)) ; Use DOS from BPS Claims field 401
Q RXINFO
;
RXINFO2(RX,FILL) ; header Rx data part 2
N RXINFO,DRG,CMOP
S DRG=+$$RXAPI1^BPSUTIL1(RX,6,"I") ; drug ien
S CMOP=$$DRUGDIE^BPSUTIL1(DRG,213,"I") ; cmop dispense field in the Drug file (0/1)
S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug"
S $E(RXINFO,10)=": "_$E($$RXAPI1^BPSUTIL1(RX,6),1,43) ; drug name
;
S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL) ; ICR# 4705
Q RXINFO
;
VER ; selection of View ePharmacy Rx from the BPS OPECC reject information screen
N BPSVRX
D FULL^VALM1
S BPSVRX("RXIEN")=$G(RXIEN)
S BPSVRX("FILL#")=$G(RXFIL)
D ^BPSVRX
VERX ;
S VALMBCK="R"
Q
;
VIEW ; action for View Rx on the BPS OPECC reject information screen
N VALMCNT,LINE,VALMHDR,TITLE,PSOVDA,DA,PS,DFN,PSODFN
S TITLE=VALM("TITLE")
S (PSOVDA,DA)=RXIEN,PS="REJECT"
;
; - DO structure used to avoid losing key variables in this routine
D
. N RXIEN,RXFIL,BPORI59,TITLE
. D DP^PSORXVW ; ICR# 4711
. Q
;
S VALMBCK="R",VALM("TITLE")=TITLE
Q
;
MP(RXIEN,RXFIL) ; entry point for Medication Profile action on OPECC reject information screen
N VALMCNT,LINE,VALMHDR,DFN,PSODFN,BPORI59
D MP^PSOREJU4(RXIEN,RXFIL) ; ICR# 6228
S VALMBCK="R"
Q
;
PI(RXIEN,RXFIL) ; entry point for Patient Information action on OPECC reject information screen
N VALMCNT,LINE,VALMHDR,DFN,PSODFN,BPORI59
D PI^PSOREJU4(RXIEN,RXFIL) ; ICR# 6228
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSSCRRJ 13090 printed Dec 13, 2024@01:53:15 Page 2
BPSSCRRJ ;ALB/ESG - ECME OPECC Reject Information ;02-SEP-2015
+1 ;;1.0;E CLAIMS MGMT ENGINE;**20,22,33,37**;JUN 2004;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $$RXSITE^PSOBPSUT in ICR #4701
+5 ; Reference to $$GETNDC^PSONDCUT in ICR #4705
+6 ; Reference to DP^PSORXVW in ICR #4711
+7 ; Reference to REJCOM^PSOREJU4 in ICR #6227
+8 ; Reference to MP^PSOREJU4 and PI^PSOREJU4 in ICR #6228
+9 ; Reference to $$TAXID^IBCEF75 in ICR #6768
+10 ;
+11 QUIT
+12 ;
EN ; -- main entry point for BPS OPECC REJECT INFORMATION
+1 NEW BPSEL,DFN,PSODFN,BPINSIEN,BPORI59,RXREF,RXIEN,RXFIL,LINE,VALMHDR,RX,FILL
+2 WRITE "OPECC Reject Information"
+3 DO FULL^VALM1
+4 SET BPSEL=$$ASKLINE^BPSSCRU4("Select item","C","Please select a single Rx line.")
+5 IF BPSEL<1
GOTO ENX
+6 ; patient DFN
SET (DFN,PSODFN)=+$PIECE(BPSEL,U,2)
+7 ; insurance ien
SET BPINSIEN=+$PIECE(BPSEL,U,3)
+8 ; BPS Transaction ien
SET BPORI59=$PIECE(BPSEL,U,4)
IF 'BPORI59
GOTO ENX
+9 SET RXREF=$$RXREF^BPSSCRU2(BPORI59)
+10 ; prescription ien
SET RXIEN=$PIECE(RXREF,U,1)
IF 'RXIEN
GOTO ENX
+11 ; fill#
SET RXFIL=$PIECE(RXREF,U,2)
+12 ;
+13 ; the claim must either be rejected or non-billable to be eligible for this action
+14 IF '$$REJECTED^BPSSCR02(BPORI59)
IF '$$NB^BPSSCR03(BPORI59)
Begin DoDot:1
+15 WRITE !!,"This claim is not a valid selection for the OPECC Reject Information screen."
+16 WRITE !,"This screen is for either rejected claims or non-billable claims."
+17 DO PAUSE^VALM1
+18 QUIT
End DoDot:1
GOTO ENX
+19 ;
+20 DO EN^VALM("BPS OPECC REJECT INFORMATION")
ENX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
+4 ;
INIT ; -- init variables and list array
+1 ;
+2 KILL ^TMP("BPSSCRRJ",$JOB),^TMP("PSOPI",$JOB)
+3 SET LINE=0
SET VALMCNT=0
+4 SET (DFN,PSODFN)=+$PIECE($GET(^BPST(BPORI59,0)),U,6)
+5 ;
+6 ; main reject information
DO REJ
+7 ; ecme opecc comments
DO BPSCOM
+8 ; pso pharmacist comments
DO PSOCOM
+9 ; insurance information
DO INS
+10 ;
INITX ;
+1 QUIT
+2 ;
REJ ; main reject information data capture and display
+1 ;
+2 NEW BBTXT,RXCOB,ELIG,STATUS,RESPIEN,BPPOS,BPRJ,BPN,RSPREC,Z,DG,CODE,DESC,BPSNAF,BPPMSG,BPARR,PREFIX,TXTLN,BPADDMSG,PAMSG,TX
+3 SET BBTXT=""
+4 SET RXCOB=+$PIECE($GET(^BPST(BPORI59,0)),U,14)
IF 'RXCOB
SET RXCOB=1
+5 IF $$BBILL^BPSBUTL(RXIEN,RXFIL,RXCOB)
SET BBTXT=" BACK-BILL"
+6 IF '$TEST
IF $$RESUBMIT^BPSBUTL(RXIEN,RXFIL,RXCOB)
SET BBTXT=" RESUBMISSION"
+7 SET ELIG=$PIECE($GET(^BPST(BPORI59,9)),U,4)
+8 SET ELIG=$SELECT(ELIG="C":"CHAMPVA",ELIG="T":"TRICARE",1:"Veteran")
+9 DO SETLN("REJECT Information ("_ELIG_") "_BBTXT,1,1)
+10 ;
+11 ; for non-billable entries display some custom information and get out
+12 ; most of this section will not work for non-billables because there is no ECME claim or response
+13 IF $$NB^BPSSCR03(BPORI59)
Begin DoDot:1
+14 DO SETLN("Current ECME Status: N/A for Non-Billable Entry")
+15 DO SETLN($$EREJTXT^BPSSCR03(BPORI59))
+16 QUIT
End DoDot:1
GOTO REJX
+17 ;
+18 ; the rest of this procedure is for a normal rejected claim/response
+19 ;
+20 SET STATUS=$PIECE($$STATUS^BPSOSRX(RXIEN,RXFIL,,,RXCOB),U,1)
+21 DO SETLN("Current ECME Status: "_STATUS)
+22 ;
+23 IF '$$GRESPPOS^BPSSCRU3(BPORI59,.RESPIEN,.BPPOS)
Begin DoDot:1
+24 DO SETLN("No ECME Response information can be found.")
+25 QUIT
End DoDot:1
GOTO INITX
+26 ;
+27 IF '$GET(RESPIEN)
Begin DoDot:1
+28 DO SETLN("SYSTEM ERROR: No ECME Response information can be found.")
+29 QUIT
End DoDot:1
GOTO INITX
+30 ;
+31 ; get the number of rejects on file and the reject codes/descriptions
+32 KILL BPRJ
SET BPN=0
+33 DO GETRJCOD^BPSSCRU3(BPORI59,.BPRJ,.BPN,74,"")
+34 ; if there are rejects
IF BPN
Begin DoDot:1
+35 ; date/time response received
SET RSPREC=$PIECE($GET(^BPSR(RESPIEN,0)),U,2)
+36 DO SETLN("Reject"_$SELECT(BPN>1:"s",1:"")_" received from Payer on "_$$FMTE^XLFDT(RSPREC,"5ZPS")_".")
DO SETLN(" ")
+37 DO SETLN(" Code Description")
+38 SET Z=0
FOR
SET Z=$ORDER(BPRJ(Z))
if 'Z
QUIT
Begin DoDot:2
+39 SET DG=$GET(BPRJ(Z))
SET CODE=$PIECE(DG,":",1)
SET DESC=$PIECE(DG,":",2,99)
+40 DO SETLN($JUSTIFY(CODE,5)_" - "_DESC)
+41 QUIT
End DoDot:2
+42 DO SETLN(" ")
+43 QUIT
End DoDot:1
+44 IF 'BPN
DO SETLN("No Reject Information was found.")
DO SETLN(" ")
+45 ;
+46 ; get and display next available fill date from the response file
+47 SET BPSNAF=$$NFLDT^BPSBUTL(RXIEN,RXFIL,RXCOB)
+48 IF BPSNAF'=""
DO SETLN("Next Avail Fill: "_$$FMTE^XLFDT(BPSNAF,"5DZ"))
+49 ;
+50 ; get and display payer message (504-F4)
+51 ; payer message (504-F4)
SET BPPMSG=$$MESSAGE^BPSSCRLG(RESPIEN)
+52 DO WRAPTXT(BPPMSG,62,.BPARR)
+53 SET BPN=0
FOR
SET BPN=$ORDER(BPARR(BPN))
if 'BPN
QUIT
Begin DoDot:1
+54 SET PREFIX=$SELECT(BPN=1:"Payer Message :",1:"")
+55 SET TXTLN=$$LJ^XLFSTR(PREFIX,17)_$GET(BPARR(BPN,0))
+56 DO SETLN(TXTLN)
+57 QUIT
End DoDot:1
+58 ;
+59 ; get and display payer additional message (526-FQ)
+60 KILL BPADDMSG
+61 DO ADDMESS^BPSSCRLG(RESPIEN,1,.BPADDMSG)
+62 SET PAMSG=""
+63 SET BPN=0
FOR
SET BPN=$ORDER(BPADDMSG(BPN))
if 'BPN
QUIT
SET TX=$GET(BPADDMSG(BPN))
SET PAMSG=$SELECT(PAMSG="":TX,1:PAMSG_" "_TX)
+64 DO WRAPTXT(PAMSG,62,.BPARR)
+65 SET BPN=0
FOR
SET BPN=$ORDER(BPARR(BPN))
if 'BPN
QUIT
Begin DoDot:1
+66 SET PREFIX=$SELECT(BPN=1:"Payer Addl Msg :",1:"")
+67 SET TXTLN=$$LJ^XLFSTR(PREFIX,17)_$GET(BPARR(BPN,0))
+68 DO SETLN(TXTLN)
+69 QUIT
End DoDot:1
+70 ;
REJX ;
+1 DO SETLN(" ")
DO SETLN(" ")
+2 QUIT
+3 ;
BPSCOM ; display full opecc comments here
+1 NEW CMTDT,ZN,CDAT,CDATE,CUSER,RXFLG,TXT,CTXT,L,TXTLN
+2 DO SETLN("OPECC COMMENTS",1,1)
+3 ;
+4 IF '$ORDER(^BPST(BPORI59,11,0))
DO SETLN(" There are no comments found for this section.")
GOTO BPSCOMX
+5 ;
+6 SET CMTDT=" "
FOR
SET CMTDT=$ORDER(^BPST(BPORI59,11,"B",CMTDT),-1)
if 'CMTDT
QUIT
SET ZN=" "
FOR
SET ZN=$ORDER(^BPST(BPORI59,11,"B",CMTDT,ZN),-1)
if 'ZN
QUIT
Begin DoDot:1
+7 SET CDAT=$GET(^BPST(BPORI59,11,ZN,0))
+8 ; external date/time of comment
SET CDATE=$$FMTE^XLFDT(CMTDT,"2ZMP")
+9 ; user name who entered comment
SET CUSER=$PIECE($GET(^VA(200,+$PIECE(CDAT,U,2),0)),U,1)
+10 ; flag that says if opecc comment should be displayed on PSO RI screen
SET RXFLG=$SELECT($PIECE(CDAT,U,4):" (Pharm)",1:"")
+11 SET TXT=CDATE_RXFLG_" - "_$PIECE(CDAT,U,3)_" ("_CUSER_")"
+12 DO WRAPTXT(TXT,76,.CTXT)
+13 SET L=0
FOR
SET L=$ORDER(CTXT(L))
if 'L
QUIT
Begin DoDot:2
+14 SET TXTLN=$SELECT(L=1:"- ",1:" ")_$GET(CTXT(L,0))
+15 DO SETLN(TXTLN)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 ;
BPSCOMX ;
+1 DO SETLN(" ")
DO SETLN(" ")
+2 QUIT
+3 ;
PSOCOM ; display the PSO comments from the pharmacist
+1 NEW RXCOB,COM,REJ,NUMREJ,REJIEN,REJDESC,COMDT,Z1,CDAT,CDATE,CUSER,TXT,CTXT,L,TXTLN
+2 ;
+3 SET RXCOB=+$PIECE($GET(^BPST(BPORI59,0)),U,14)
IF 'RXCOB
SET RXCOB=1
+4 ; build the PSO comments array for this Rx/fill/cob (ICR# 6227)
DO REJCOM^PSOREJU4(RXIEN,RXFIL,RXCOB,.COM)
+5 ;
+6 DO SETLN("PHARMACIST COMMENTS",1,1)
+7 ;
+8 ; count the number of reject codes that have PSO comments
SET REJ=""
FOR NUMREJ=0:1
SET REJ=$ORDER(COM(REJ))
if REJ=""
QUIT
+9 IF 'NUMREJ
DO SETLN(" There are no comments found for this section.")
GOTO PSOCOMX
+10 ;
+11 SET REJ=""
FOR
SET REJ=$ORDER(COM(REJ))
if REJ=""
QUIT
Begin DoDot:1
+12 ;
+13 ; if there are 2 or more reject codes that have comments, then display the reject code/description here
+14 IF NUMREJ>1
Begin DoDot:2
+15 ; reject code internal IEN
SET REJIEN=+$ORDER(^BPSF(9002313.93,"B",REJ,""),-1)
+16 ; reject description
SET REJDESC=$PIECE($GET(^BPSF(9002313.93,REJIEN,0)),U,2)
+17 DO SETLN(REJ_" - "_REJDESC)
+18 QUIT
End DoDot:2
+19 ;
+20 SET COMDT=" "
FOR
SET COMDT=$ORDER(COM(REJ,COMDT),-1)
if 'COMDT
QUIT
SET Z1=" "
FOR
SET Z1=$ORDER(COM(REJ,COMDT,Z1),-1)
if 'Z1
QUIT
Begin DoDot:2
+21 SET CDAT=$GET(COM(REJ,COMDT,Z1))
+22 SET CDATE=$$FMTE^XLFDT($PIECE(CDAT,U,1),"2ZMP")
+23 SET CUSER=$PIECE($GET(^VA(200,+$PIECE(CDAT,U,2),0)),U,1)
+24 SET TXT=CDATE_" - "_$PIECE(CDAT,U,3)_" ("_CUSER_")"
+25 DO WRAPTXT(TXT,76,.CTXT)
+26 SET L=0
FOR
SET L=$ORDER(CTXT(L))
if 'L
QUIT
Begin DoDot:3
+27 SET TXTLN=$SELECT(L=1:"- ",1:" ")_$GET(CTXT(L,0))
+28 DO SETLN(TXTLN)
+29 QUIT
End DoDot:3
+30 QUIT
End DoDot:2
+31 ;
+32 ; if there are more reject codes, display a blank line here before the next reject code
+33 IF $ORDER(COM(REJ))'=""
DO SETLN(" ")
+34 QUIT
End DoDot:1
+35 ;
PSOCOMX ;
+1 DO SETLN(" ")
DO SETLN(" ")
+2 QUIT
+3 ;
INS ; gather and show insurance information
+1 NEW BPSINS,IENS,INSNAME,RXCOB,BPSPOL,BPSEFDT
+2 SET BPSINS=+$$GET1^DIQ(9002313.59,BPORI59,901,"I")
IF 'BPSINS
SET BPSINS=1
+3 SET IENS=BPSINS_","_BPORI59_","
+4 SET RXCOB=+$PIECE($GET(^BPST(BPORI59,0)),U,14)
IF 'RXCOB
SET RXCOB=1
+5 ;
+6 SET INSNAME=$$LJ^XLFSTR($$GET1^DIQ(9002313.59902,IENS,902.24),32)
+7 IF RXCOB=2
SET INSNAME=INSNAME_"Coord. Of Benefits: SECONDARY"
+8 ; pt insurance 2.312 subfile ien
SET BPSPOL=+$$GET1^DIQ(9002313.59902,IENS,902.35,"I")
+9 ; policy effective date
SET BPSEFDT=$SELECT(BPSPOL:+$PIECE($GET(^DPT(DFN,.312,BPSPOL,0)),U,8)\1,1:"")
+10 ; external policy effective date
IF BPSEFDT
SET BPSEFDT=$$FMTE^XLFDT(BPSEFDT,"5DZ")
+11 ;
+12 DO SETLN("INSURANCE Information",1,1)
+13 DO SETLN("Insurance : "_INSNAME)
+14 DO SETLN("Contact : "_$$GET1^DIQ(9002313.59902,IENS,902.26))
+15 DO SETLN("BIN : "_$$GET1^DIQ(9002313.59902,IENS,902.03))
+16 DO SETLN("PCN : "_$$GET1^DIQ(9002313.59902,IENS,902.04))
+17 DO SETLN("Group Number : "_$$GET1^DIQ(9002313.59902,IENS,902.05))
+18 DO SETLN("Cardholder ID : "_$$GET1^DIQ(9002313.59902,IENS,902.06))
+19 DO SETLN("Effective Date : "_BPSEFDT)
+20 ;
INSX ;
+1 DO SETLN(" ")
DO SETLN(" ")
+2 QUIT
+3 ;
WRAPTXT(X,DIWR,RET) ; wrap text in variable X with right margin DIWR, return in array RET
+1 NEW %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,DN,I,Z
+2 KILL ^UTILITY($JOB,"W"),RET
+3 SET DIWL=1
+4 DO ^DIWP
+5 MERGE RET=^UTILITY($JOB,"W",1)
+6 KILL ^UTILITY($JOB,"W")
WRAPX ;
+1 QUIT
+2 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BPSSCRRJ",$JOB),^TMP("PSOPI",$JOB)
+2 QUIT
+3 ;
SETLN(TEXT,REV,UND,HIG) ; set a line into the ListMan array
+1 IF $GET(TEXT)=""
SET TEXT=" "
+2 IF $LENGTH(TEXT)>80
SET TEXT=$EXTRACT(TEXT,1,80)
+3 SET LINE=LINE+1
+4 DO SET^VALM10(LINE,TEXT)
+5 SET VALMCNT=LINE
+6 ;
+7 IF $GET(REV)
Begin DoDot:1
+8 DO CNTRL^VALM10(LINE,1,$LENGTH(TEXT),IORVON,IOINORM)
+9 IF $GET(UND)
DO CNTRL^VALM10(LINE,$LENGTH(TEXT)+1,80,IOUON,IOINORM)
+10 QUIT
End DoDot:1
GOTO SETLNX
+11 ;
+12 IF $GET(UND)
DO CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
+13 ;
+14 IF $GET(HIG)
DO CNTRL^VALM10(LINE,HIG,80,IOINHI_$SELECT($GET(UND):IOUON,1:""),IOINORM)
+15 ;
SETLNX ;
+1 QUIT
+2 ;
HDR ; -- header code
+1 NEW PTINFO
+2 ; division, npi, ncpdp data
SET VALMHDR(1)=$$DVINFO(RXIEN,RXFIL)
+3 SET PTINFO=$$PTINFO(RXIEN)
+4 ; Patient data
SET VALMHDR(2)=$PIECE(PTINFO,U,1)
+5 ; Patient sex
SET VALMHDR(3)=$PIECE(PTINFO,U,2)
+6 ; Rx data part 1
SET VALMHDR(4)=$$RXINFO1(RXIEN,RXFIL)
+7 ; Rx data part 2
SET VALMHDR(5)=$$RXINFO2(RXIEN,RXFIL)
+8 QUIT
+9 ;
DVINFO(RX,RFL) ; header division data
+1 ;Input: (r) RX - Rx IEN (#52)
+2 ; (o) RFL - Refill #
+3 NEW BPSTAXID,DVIEN,DVINFO,NCPNPI
+4 ; Pharmacy Division name from BPS Transaction
SET DVINFO="Division : "_$EXTRACT($$GET1^DIQ(9002313.59,BPORI59,11),1,15)
+5 ;Display both NPI and NCPDP numbers
+6 ; ICR# 4701
SET DVIEN=+$$RXSITE^PSOBPSUT(RX,RFL)
+7 ;
+8 ; Check for Controlled Substance Drug and if a BPS Pharmacy for CS has
+9 ; been defined. If so, use NCPDP# & NPI for the CS Pharmacy.
+10 SET NCPNPI=$$CSNPI^BPSUTIL(RX,RFL)
+11 ;
+12 ; If not a Controlled Substance, use NCDPD# & NPI info based on Division.
+13 IF +NCPNPI=-1
SET NCPNPI=$$DIVNCPDP^BPSBUTL(DVIEN)
+14 SET $EXTRACT(DVINFO,28)="NPI: "_$PIECE(NCPNPI,U,2)
+15 SET $EXTRACT(DVINFO,44)="NCPDP: "_$PIECE(NCPNPI,U,1)
+16 ; ICR# 6768
SET BPSTAXID=$PIECE($$TAXID^IBCEF75,U,2)
+17 SET $EXTRACT(DVINFO,62)="TAX ID: "_$EXTRACT(BPSTAXID,1,2)_"-"_$EXTRACT(BPSTAXID,3,$LENGTH(BPSTAXID))
+18 QUIT DVINFO
+19 ;
PTINFO(RX) ; header patient data
+1 ;Input: (r) RX - Rx IEN (#52)
+2 NEW DFN,PTINFO,SEX,SSN4,VADM
+3 SET DFN=+$PIECE($GET(^BPST(BPORI59,0)),U,6)
+4 DO DEM^VADPT
SET SSN4=$PIECE($GET(VADM(2)),U,2)
+5 SET PTINFO="Patient : "_$EXTRACT($GET(VADM(1)),1,24)_"("_$EXTRACT(SSN4,$LENGTH(SSN4)-3,$LENGTH(SSN4))_")"
+6 SET $EXTRACT(PTINFO,61)="DOB: "_$PIECE($GET(VADM(3)),U,2)_"("_$PIECE($GET(VADM(4)),U,1)_")"
+7 SET SEX="Birth Sex: "_$PIECE($GET(VADM(5)),U,1)
+8 SET $EXTRACT(SEX,32)="Self-Identified Gender: "_$EXTRACT($PIECE($GET(VADM(14,5)),U,1),1,24)
+9 QUIT PTINFO_U_SEX
+10 ;
RXINFO1(RX,FILL) ; header Rx data part 1
+1 NEW RXINFO,RXDOS,PSOET
+2 ; Get Date of Service from BPS CLAIM field 401
DO GETDAT^BPSBUTL(RX,FILL,,.RXDOS)
+3 SET RXINFO="Rx# : "_$$RXNUM^BPSSCRU2(RX)_"/"_FILL
+4 ; TRI/CVA non-billable entry
SET PSOET=$$NB^BPSSCR03(BPORI59)
+5 SET $EXTRACT(RXINFO,27)="ECME#: "_$SELECT(PSOET:"",1:$PIECE($$CLAIM^BPSBUTL(RX,FILL),U,6))
+6 ; Use DOS from BPS Claims field 401
SET $EXTRACT(RXINFO,49)="Date of Service: "_$SELECT(PSOET:"",1:$$FMTE^XLFDT(RXDOS))
+7 QUIT RXINFO
+8 ;
RXINFO2(RX,FILL) ; header Rx data part 2
+1 NEW RXINFO,DRG,CMOP
+2 ; drug ien
SET DRG=+$$RXAPI1^BPSUTIL1(RX,6,"I")
+3 ; cmop dispense field in the Drug file (0/1)
SET CMOP=$$DRUGDIE^BPSUTIL1(DRG,213,"I")
+4 SET RXINFO=$SELECT(CMOP:"CMOP ",1:"")_"Drug"
+5 ; drug name
SET $EXTRACT(RXINFO,10)=": "_$EXTRACT($$RXAPI1^BPSUTIL1(RX,6),1,43)
+6 ;
+7 ; ICR# 4705
SET $EXTRACT(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
+8 QUIT RXINFO
+9 ;
VER ; selection of View ePharmacy Rx from the BPS OPECC reject information screen
+1 NEW BPSVRX
+2 DO FULL^VALM1
+3 SET BPSVRX("RXIEN")=$GET(RXIEN)
+4 SET BPSVRX("FILL#")=$GET(RXFIL)
+5 DO ^BPSVRX
VERX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
VIEW ; action for View Rx on the BPS OPECC reject information screen
+1 NEW VALMCNT,LINE,VALMHDR,TITLE,PSOVDA,DA,PS,DFN,PSODFN
+2 SET TITLE=VALM("TITLE")
+3 SET (PSOVDA,DA)=RXIEN
SET PS="REJECT"
+4 ;
+5 ; - DO structure used to avoid losing key variables in this routine
+6 Begin DoDot:1
+7 NEW RXIEN,RXFIL,BPORI59,TITLE
+8 ; ICR# 4711
DO DP^PSORXVW
+9 QUIT
End DoDot:1
+10 ;
+11 SET VALMBCK="R"
SET VALM("TITLE")=TITLE
+12 QUIT
+13 ;
MP(RXIEN,RXFIL) ; entry point for Medication Profile action on OPECC reject information screen
+1 NEW VALMCNT,LINE,VALMHDR,DFN,PSODFN,BPORI59
+2 ; ICR# 6228
DO MP^PSOREJU4(RXIEN,RXFIL)
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
PI(RXIEN,RXFIL) ; entry point for Patient Information action on OPECC reject information screen
+1 NEW VALMCNT,LINE,VALMHDR,DFN,PSODFN,BPORI59
+2 ; ICR# 6228
DO PI^PSOREJU4(RXIEN,RXFIL)
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
