PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05
;;7.0;OUTPATIENT PHARMACY;**148,247,260,281,287,289,290,358,359,385,403,421,427,448,478,482,512,562,648,702,704**;DEC 1997;Build 16
; Reference to File 9002313.93 - BPS NCPDP REJECT CODES in ICR #4720
; Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE in ICR #4712
; Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE in ICR #4713
; Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE in ICR #4714
; Reference to File 9002313.25 - BPS NCPDP SUBMISSION CLARIFICATION CODE in ICR #5064
; Reference to File 9002313.26 - BPS NCPDP PRIOR AUTHORIZATION TYPE CODE in ICR #5585
; Reference to DURRESP^BPSNCPD3 in ICR #4560
; Reference to ^BPSVRX in ICR #5723
; Reference to $$BBILL^BPSBUTL,$$RESUBMIT^BPSBUTL in ICR #4719
;
;
EN(RX,REJ,CHANGE) ; Entry point
;
N FILL,LASTLN,PSOCODE,PSOTRIC
S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
S PSOTRIC=$$TRIC(RX,FILL),PSOCODE=$$GET1^DIQ(52.25,REJ_","_RX,.01)
I $$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY - RESOLVED")
I '$$CLOSED(RX,REJ)&(PSOTRIC) D EN^VALM("PSO REJECT TRICARE")
I '$$CLOSED(RX,REJ)&('PSOTRIC) D EN^VALM("PSO REJECT DISPLAY")
D FULL^VALM1
Q
;
HDR ; Builds the Header section
N LINE1,LINE2,PTINFO,X
S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1)
S PTINFO=$$PTINFO^PSOREJU2(RX,1)
S VALMHDR(2)=$P(PTINFO,U,1)
S VALMHDR(3)=$P(PTINFO,U,2)
S VALMHDR(4)=$$RXINFO^PSOREJP3(RX,FILL,1)
S VALMHDR(5)=$$RXINFO^PSOREJP3(RX,FILL,2,REJ)
Q
;
TRIC(RX,RFL,PSOTRIC) ; Return 1 for TRICARE, 2 for CHAMPVA or 0 (zero) for not TRICARE or CHAMPVA
I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
S PSOTRIC=$S(RFL=0&($$GET1^DIQ(52,RX_",",85,"I")="T"):1,$$GET1^DIQ(52.1,RFL_","_RX_",",85,"I")="T":1,RFL=0&($$GET1^DIQ(52,RX_",",85,"I")="C"):2,$$GET1^DIQ(52.1,RFL_","_RX_",",85,"I")="C":2,1:0)
Q PSOTRIC
;
ELIGDISP(RX,RFL) ; Return either CHAMPVA or TRICARE for display
; purposes, or null if neither
N PSOELIG
S PSOELIG=$$TRIC(RX,RFL)
Q $S(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",1:"")
;
ELIGTCV(RX,RFL,CAPS) ; Return either CHAMPVA, TRICARE, or Veteran/VETERAN for eligibility display
; if CAPS=1 then return "Veteran" in all caps
; Note if the requested refill has been deleted, then the message "N/A - Fill Deleted" will be returned
N PSOELIG,VET,DELMSG
S DELMSG="N/A - Fill Deleted"
S PSOELIG=$$TRIC(RX,RFL),VET="Veteran" I $G(CAPS) S VET="VETERAN"
I RFL>0,'$D(^PSRX(RX,1,RFL,0)) S PSOELIG=3
Q $S(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",PSOELIG=3:DELMSG,1:VET)
;
INIT ; Builds the Body section
N DATA,LINE
I '$D(FILL) S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5) ; PSO*7*448 obtain fill# from 52.25 subfile if not defined
I '$$CLOSED(RX,REJ) S VALM("TITLE")="Reject Information ("_$$ELIGTCV(RX,FILL)_")"
I $$CLOSED(RX,REJ) S VALM("TITLE")="Reject Information (RESOLVED)"
F I=1:1:$G(LASTLN) D RESTORE^VALM10(I)
K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0
D GET^PSOREJU2(RX,FILL,.DATA,REJ,1)
D REJ ; Display the REJECT Information
D OTH ; Display the Other Rejects Information
D COM^PSOREJP3 ; Display the Comment
D INS ; Display the Insurance Information
D CLS ; Display the Resolution Information
S VALMCNT=LINE
Q
;
REJ ; Reject Information
N PFLDT,PSOADD,PSOCOB,PSOECME,PSOET,PSONAF,PSOTXT,TREJ,TYPE
;
; Display 'RESUBMISSION' where 'BACK-BILL' currently displays if the
; claim was resubmitted from the ECME User Screen. To facilitate
; this, the function $$RESUBMIT^BPSBUTL was created.
;
S PSOTXT=""
S PSOCOB=$G(DATA(REJ,"COB")),PSOCOB=$S(PSOCOB="SECONDARY":2,PSOCOB="TERTIARY":3,1:1)
I $$BBILL^BPSBUTL(RX,FILL,PSOCOB) S PSOTXT=" BACK-BILL"
E I $$RESUBMIT^BPSBUTL(RX,FILL,PSOCOB) S PSOTXT=" RESUBMISSION" ; IA 4719.
D SETLN("REJECT Information ("_$$ELIGTCV(RX,FILL)_") "_PSOTXT,1,1)
;
S PSOECME=$$STATUS^PSOBPSUT(RX,FILL,PSOCOB)
I PSOECME="E PAYABLE" D
. D SETLN("Reject Received: ",,,18)
. D SETLN("Reject Type : ",,,18)
. D SETLN("Reject Status : ** E PAYABLE **",,,18)
. I DATA(REJ,"PAYER MESSAGE")["Not ECME Billable" S DATA(REJ,"PAYER MESSAGE")=""
. Q
E D
. I $G(DATA(REJ,"CODE"))=79 S TYPE="79 - REFILL TOO SOON"
. E S TYPE=DATA(REJ,"CODE")_" - "_$$EXP(DATA(REJ,"CODE"))
. I $L(TYPE)>62 S TYPE=$E(TYPE,1,59)_"..."
. D SETLN("Reject Received: "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME"))),,,18)
. D SETLN("Reject Type : "_TYPE,,,18)
. ; If TRICARE/CHAMPVA non-billable then reset Status line
. S PSOET=$$PSOET^PSOREJP3(RX,FILL)
. I PSOET D SETLN("Status : NO CLAIM SUBMITTED")
. I 'PSOET D SETLN("Reject Status : "_$G(DATA(REJ,"STATUS"))_" - "_PSOECME,,,18)
. Q
;
; code moved to PSOREJP5
D REJ^PSOREJP5
Q
;
OTH ; Other Rejects Information
N LST,I,RJC,J,LAST
S LST=$G(DATA(REJ,"OTHER REJECTS")) I LST="" Q
D SETLN()
D SETLN("OTHER REJECTS",1,1)
F I=1:1:$L(LST,",") S RJC=$P(LST,",",I) D
. S LAST=1 F J=(I+1):1:$L(LST,",") I $P(LST,",",J)'="" S LAST=0 Q
. I RJC'="" D SETLN(RJC_" - "_$$EXP(RJC),,$S(LAST:1,1:0),6)
Q
;
INS ; Insurance Information
D SETLN()
D SETLN("INSURANCE Information",1,1)
N PSOINS,PSOINS1,I,PSOBINPCN
S PSOINS=$G(DATA(REJ,"INSURANCE NAME"))
F I=1:1:(50-($L(PSOINS)+18)) S PSOINS=PSOINS_" "
S PSOINS1=$G(DATA(REJ,"COB"))
I PSOINS1="SECONDARY" S PSOINS=PSOINS_"Coord. Of Benefits: "_PSOINS1
D SETLN("Insurance : "_PSOINS,,,18)
D SETLN("Contact : "_$G(DATA(REJ,"PLAN CONTACT")),,,18)
S PSOBINPCN=$G(DATA(REJ,"BIN"))_"/ "_$G(DATA(REJ,"PCN"))
D SETLN("BIN/ PCN : "_PSOBINPCN,,,18)
D SETLN("Group Number : "_$E($G(DATA(REJ,"GROUP NUMBER")),1,15),,,18)
D SETLN("Cardholder ID : "_$E($G(DATA(REJ,"CARDHOLDER ID")),1,20),,1,18)
Q
;
CLS ; Resolution Information
N X
I '$$CLOSED(RX,REJ) Q
D SETLN()
D SETLN("RESOLUTION Information",1,1)
D SETLN("Resolved By : "_$G(DATA(REJ,"CLOSED BY")),,,18)
D SETLN("Date/Time : "_$G(DATA(REJ,"CLOSED DATE/TIME")),,,18)
I $G(DATA(REJ,"CLOSE COMMENTS"))'="" D SET("CLOSE COMMENTS",63)
I $G(DATA(REJ,"COD1"))'="" D SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$G(DATA(REJ,"COD1"))),,,18)
I $G(DATA(REJ,"COD2"))'="" D SETLN("Profes. Svc : "_$$OVRX^PSOREJU1(2,$G(DATA(REJ,"COD2"))),,,18)
I $G(DATA(REJ,"COD3"))'="" D SETLN("Result of Svc : "_$$OVRX^PSOREJU1(3,$G(DATA(REJ,"COD3"))),,,18)
I $G(DATA(REJ,"CLA CODE"))'="" D
. N CLAPNTR S CLAPNTR=$O(^BPS(9002313.25,"B",DATA(REJ,"CLA CODE"),""))
. S X=DATA(REJ,"CLA CODE")_" - "_$$GET1^DIQ(9002313.25,CLAPNTR,".02")
. D SETLN("Clarific. Code : "_X,,,18)
I $G(DATA(REJ,"PRIOR AUTH TYPE"))'="" D
. S X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE"))
. D SETLN("Prior Auth.Type: "_X,,,18),SETLN("Prior Auth. # : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18)
D SETLN("Reason : "_$G(DATA(REJ,"CLOSE REASON")),,1,18)
Q
;
;
SET(FIELD,L,UND) ; Sets the lines for fields that require text wrapping
N TXT,T
S TXT=DATA(REJ,FIELD) I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q
F I=1:1 Q:TXT="" D
. I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q
. S T="",$E(T,81-L)=$E(TXT,1,L) D SETLN(T,,$S($E(TXT,L+1,999)=""&$G(UND):1,1:0),80-L) S TXT=$E(TXT,L+1,999)
Q
;
LABEL(FIELD) ; Sets the label for the field
I FIELD="REASON" Q "Reason Code : "
I FIELD="PAYER MESSAGE" Q "Payer Addl Msg : "
I FIELD="DUR TEXT" Q $S(+$$ISDUR^PSOREJP5(RX,REJ):"+DUR Text : ",1:"DUR Text : ")
I FIELD="CLOSE COMMENTS" Q "Comments : "
Q ""
;
VIEW ; Rx View hidden action
N VALMCNT,TITLE
I $G(PSOBACK) D Q
. S VALMSG="Not available through Backdoor!",VALMBCK="R"
S TITLE=VALM("TITLE")
;
; DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
DO
. N PSOVDA,DA,PS
. S (PSOVDA,DA)=RX,PS="REJECT"
. N RX,REJ,FILL,LINE,TITLE
. D DP^PSORXVW
;
S VALMBCK="R",VALM("TITLE")=TITLE
Q
;
EDT ; Rx Edit hidden action
N VALMCNT,TITLE
I $G(PSOBACK) D Q
. S VALMSG="Not available through Backdoor!",VALMBCK="R"
S TITLE=VALM("TITLE")
;
; DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
DO
. N PSOSITE,ORN,PSOPAR,PSOLIST,PSOREJCT
. S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL),ORN=RX
. S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOLIST(1)=ORN_","
. ; Variable PSOREJCT is used so that EPH^PSORXEDT has the RX 'passed' by this routine
. S PSOREJCT=RX_U_FILL
. N RX,REJ,FILL,LINE,TITLE
. D EPH^PSORXEDT
;
K VALMBCK I $$CLOSED(RX,REJ),$D(PSOSTFLT),PSOSTFLT="U" S CHANGE=1 Q
S VALMBCK="R",VALM("TITLE")=TITLE
Q
;
OVR ; Override a REJECT action
N PSOET
I $$CLOSED(RX,REJ,1) Q
S PSOET=$$PSOET^PSOREJP3(RX,FILL)
I PSOET S VALMSG="OVR not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q
N COD1,COD2,COD3
D FULL^VALM1 W !
S COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^"!(COD1="") S VALMBCK="R" Q
S COD2=$$OVRCOD^PSOREJU1(2) I COD2="^" S VALMBCK="R" Q
S COD3=$$OVRCOD^PSOREJU1(3) I COD3="^" S VALMBCK="R" Q
D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
D SEND^PSOREJP3(COD1_"^"_COD2_"^"_COD3,,,PSOET)
Q
;
RES ; Re-submit a claim action
N PSOET
I $$CLOSED(RX,REJ,1) Q
S PSOET=$$PSOET^PSOREJP3(RX,FILL)
D FULL^VALM1 W !
D SEND^PSOREJP3(,,,PSOET)
Q
;
CLA ; Submit Clarification Code
N CLA,PSOET
I $$CLOSED(RX,REJ,1) Q
S PSOET=$$PSOET^PSOREJP3(RX,FILL)
I PSOET S VALMSG="CLA not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q
D FULL^VALM1 W !
; Prompt for the Submission Clarification Codes (up to three)
S CLA=$$CLA^PSOREJU1() I CLA="^"!(CLA="") S VALMBCK="R" Q
W ! D SEND^PSOREJP3(,CLA,,PSOET)
Q
;
PA ; Submit Prior Authorization
N PA,PSOET
I $$CLOSED(RX,REJ,1) Q
S PSOET=$$PSOET^PSOREJP3(RX,FILL)
I PSOET S VALMSG="PA not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q
D FULL^VALM1 W !
; Prompt for Prior Auth fields
S PA=$$PA^PSOREJU2() I PA="^" S VALMBCK="R" Q
W ! D SEND^PSOREJP3(,,PA,PSOET)
Q
;
MP ; Patient Medication Profile
I $G(PSOBACK) D Q
. S VALMSG="Not available through Backdoor!",VALMBCK="R"
N SITE,PATIENT
D FULL^VALM1 W !
S SITE=+$$RXSITE^PSOBPSUT(RX,FILL) S:$G(PSOSITE) SITE=PSOSITE
S PATIENT=+$$GET1^DIQ(52,RX,2,"I")
D LST^PSOPMP0(SITE,PATIENT) S VALMBCK="R"
Q
;
EXIT ;
K ^TMP("PSOREJP1",$J)
Q
;
SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
N X
S:$G(TEXT)="" $E(TEXT,80)=""
S:$L(TEXT)>80 TEXT=$E(TEXT,1,80)
S LINE=LINE+1,^TMP("PSOREJP1",$J,LINE,0)=$G(TEXT)
;
I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE
;
I $G(REV) D Q
. D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM)
. I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM)
I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
I $G(HIG) D
. D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM)
Q
HELP ;
Q
;
CLOSED(RX,REJ,MSG) ; Returns whether the REJECT is RESOLVED or NOT
I $$GET1^DIQ(52.25,REJ_","_RX,10,"I") D:$G(MSG) Q 1
. S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
Q 0
;
REOPN(RX,REJ) ; Returns whether the REJECT was RE-OPENED or NOT
Q $S($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1)
;
EXP(CODE) ; Returns the explanation field (.02) for a reject code
; Input: (r) CODE - .01 field (Code) value from file 9002313.93
; Output: .02 field (Explanation) value from file 9002313.93
N DIC,X,Y
S DIC=9002313.93,DIC(0)="Z",X=CODE D ^DIC
Q $P($G(Y(0)),"^",2)
;
OUT(RX) ; Supported call by outside PROTOCOLs to act on specific REJECTs
N I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN
I '$D(^XUSEC("PSORPH",DUZ)) D Q
. S VALMSG="PSORPH key required to use the REJ action.",VALMBCK="R"
I $G(PS)="REJECT" D
. S VALMSG="REJ action is not available at this point.",VALMBCK="R"
S PSOBACK=1
S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I)) S RFL=I
S X=$$FIND^PSOREJUT(RX,RFL,.DATA,,1) S REJ=$O(DATA(""))
I '$G(REJ) S VALMSG="Invalid selection!",VALMBCK="R" Q
D EN(RX,REJ) S VALMBCK="R"
Q
;
SMA ; Submit multiple actions
N CLA,I,OVR,OVRSTR,PA,REJIEN,DUR,RSC,DURIEN,REQ,RSUB,PSOET
I $$CLOSED(RX,REJ,1) Q
S PSOET=$$PSOET^PSOREJP3(RX,FILL)
I PSOET S VALMSG="SMA not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q
D FULL^VALM1 W !
S DURIEN=$P($G(^PSRX(RX,"REJ",REJ,0)),U,11)
D DURRESP^BPSNCPD3(DURIEN,.DUR) ; Reference to BPSNCPD3 supported by IA 4560
;
; Prompt for Prior Auth fields
S PA=$$PA^PSOREJU2
I PA="^" S VALMBCK="R" Q ;User terminated or did not answer
;
; Prompt for submission clarification codes (up to three)
W !
S CLA=$$CLA^PSOREJU1
I CLA="^" S VALMBCK="R" Q ;User terminated or did not answer
;
; Check if DUR Overrides required - PSO*7*421
S REQ=$$REQ I REQ="^" S VALMBCK="R" Q
;
; Prompt for DUR Overrides (up to 3) - option to delete default added - PSO*7*421
S OVRSTR="",OVR=""
I REQ S REJIEN=0 F RSUB=1:1:3 D Q:OVR="^"!(OVR="")!(OVR="@") S $P(OVRSTR,"~",RSUB)=OVR
. I REJIEN]"" S REJIEN=$O(DUR(1,"DUR PPS",REJIEN))
. S RSC="" I +REJIEN S RSC=$P($G(DUR(1,"DUR PPS",REJIEN,"REASON FOR SERVICE CODE"))," ",1)
. S OVR=$$SMAOVR^PSOREJU1(RSC,RSUB)
I OVR="^" S VALMBCK="R" Q ;User exited or timed-out
;
W !!,?6,"RECAP:"
W !,?6,"Prior Authorization Type : ",$P(PA,"^")," ",$$DSC^PSOREJU1(9002313.26,$P(PA,"^"),.02)
W !,?6,"Prior Authorization Number : ",$P(PA,"^",2)
W !,?6,"Submission Clarification Code 1: ",$P(CLA,"~",1)," ",$$DSC^PSOREJU1(9002313.25,$P(CLA,"~",1),.02)
I $P(CLA,"~",2)]"" W !,?6,"Submission Clarification Code 2: ",$P(CLA,"~",2)," ",$$DSC^PSOREJU1(9002313.25,$P(CLA,"~",2),.02)
I $P(CLA,"~",3)]"" W !,?6,"Submission Clarification Code 3: ",$P(CLA,"~",3)," ",$$DSC^PSOREJU1(9002313.25,$P(CLA,"~",3),.02)
W !,?6,"Reason for Service Code 1 : ",$P($P(OVRSTR,"~",1),U,1)," ",$$DSC^PSOREJU1(9002313.23,$P($P(OVRSTR,"~",1),U,1),1)
W !,?6,"Professional Service Code 1 : ",$P($P(OVRSTR,"~",1),U,2)," ",$$DSC^PSOREJU1(9002313.21,$P($P(OVRSTR,"~",1),U,2),1)
W !,?6,"Result of Service Code 1 : ",$P($P(OVRSTR,"~",1),U,3)," ",$$DSC^PSOREJU1(9002313.22,$P($P(OVRSTR,"~",1),U,3),1)
I $P($P(OVRSTR,"~",2),U,1)]"" W !,?6,"Reason for Service Code 2 : ",$P($P(OVRSTR,"~",2),U,1)," ",$$DSC^PSOREJU1(9002313.23,$P($P(OVRSTR,"~",2),U,1),1)
I $P($P(OVRSTR,"~",2),U,2)]"" W !,?6,"Professional Service Code 2 : ",$P($P(OVRSTR,"~",2),U,2)," ",$$DSC^PSOREJU1(9002313.21,$P($P(OVRSTR,"~",2),U,2),1)
I $P($P(OVRSTR,"~",2),U,3)]"" W !,?6,"Result of Service Code 2 : ",$P($P(OVRSTR,"~",2),U,3)," ",$$DSC^PSOREJU1(9002313.22,$P($P(OVRSTR,"~",2),U,3),1)
I $P($P(OVRSTR,"~",3),U,1)]"" W !,?6,"Reason for Service Code 3 : ",$P($P(OVRSTR,"~",3),U,1)," ",$$DSC^PSOREJU1(9002313.23,$P($P(OVRSTR,"~",3),U,1),1)
I $P($P(OVRSTR,"~",3),U,2)]"" W !,?6,"Professional Service Code 3 : ",$P($P(OVRSTR,"~",3),U,2)," ",$$DSC^PSOREJU1(9002313.21,$P($P(OVRSTR,"~",3),U,2),1)
I $P($P(OVRSTR,"~",3),U,3)]"" W !,?6,"Result of Service Code 3 : ",$P($P(OVRSTR,"~",3),U,3)," ",$$DSC^PSOREJU1(9002313.22,$P($P(OVRSTR,"~",3),U,3),1)
W !
D SEND^PSOREJP3(OVRSTR,CLA,PA,PSOET)
Q
;
VRX ; View ePharmacy Prescription - invoked from the Reject Information screen
N BPSVRX
K ^TMP("BPSVRX1-PSO VIEW RX",$J,"PSOHDR")
D FULL^VALM1
;
; save the current header display
M ^TMP("BPSVRX1-PSO VIEW RX",$J,"PSOHDR")=^TMP("PSOHDR",$J)
;
S BPSVRX("RXIEN")=$G(RX)
S BPSVRX("FILL#")=$G(FILL)
D ^BPSVRX ; DBIA #5723
;
; restore the header display
I '$D(^TMP("PSOHDR",$J)) M ^TMP("PSOHDR",$J)=^TMP("BPSVRX1-PSO VIEW RX",$J,"PSOHDR")
;
S VALMBCK="R"
K ^TMP("BPSVRX1-PSO VIEW RX",$J,"PSOHDR")
Q
;
VER ; View ePharmacy Prescription - invoked from the Rx view hidden action of Medication Profile
N BPSVRX
K ^TMP("BPSVRX-PSO VIEW RX",$J)
D FULL^VALM1
;
; save the current PSO Rx display array and header
M ^TMP("BPSVRX-PSO VIEW RX",$J,"PSOHDR")=^TMP("PSOHDR",$J)
M ^TMP("BPSVRX-PSO VIEW RX",$J,"PSOAL")=^TMP("PSOAL",$J)
;
S BPSVRX("RXIEN")=$G(RXN) ; Rx ien ptr file 52
D ^BPSVRX ; DBIA #5723
;
; restore the PSO Rx display array and header upon return
I '$D(^TMP("PSOHDR",$J)) M ^TMP("PSOHDR",$J)=^TMP("BPSVRX-PSO VIEW RX",$J,"PSOHDR")
I '$D(^TMP("PSOAL",$J)) M ^TMP("PSOAL",$J)=^TMP("BPSVRX-PSO VIEW RX",$J,"PSOAL")
;
S VALMBCK="R"
K ^TMP("BPSVRX-PSO VIEW RX",$J)
Q
;
REQ() ;Prompt if DUR Rejects are required
N DIR,DTOUT,DTOUT,DIRUT,DIROUT,X,Y
S DIR("?")="Enter No if Reason Codes are not required. Enter Yes to proceed and enter up to 3 sets of override Reason Codes. To delete default Reason Codes, enter ""@""."
S DIR("A")="Enter DUR codes",DIR(0)="Y",DIR("B")="YES" W ! D ^DIR
I $D(DIRUT)!$D(DIROUT) Q "^" ;User exited or timed-out
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJP1 16944 printed Dec 13, 2024@02:33:32 Page 2
PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05
+1 ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281,287,289,290,358,359,385,403,421,427,448,478,482,512,562,648,702,704**;DEC 1997;Build 16
+2 ; Reference to File 9002313.93 - BPS NCPDP REJECT CODES in ICR #4720
+3 ; Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE in ICR #4712
+4 ; Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE in ICR #4713
+5 ; Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE in ICR #4714
+6 ; Reference to File 9002313.25 - BPS NCPDP SUBMISSION CLARIFICATION CODE in ICR #5064
+7 ; Reference to File 9002313.26 - BPS NCPDP PRIOR AUTHORIZATION TYPE CODE in ICR #5585
+8 ; Reference to DURRESP^BPSNCPD3 in ICR #4560
+9 ; Reference to ^BPSVRX in ICR #5723
+10 ; Reference to $$BBILL^BPSBUTL,$$RESUBMIT^BPSBUTL in ICR #4719
+11 ;
+12 ;
EN(RX,REJ,CHANGE) ; Entry point
+1 ;
+2 NEW FILL,LASTLN,PSOCODE,PSOTRIC
+3 SET FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
+4 SET PSOTRIC=$$TRIC(RX,FILL)
SET PSOCODE=$$GET1^DIQ(52.25,REJ_","_RX,.01)
+5 IF $$CLOSED(RX,REJ)
DO EN^VALM("PSO REJECT DISPLAY - RESOLVED")
+6 IF '$$CLOSED(RX,REJ)&(PSOTRIC)
DO EN^VALM("PSO REJECT TRICARE")
+7 IF '$$CLOSED(RX,REJ)&('PSOTRIC)
DO EN^VALM("PSO REJECT DISPLAY")
+8 DO FULL^VALM1
+9 QUIT
+10 ;
HDR ; Builds the Header section
+1 NEW LINE1,LINE2,PTINFO,X
+2 SET VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1)
+3 SET PTINFO=$$PTINFO^PSOREJU2(RX,1)
+4 SET VALMHDR(2)=$PIECE(PTINFO,U,1)
+5 SET VALMHDR(3)=$PIECE(PTINFO,U,2)
+6 SET VALMHDR(4)=$$RXINFO^PSOREJP3(RX,FILL,1)
+7 SET VALMHDR(5)=$$RXINFO^PSOREJP3(RX,FILL,2,REJ)
+8 QUIT
+9 ;
TRIC(RX,RFL,PSOTRIC) ; Return 1 for TRICARE, 2 for CHAMPVA or 0 (zero) for not TRICARE or CHAMPVA
+1 IF '$DATA(RFL)
SET RFL=$$LSTRFL^PSOBPSU1(RX)
+2 SET PSOTRIC=$SELECT(RFL=0&($$GET1^DIQ(52,RX_",",85,"I")="T"):1,$$GET1^DIQ(52.1,RFL_","_RX_",",85,"I")="T":1,RFL=0&($$GET1^DIQ(52,RX_",",85,"I")="C"):2,$$GET1^DIQ(52.1,RFL_","_RX_",",85,"I")="C":2,1:0)
+3 QUIT PSOTRIC
+4 ;
ELIGDISP(RX,RFL) ; Return either CHAMPVA or TRICARE for display
+1 ; purposes, or null if neither
+2 NEW PSOELIG
+3 SET PSOELIG=$$TRIC(RX,RFL)
+4 QUIT $SELECT(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",1:"")
+5 ;
ELIGTCV(RX,RFL,CAPS) ; Return either CHAMPVA, TRICARE, or Veteran/VETERAN for eligibility display
+1 ; if CAPS=1 then return "Veteran" in all caps
+2 ; Note if the requested refill has been deleted, then the message "N/A - Fill Deleted" will be returned
+3 NEW PSOELIG,VET,DELMSG
+4 SET DELMSG="N/A - Fill Deleted"
+5 SET PSOELIG=$$TRIC(RX,RFL)
SET VET="Veteran"
IF $GET(CAPS)
SET VET="VETERAN"
+6 IF RFL>0
IF '$DATA(^PSRX(RX,1,RFL,0))
SET PSOELIG=3
+7 QUIT $SELECT(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",PSOELIG=3:DELMSG,1:VET)
+8 ;
INIT ; Builds the Body section
+1 NEW DATA,LINE
+2 ; PSO*7*448 obtain fill# from 52.25 subfile if not defined
IF '$DATA(FILL)
SET FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
+3 IF '$$CLOSED(RX,REJ)
SET VALM("TITLE")="Reject Information ("_$$ELIGTCV(RX,FILL)_")"
+4 IF $$CLOSED(RX,REJ)
SET VALM("TITLE")="Reject Information (RESOLVED)"
+5 FOR I=1:1:$GET(LASTLN)
DO RESTORE^VALM10(I)
+6 KILL ^TMP("PSOREJP1",$JOB)
SET VALMCNT=0
SET LINE=0
+7 DO GET^PSOREJU2(RX,FILL,.DATA,REJ,1)
+8 ; Display the REJECT Information
DO REJ
+9 ; Display the Other Rejects Information
DO OTH
+10 ; Display the Comment
DO COM^PSOREJP3
+11 ; Display the Insurance Information
DO INS
+12 ; Display the Resolution Information
DO CLS
+13 SET VALMCNT=LINE
+14 QUIT
+15 ;
REJ ; Reject Information
+1 NEW PFLDT,PSOADD,PSOCOB,PSOECME,PSOET,PSONAF,PSOTXT,TREJ,TYPE
+2 ;
+3 ; Display 'RESUBMISSION' where 'BACK-BILL' currently displays if the
+4 ; claim was resubmitted from the ECME User Screen. To facilitate
+5 ; this, the function $$RESUBMIT^BPSBUTL was created.
+6 ;
+7 SET PSOTXT=""
+8 SET PSOCOB=$GET(DATA(REJ,"COB"))
SET PSOCOB=$SELECT(PSOCOB="SECONDARY":2,PSOCOB="TERTIARY":3,1:1)
+9 IF $$BBILL^BPSBUTL(RX,FILL,PSOCOB)
SET PSOTXT=" BACK-BILL"
+10 ; IA 4719.
IF '$TEST
IF $$RESUBMIT^BPSBUTL(RX,FILL,PSOCOB)
SET PSOTXT=" RESUBMISSION"
+11 DO SETLN("REJECT Information ("_$$ELIGTCV(RX,FILL)_") "_PSOTXT,1,1)
+12 ;
+13 SET PSOECME=$$STATUS^PSOBPSUT(RX,FILL,PSOCOB)
+14 IF PSOECME="E PAYABLE"
Begin DoDot:1
+15 DO SETLN("Reject Received: ",,,18)
+16 DO SETLN("Reject Type : ",,,18)
+17 DO SETLN("Reject Status : ** E PAYABLE **",,,18)
+18 IF DATA(REJ,"PAYER MESSAGE")["Not ECME Billable"
SET DATA(REJ,"PAYER MESSAGE")=""
+19 QUIT
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 IF $GET(DATA(REJ,"CODE"))=79
SET TYPE="79 - REFILL TOO SOON"
+22 IF '$TEST
SET TYPE=DATA(REJ,"CODE")_" - "_$$EXP(DATA(REJ,"CODE"))
+23 IF $LENGTH(TYPE)>62
SET TYPE=$EXTRACT(TYPE,1,59)_"..."
+24 DO SETLN("Reject Received: "_$$FMTE^XLFDT($GET(DATA(REJ,"DATE/TIME"))),,,18)
+25 DO SETLN("Reject Type : "_TYPE,,,18)
+26 ; If TRICARE/CHAMPVA non-billable then reset Status line
+27 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+28 IF PSOET
DO SETLN("Status : NO CLAIM SUBMITTED")
+29 IF 'PSOET
DO SETLN("Reject Status : "_$GET(DATA(REJ,"STATUS"))_" - "_PSOECME,,,18)
+30 QUIT
End DoDot:1
+31 ;
+32 ; code moved to PSOREJP5
+33 DO REJ^PSOREJP5
+34 QUIT
+35 ;
OTH ; Other Rejects Information
+1 NEW LST,I,RJC,J,LAST
+2 SET LST=$GET(DATA(REJ,"OTHER REJECTS"))
IF LST=""
QUIT
+3 DO SETLN()
+4 DO SETLN("OTHER REJECTS",1,1)
+5 FOR I=1:1:$LENGTH(LST,",")
SET RJC=$PIECE(LST,",",I)
Begin DoDot:1
+6 SET LAST=1
FOR J=(I+1):1:$LENGTH(LST,",")
IF $PIECE(LST,",",J)'=""
SET LAST=0
QUIT
+7 IF RJC'=""
DO SETLN(RJC_" - "_$$EXP(RJC),,$SELECT(LAST:1,1:0),6)
End DoDot:1
+8 QUIT
+9 ;
INS ; Insurance Information
+1 DO SETLN()
+2 DO SETLN("INSURANCE Information",1,1)
+3 NEW PSOINS,PSOINS1,I,PSOBINPCN
+4 SET PSOINS=$GET(DATA(REJ,"INSURANCE NAME"))
+5 FOR I=1:1:(50-($LENGTH(PSOINS)+18))
SET PSOINS=PSOINS_" "
+6 SET PSOINS1=$GET(DATA(REJ,"COB"))
+7 IF PSOINS1="SECONDARY"
SET PSOINS=PSOINS_"Coord. Of Benefits: "_PSOINS1
+8 DO SETLN("Insurance : "_PSOINS,,,18)
+9 DO SETLN("Contact : "_$GET(DATA(REJ,"PLAN CONTACT")),,,18)
+10 SET PSOBINPCN=$GET(DATA(REJ,"BIN"))_"/ "_$GET(DATA(REJ,"PCN"))
+11 DO SETLN("BIN/ PCN : "_PSOBINPCN,,,18)
+12 DO SETLN("Group Number : "_$EXTRACT($GET(DATA(REJ,"GROUP NUMBER")),1,15),,,18)
+13 DO SETLN("Cardholder ID : "_$EXTRACT($GET(DATA(REJ,"CARDHOLDER ID")),1,20),,1,18)
+14 QUIT
+15 ;
CLS ; Resolution Information
+1 NEW X
+2 IF '$$CLOSED(RX,REJ)
QUIT
+3 DO SETLN()
+4 DO SETLN("RESOLUTION Information",1,1)
+5 DO SETLN("Resolved By : "_$GET(DATA(REJ,"CLOSED BY")),,,18)
+6 DO SETLN("Date/Time : "_$GET(DATA(REJ,"CLOSED DATE/TIME")),,,18)
+7 IF $GET(DATA(REJ,"CLOSE COMMENTS"))'=""
DO SET("CLOSE COMMENTS",63)
+8 IF $GET(DATA(REJ,"COD1"))'=""
DO SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$GET(DATA(REJ,"COD1"))),,,18)
+9 IF $GET(DATA(REJ,"COD2"))'=""
DO SETLN("Profes. Svc : "_$$OVRX^PSOREJU1(2,$GET(DATA(REJ,"COD2"))),,,18)
+10 IF $GET(DATA(REJ,"COD3"))'=""
DO SETLN("Result of Svc : "_$$OVRX^PSOREJU1(3,$GET(DATA(REJ,"COD3"))),,,18)
+11 IF $GET(DATA(REJ,"CLA CODE"))'=""
Begin DoDot:1
+12 NEW CLAPNTR
SET CLAPNTR=$ORDER(^BPS(9002313.25,"B",DATA(REJ,"CLA CODE"),""))
+13 SET X=DATA(REJ,"CLA CODE")_" - "_$$GET1^DIQ(9002313.25,CLAPNTR,".02")
+14 DO SETLN("Clarific. Code : "_X,,,18)
End DoDot:1
+15 IF $GET(DATA(REJ,"PRIOR AUTH TYPE"))'=""
Begin DoDot:1
+16 SET X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE"))
+17 DO SETLN("Prior Auth.Type: "_X,,,18)
DO SETLN("Prior Auth. # : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18)
End DoDot:1
+18 DO SETLN("Reason : "_$GET(DATA(REJ,"CLOSE REASON")),,1,18)
+19 QUIT
+20 ;
+21 ;
SET(FIELD,L,UND) ; Sets the lines for fields that require text wrapping
+1 NEW TXT,T
+2 SET TXT=DATA(REJ,FIELD)
IF $LENGTH(TXT)'>L
DO SETLN($$LABEL(FIELD)_TXT,,$SELECT($GET(UND):1,1:0),80-L)
QUIT
+3 FOR I=1:1
if TXT=""
QUIT
Begin DoDot:1
+4 IF I=1
DO SETLN($$LABEL(FIELD)_$EXTRACT(TXT,1,L),,,80-L)
SET TXT=$EXTRACT(TXT,L+1,999)
QUIT
+5 SET T=""
SET $EXTRACT(T,81-L)=$EXTRACT(TXT,1,L)
DO SETLN(T,,$SELECT($EXTRACT(TXT,L+1,999)=""&$GET(UND):1,1:0),80-L)
SET TXT=$EXTRACT(TXT,L+1,999)
End DoDot:1
+6 QUIT
+7 ;
LABEL(FIELD) ; Sets the label for the field
+1 IF FIELD="REASON"
QUIT "Reason Code : "
+2 IF FIELD="PAYER MESSAGE"
QUIT "Payer Addl Msg : "
+3 IF FIELD="DUR TEXT"
QUIT $SELECT(+$$ISDUR^PSOREJP5(RX,REJ):"+DUR Text : ",1:"DUR Text : ")
+4 IF FIELD="CLOSE COMMENTS"
QUIT "Comments : "
+5 QUIT ""
+6 ;
VIEW ; Rx View hidden action
+1 NEW VALMCNT,TITLE
+2 IF $GET(PSOBACK)
Begin DoDot:1
+3 SET VALMSG="Not available through Backdoor!"
SET VALMBCK="R"
End DoDot:1
QUIT
+4 SET TITLE=VALM("TITLE")
+5 ;
+6 ; DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
+7 Begin DoDot:1
+8 NEW PSOVDA,DA,PS
+9 SET (PSOVDA,DA)=RX
SET PS="REJECT"
+10 NEW RX,REJ,FILL,LINE,TITLE
+11 DO DP^PSORXVW
End DoDot:1
+12 ;
+13 SET VALMBCK="R"
SET VALM("TITLE")=TITLE
+14 QUIT
+15 ;
EDT ; Rx Edit hidden action
+1 NEW VALMCNT,TITLE
+2 IF $GET(PSOBACK)
Begin DoDot:1
+3 SET VALMSG="Not available through Backdoor!"
SET VALMBCK="R"
End DoDot:1
QUIT
+4 SET TITLE=VALM("TITLE")
+5 ;
+6 ; DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE
+7 Begin DoDot:1
+8 NEW PSOSITE,ORN,PSOPAR,PSOLIST,PSOREJCT
+9 SET PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL)
SET ORN=RX
+10 SET PSOPAR=$GET(^PS(59,PSOSITE,1))
SET PSOLIST(1)=ORN_","
+11 ; Variable PSOREJCT is used so that EPH^PSORXEDT has the RX 'passed' by this routine
+12 SET PSOREJCT=RX_U_FILL
+13 NEW RX,REJ,FILL,LINE,TITLE
+14 DO EPH^PSORXEDT
End DoDot:1
+15 ;
+16 KILL VALMBCK
IF $$CLOSED(RX,REJ)
IF $DATA(PSOSTFLT)
IF PSOSTFLT="U"
SET CHANGE=1
QUIT
+17 SET VALMBCK="R"
SET VALM("TITLE")=TITLE
+18 QUIT
+19 ;
OVR ; Override a REJECT action
+1 NEW PSOET
+2 IF $$CLOSED(RX,REJ,1)
QUIT
+3 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+4 IF PSOET
SET VALMSG="OVR not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim."
SET VALMBCK="R"
QUIT
+5 NEW COD1,COD2,COD3
+6 DO FULL^VALM1
WRITE !
+7 SET COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14))
IF COD1="^"!(COD1="")
SET VALMBCK="R"
QUIT
+8 SET COD2=$$OVRCOD^PSOREJU1(2)
IF COD2="^"
SET VALMBCK="R"
QUIT
+9 SET COD3=$$OVRCOD^PSOREJU1(3)
IF COD3="^"
SET VALMBCK="R"
QUIT
+10 DO OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
+11 DO SEND^PSOREJP3(COD1_"^"_COD2_"^"_COD3,,,PSOET)
+12 QUIT
+13 ;
RES ; Re-submit a claim action
+1 NEW PSOET
+2 IF $$CLOSED(RX,REJ,1)
QUIT
+3 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+4 DO FULL^VALM1
WRITE !
+5 DO SEND^PSOREJP3(,,,PSOET)
+6 QUIT
+7 ;
CLA ; Submit Clarification Code
+1 NEW CLA,PSOET
+2 IF $$CLOSED(RX,REJ,1)
QUIT
+3 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+4 IF PSOET
SET VALMSG="CLA not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim."
SET VALMBCK="R"
QUIT
+5 DO FULL^VALM1
WRITE !
+6 ; Prompt for the Submission Clarification Codes (up to three)
+7 SET CLA=$$CLA^PSOREJU1()
IF CLA="^"!(CLA="")
SET VALMBCK="R"
QUIT
+8 WRITE !
DO SEND^PSOREJP3(,CLA,,PSOET)
+9 QUIT
+10 ;
PA ; Submit Prior Authorization
+1 NEW PA,PSOET
+2 IF $$CLOSED(RX,REJ,1)
QUIT
+3 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+4 IF PSOET
SET VALMSG="PA not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim."
SET VALMBCK="R"
QUIT
+5 DO FULL^VALM1
WRITE !
+6 ; Prompt for Prior Auth fields
+7 SET PA=$$PA^PSOREJU2()
IF PA="^"
SET VALMBCK="R"
QUIT
+8 WRITE !
DO SEND^PSOREJP3(,,PA,PSOET)
+9 QUIT
+10 ;
MP ; Patient Medication Profile
+1 IF $GET(PSOBACK)
Begin DoDot:1
+2 SET VALMSG="Not available through Backdoor!"
SET VALMBCK="R"
End DoDot:1
QUIT
+3 NEW SITE,PATIENT
+4 DO FULL^VALM1
WRITE !
+5 SET SITE=+$$RXSITE^PSOBPSUT(RX,FILL)
if $GET(PSOSITE)
SET SITE=PSOSITE
+6 SET PATIENT=+$$GET1^DIQ(52,RX,2,"I")
+7 DO LST^PSOPMP0(SITE,PATIENT)
SET VALMBCK="R"
+8 QUIT
+9 ;
EXIT ;
+1 KILL ^TMP("PSOREJP1",$JOB)
+2 QUIT
+3 ;
SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
+1 NEW X
+2 if $GET(TEXT)=""
SET $EXTRACT(TEXT,80)=""
+3 if $LENGTH(TEXT)>80
SET TEXT=$EXTRACT(TEXT,1,80)
+4 SET LINE=LINE+1
SET ^TMP("PSOREJP1",$JOB,LINE,0)=$GET(TEXT)
+5 ;
+6 IF LINE>$GET(LASTLN)
DO SAVE^VALM10(LINE)
SET LASTLN=LINE
+7 ;
+8 IF $GET(REV)
Begin DoDot:1
+9 DO CNTRL^VALM10(LINE,1,$LENGTH(TEXT),IORVON,IOINORM)
+10 IF $GET(UND)
DO CNTRL^VALM10(LINE,$LENGTH(TEXT)+1,80,IOUON,IOINORM)
End DoDot:1
QUIT
+11 IF $GET(UND)
DO CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
+12 IF $GET(HIG)
Begin DoDot:1
+13 DO CNTRL^VALM10(LINE,HIG,80,IOINHI_$SELECT($GET(UND):IOUON,1:""),IOINORM)
End DoDot:1
+14 QUIT
HELP ;
+1 QUIT
+2 ;
CLOSED(RX,REJ,MSG) ; Returns whether the REJECT is RESOLVED or NOT
+1 IF $$GET1^DIQ(52.25,REJ_","_RX,10,"I")
if $GET(MSG)
Begin DoDot:1
+2 SET VALMSG="This Reject is marked resolved!"
SET VALMBCK="R"
WRITE $CHAR(7)
End DoDot:1
QUIT 1
+3 QUIT 0
+4 ;
REOPN(RX,REJ) ; Returns whether the REJECT was RE-OPENED or NOT
+1 QUIT $SELECT($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1)
+2 ;
EXP(CODE) ; Returns the explanation field (.02) for a reject code
+1 ; Input: (r) CODE - .01 field (Code) value from file 9002313.93
+2 ; Output: .02 field (Explanation) value from file 9002313.93
+3 NEW DIC,X,Y
+4 SET DIC=9002313.93
SET DIC(0)="Z"
SET X=CODE
DO ^DIC
+5 QUIT $PIECE($GET(Y(0)),"^",2)
+6 ;
OUT(RX) ; Supported call by outside PROTOCOLs to act on specific REJECTs
+1 NEW I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN
+2 IF '$DATA(^XUSEC("PSORPH",DUZ))
Begin DoDot:1
+3 SET VALMSG="PSORPH key required to use the REJ action."
SET VALMBCK="R"
End DoDot:1
QUIT
+4 IF $GET(PS)="REJECT"
Begin DoDot:1
+5 SET VALMSG="REJ action is not available at this point."
SET VALMBCK="R"
End DoDot:1
+6 SET PSOBACK=1
+7 SET (RFL,I)=0
FOR I=1:1
if '$DATA(^PSRX(RX,1,I))
QUIT
SET RFL=I
+8 SET X=$$FIND^PSOREJUT(RX,RFL,.DATA,,1)
SET REJ=$ORDER(DATA(""))
+9 IF '$GET(REJ)
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+10 DO EN(RX,REJ)
SET VALMBCK="R"
+11 QUIT
+12 ;
SMA ; Submit multiple actions
+1 NEW CLA,I,OVR,OVRSTR,PA,REJIEN,DUR,RSC,DURIEN,REQ,RSUB,PSOET
+2 IF $$CLOSED(RX,REJ,1)
QUIT
+3 SET PSOET=$$PSOET^PSOREJP3(RX,FILL)
+4 IF PSOET
SET VALMSG="SMA not allowed for "_$$ELIGDISP(RX,FILL)_" Non-Billable claim."
SET VALMBCK="R"
QUIT
+5 DO FULL^VALM1
WRITE !
+6 SET DURIEN=$PIECE($GET(^PSRX(RX,"REJ",REJ,0)),U,11)
+7 ; Reference to BPSNCPD3 supported by IA 4560
DO DURRESP^BPSNCPD3(DURIEN,.DUR)
+8 ;
+9 ; Prompt for Prior Auth fields
+10 SET PA=$$PA^PSOREJU2
+11 ;User terminated or did not answer
IF PA="^"
SET VALMBCK="R"
QUIT
+12 ;
+13 ; Prompt for submission clarification codes (up to three)
+14 WRITE !
+15 SET CLA=$$CLA^PSOREJU1
+16 ;User terminated or did not answer
IF CLA="^"
SET VALMBCK="R"
QUIT
+17 ;
+18 ; Check if DUR Overrides required - PSO*7*421
+19 SET REQ=$$REQ
IF REQ="^"
SET VALMBCK="R"
QUIT
+20 ;
+21 ; Prompt for DUR Overrides (up to 3) - option to delete default added - PSO*7*421
+22 SET OVRSTR=""
SET OVR=""
+23 IF REQ
SET REJIEN=0
FOR RSUB=1:1:3
Begin DoDot:1
+24 IF REJIEN]""
SET REJIEN=$ORDER(DUR(1,"DUR PPS",REJIEN))
+25 SET RSC=""
IF +REJIEN
SET RSC=$PIECE($GET(DUR(1,"DUR PPS",REJIEN,"REASON FOR SERVICE CODE"))," ",1)
+26 SET OVR=$$SMAOVR^PSOREJU1(RSC,RSUB)
End DoDot:1
if OVR="^"!(OVR="")!(OVR="@")
QUIT
SET $PIECE(OVRSTR,"~",RSUB)=OVR
+27 ;User exited or timed-out
IF OVR="^"
SET VALMBCK="R"
QUIT
+28 ;
+29 WRITE !!,?6,"RECAP:"
+30 WRITE !,?6,"Prior Authorization Type : ",$PIECE(PA,"^")," ",$$DSC^PSOREJU1(9002313.26,$PIECE(PA,"^"),.02)
+31 WRITE !,?6,"Prior Authorization Number : ",$PIECE(PA,"^",2)
+32 WRITE !,?6,"Submission Clarification Code 1: ",$PIECE(CLA,"~",1)," ",$$DSC^PSOREJU1(9002313.25,$PIECE(CLA,"~",1),.02)
+33 IF $PIECE(CLA,"~",2)]""
WRITE !,?6,"Submission Clarification Code 2: ",$PIECE(CLA,"~",2)," ",$$DSC^PSOREJU1(9002313.25,$PIECE(CLA,"~",2),.02)
+34 IF $PIECE(CLA,"~",3)]""
WRITE !,?6,"Submission Clarification Code 3: ",$PIECE(CLA,"~",3)," ",$$DSC^PSOREJU1(9002313.25,$PIECE(CLA,"~",3),.02)
+35 WRITE !,?6,"Reason for Service Code 1 : ",$PIECE($PIECE(OVRSTR,"~",1),U,1)," ",$$DSC^PSOREJU1(9002313.23,$PIECE($PIECE(OVRSTR,"~",1),U,1),1)
+36 WRITE !,?6,"Professional Service Code 1 : ",$PIECE($PIECE(OVRSTR,"~",1),U,2)," ",$$DSC^PSOREJU1(9002313.21,$PIECE($PIECE(OVRSTR,"~",1),U,2),1)
+37 WRITE !,?6,"Result of Service Code 1 : ",$PIECE($PIECE(OVRSTR,"~",1),U,3)," ",$$DSC^PSOREJU1(9002313.22,$PIECE($PIECE(OVRSTR,"~",1),U,3),1)
+38 IF $PIECE($PIECE(OVRSTR,"~",2),U,1)]""
WRITE !,?6,"Reason for Service Code 2 : ",$PIECE($PIECE(OVRSTR,"~",2),U,1)," ",$$DSC^PSOREJU1(9002313.23,$PIECE($PIECE(OVRSTR,"~",2),U,1),1)
+39 IF $PIECE($PIECE(OVRSTR,"~",2),U,2)]""
WRITE !,?6,"Professional Service Code 2 : ",$PIECE($PIECE(OVRSTR,"~",2),U,2)," ",$$DSC^PSOREJU1(9002313.21,$PIECE($PIECE(OVRSTR,"~",2),U,2),1)
+40 IF $PIECE($PIECE(OVRSTR,"~",2),U,3)]""
WRITE !,?6,"Result of Service Code 2 : ",$PIECE($PIECE(OVRSTR,"~",2),U,3)," ",$$DSC^PSOREJU1(9002313.22,$PIECE($PIECE(OVRSTR,"~",2),U,3),1)
+41 IF $PIECE($PIECE(OVRSTR,"~",3),U,1)]""
WRITE !,?6,"Reason for Service Code 3 : ",$PIECE($PIECE(OVRSTR,"~",3),U,1)," ",$$DSC^PSOREJU1(9002313.23,$PIECE($PIECE(OVRSTR,"~",3),U,1),1)
+42 IF $PIECE($PIECE(OVRSTR,"~",3),U,2)]""
WRITE !,?6,"Professional Service Code 3 : ",$PIECE($PIECE(OVRSTR,"~",3),U,2)," ",$$DSC^PSOREJU1(9002313.21,$PIECE($PIECE(OVRSTR,"~",3),U,2),1)
+43 IF $PIECE($PIECE(OVRSTR,"~",3),U,3)]""
WRITE !,?6,"Result of Service Code 3 : ",$PIECE($PIECE(OVRSTR,"~",3),U,3)," ",$$DSC^PSOREJU1(9002313.22,$PIECE($PIECE(OVRSTR,"~",3),U,3),1)
+44 WRITE !
+45 DO SEND^PSOREJP3(OVRSTR,CLA,PA,PSOET)
+46 QUIT
+47 ;
VRX ; View ePharmacy Prescription - invoked from the Reject Information screen
+1 NEW BPSVRX
+2 KILL ^TMP("BPSVRX1-PSO VIEW RX",$JOB,"PSOHDR")
+3 DO FULL^VALM1
+4 ;
+5 ; save the current header display
+6 MERGE ^TMP("BPSVRX1-PSO VIEW RX",$JOB,"PSOHDR")=^TMP("PSOHDR",$JOB)
+7 ;
+8 SET BPSVRX("RXIEN")=$GET(RX)
+9 SET BPSVRX("FILL#")=$GET(FILL)
+10 ; DBIA #5723
DO ^BPSVRX
+11 ;
+12 ; restore the header display
+13 IF '$DATA(^TMP("PSOHDR",$JOB))
MERGE ^TMP("PSOHDR",$JOB)=^TMP("BPSVRX1-PSO VIEW RX",$JOB,"PSOHDR")
+14 ;
+15 SET VALMBCK="R"
+16 KILL ^TMP("BPSVRX1-PSO VIEW RX",$JOB,"PSOHDR")
+17 QUIT
+18 ;
VER ; View ePharmacy Prescription - invoked from the Rx view hidden action of Medication Profile
+1 NEW BPSVRX
+2 KILL ^TMP("BPSVRX-PSO VIEW RX",$JOB)
+3 DO FULL^VALM1
+4 ;
+5 ; save the current PSO Rx display array and header
+6 MERGE ^TMP("BPSVRX-PSO VIEW RX",$JOB,"PSOHDR")=^TMP("PSOHDR",$JOB)
+7 MERGE ^TMP("BPSVRX-PSO VIEW RX",$JOB,"PSOAL")=^TMP("PSOAL",$JOB)
+8 ;
+9 ; Rx ien ptr file 52
SET BPSVRX("RXIEN")=$GET(RXN)
+10 ; DBIA #5723
DO ^BPSVRX
+11 ;
+12 ; restore the PSO Rx display array and header upon return
+13 IF '$DATA(^TMP("PSOHDR",$JOB))
MERGE ^TMP("PSOHDR",$JOB)=^TMP("BPSVRX-PSO VIEW RX",$JOB,"PSOHDR")
+14 IF '$DATA(^TMP("PSOAL",$JOB))
MERGE ^TMP("PSOAL",$JOB)=^TMP("BPSVRX-PSO VIEW RX",$JOB,"PSOAL")
+15 ;
+16 SET VALMBCK="R"
+17 KILL ^TMP("BPSVRX-PSO VIEW RX",$JOB)
+18 QUIT
+19 ;
REQ() ;Prompt if DUR Rejects are required
+1 NEW DIR,DTOUT,DTOUT,DIRUT,DIROUT,X,Y
+2 SET DIR("?")="Enter No if Reason Codes are not required. Enter Yes to proceed and enter up to 3 sets of override Reason Codes. To delete default Reason Codes, enter ""@""."
+3 SET DIR("A")="Enter DUR codes"
SET DIR(0)="Y"
SET DIR("B")="YES"
WRITE !
DO ^DIR
+4 ;User exited or timed-out
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT "^"
+5 QUIT Y
