PSOREJP0 ;BIRM/MFR - Third Party Rejects Processing Screen ;04/28/05
;;7.0;OUTPATIENT PHARMACY;**148,260,287,289,385,421,427,448,549,562,704**;DEC 1997;Build 16
; Reference to ^BPSVRX in ICR #5723
;
N PSOREJST,PSORJSRT,PSORJASC,PSOSTFLT,PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT,PSOINGRP,PSOTRITG
N INSLN,HIGHLN,LASTLN,PSOEKEY,PSOCVATG,PSORCFLT
;
; - Division/Site selection
D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT
;
; - Initializing global variables
S PSORJSRT="PA",PSORJASC=1,PSOSTFLT="U",(PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT,PSORCFLT)="ALL"
S PSOINGRP=0,PSOTRITG=1,PSOCVATG=1
;
D LST("W")
G EXIT
;
LST(PSOMENU) ; - Invokes Listmanager
W !,"Please wait..."
I PSOMENU="W" D EN^VALM("PSO REJECTS WORKLIST")
I PSOMENU="VP" D EN^VALM("PSO REJECTS VIEW/PROCESS")
D FULL^VALM1
Q
;
HDR ; - Header code
N LINE1,LINE2,LINE3
S LINE1=$$SITES() I $L(LINE1)>80 S $E(LINE1,78,999)="..."
;
S LINE2="Selection : ALL "_$S(PSOSTFLT="U":"UNRESOLVED ",PSOSTFLT="R":"RESOLVED ",1:"")_"REJECTS"
I $G(PSOPTFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("P")
I $G(PSODRFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("D")
I $G(PSOINFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("I")
I $G(PSORCFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("C")
I $G(PSOINGRP) S LINE2=LINE2_" GROUPED BY INSURANCE"
S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2
I PSOMENU="VP" D
. I $G(PSORXFLT) S LINE3="Rx# : "_$$NAME("R")
. E D
. . S LINE3="Date Range: "_$$FMTE^XLFDT(+PSODTRNG,2)
. . I +PSODTRNG'=$P(PSODTRNG,"^",2) S LINE3=LINE3_" THRU "_$$FMTE^XLFDT($P(PSODTRNG,"^",2),2)
. S VALMHDR(3)=LINE3
;
D SETHDR()
Q
;
SETHDR() ; - Displays the Header Line
N HDR,ORD
;
S HDR=" #",$E(HDR,5)="Rx#",$E(HDR,18)="PATIENT(ID)",$E(HDR,43)="DRUG",$E(HDR,64)="REASON"
S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,$S(PSOMENU="W":4,1:5))
S ORD=$S(PSORJASC=1:"[^]",1:"[v]")
S:PSORJSRT="RX" POS=9 S:PSORJSRT="PA" POS=30 S:PSORJSRT="DR" POS=48 S:PSORJSRT="RE" POS=71
D INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,$S(PSOMENU="W":4,1:5))
Q
;
INIT ; - Populates the Body section for ListMan
K ^TMP("PSOREJP0",$J)
D SETSORT(PSORJSRT),SETLINE
S VALMSG="Select the entry # to view or ?? for more actions"
Q
;
SETLINE ; - Sets the line to be displayed in ListMan
N INS,SUB,SEQ,SORTA,LINE,Z,I,X,X1,X2
I '$D(^TMP("PSOREJSR",$J)) D Q
. F I=1:1:7 S ^TMP("PSOREJP0",$J,I,0)=""
. S ^TMP("PSOREJP0",$J,8,0)=" No Clinical Third Party Payer Rejects found."
. S VALMCNT=1
;
F I=1:1:$G(LASTLN) D RESTORE^VALM10(I)
K INSLN,HIGHLN
;
S (SORTA,INS,SUB)="",LINE=0 K ^TMP("PSOREJP0",$J)
F S SORTA=$O(^TMP("PSOREJSR",$J,SORTA)) Q:SORTA="" D
. F S INS=$O(^TMP("PSOREJSR",$J,SORTA,INS)) Q:INS="" D
. . I INS'="<NULL>" D
. . . D GROUP(INS,.LINE)
. . F S SUB=$O(^TMP("PSOREJSR",$J,SORTA,INS,SUB),PSORJASC) Q:SUB="" D
. . . S Z=$G(^TMP("PSOREJSR",$J,SORTA,INS,SUB))
. . . S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3)
. . . S $E(X1,5)=$P(Z,"^",3),$E(X1,18)=$P(Z,"^",4),$E(X1,43)=$P(Z,"^",5),$E(X1,64)=$P(Z,"^",6)
. . . S LINE=LINE+1,^TMP("PSOREJP0",$J,LINE,0)=X1,HIGHLN(LINE)=""
. . . S X2="",$E(X2,5)="Payer Message: "_$P(Z,"^",7)
. . . S LINE=LINE+1,^TMP("PSOREJP0",$J,LINE,0)=X2
. . . S ^TMP("PSOREJP0",$J,SEQ,"RX")=$P(Z,"^",1,2)
;
I LINE>$G(LASTLN) D
. F I=($G(LASTLN)+1):1:LINE D SAVE^VALM10(I)
. S LASTLN=LINE
;
; - Highlighting the prescription/insurance line
F LN=1:1:LINE D
. I $D(HIGHLN(LN)) D Q
. . D CNTRL^VALM10(LN,1,80,IOINHI,IOINORM)
. . D CNTRL^VALM10(LN,64,3,IOUON,IOINORM)
. . D CNTRL^VALM10(LN,67,80,IOINHI,IOINORM)
. I $D(INSLN(LN)) D
. . S LBL=INSLN(LN),POS=41-($L(LBL)/2+.5\1)
. . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM)
. . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IORVOFF_IOINORM)
. . D CNTRL^VALM10(LN,POS+$L(LBL),(81-POS-$L(LBL)),IOUON_IOINHI,IOINORM)
;
S VALMCNT=+$G(LINE)
Q
;
GROUP(LBL,LINE) ; Sets an insurance delimiter line
N X,POS
S POS=41-($L(LBL)/2+.5\1)
S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL
S LINE=LINE+1,^TMP("PSOREJP0",$J,LINE,0)=X,INSLN(LINE)=LBL
Q
;
SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified
N RX,REJ,STS,DAT
K ^TMP("PSOREJSR",$J)
;
; - Worklist
I PSOMENU="W" D
. S RX=0 F S RX=$O(^PSRX("REJSTS",0,RX)) Q:'RX D
. . S REJ=0 F S REJ=$O(^PSRX("REJSTS",0,RX,REJ)) Q:'REJ D
. . . D SETTMP(RX,REJ,FIELD)
;
; - View/Process
I PSOMENU="VP" D
. I $G(PSORXFLT)'="ALL" D Q
. . S REJ=0 F S REJ=$O(^PSRX(+PSORXFLT,"REJ",REJ)) Q:'REJ D
. . . I $$FLTSTS(+PSORXFLT,REJ) Q
. . . D SETTMP(+PSORXFLT,REJ,FIELD)
. S DAT=$P(PSODTRNG,"^")-0.0000001,(RX,REJ)=0
. F S DAT=$O(^PSRX("REJDAT",DAT)) Q:'DAT!(DAT>$$ENDT()) D
. . F S RX=$O(^PSRX("REJDAT",DAT,RX)) Q:'RX D
. . . I $$FILTER(RX) Q
. . . F S REJ=$O(^PSRX("REJDAT",DAT,RX,REJ)) Q:'REJ D
. . . . I $$FLTSTS(RX,REJ) Q
. . . . I $G(PSORCFLT)'="ALL",$$FLTRC(RX,REJ) Q
. . . . D SETTMP(RX,REJ,FIELD)
Q
;
SETTMP(RX,REJ,FIELD) ; - Sets ^TMP global that will be displayed in the body section
N CODE,DRNAME,FILL,I,INS,MSG,OREJ,PSOCOB,PSOTRIC,PTNAME,REASON,REJLST,RXNUM,SORT,SORTA,X,Z
I $G(PSORXFLT)="ALL",$$CLOSED^PSOREJP1(RX,REJ),$$REOPN^PSOREJP1(RX,REJ) Q
S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SORTA=1
I '$$DIV(RX,FILL) Q
K REJLST D GET^PSOREJU2(RX,FILL,.REJLST,,1) I '$D(REJLST) Q
I $$FILTER(,REJLST(REJ,"INSURANCE POINTER")) Q
S CODE=$G(REJLST(REJ,"CODE"))
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
Q:$G(PSOTRIC)=1&('$G(PSOTRITG))&(CODE'="79")&(CODE'="88")&(CODE'="943") ;show/hide non-DUR/RTS TRICARE
Q:$G(PSOTRIC)=2&('$G(PSOCVATG))&(CODE'="79")&(CODE'="88")&(CODE'="943") ;show/hide non-DUR/RTS CHAMPVA
S PTNAME=$$PTNAME(RX)
S DRNAME=$$GET1^DIQ(52,RX,6)
S RXNUM=$$GET1^DIQ(52,RX,.01)
S MSG=$G(REJLST(REJ,"PAYER MESSAGE")) I $L(MSG)>60 S MSG=$E(MSG,1,58)_"..."
S PSOCOB=$S(REJLST(REJ,"COB")="SECONDARY":2,1:1)
I $$STATUS^PSOBPSUT(RX,FILL,PSOCOB)="E PAYABLE" D
. I MSG["Not ECME Billable" S MSG=""
S REASON=$S(CODE=88!(CODE=943):"DUR:"_$G(REJLST(REJ,"REASON")),CODE=79:"79 :REFILL TOO SOON",1:CODE)
I CODE'=79&(CODE'=88)&(CODE'=943) S REASON=CODE_" :"_$$EXP^PSOREJP1(CODE)
S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=REJ,$P(Z,"^",3)=RXNUM,$P(Z,"^",4)=PTNAME
S $P(Z,"^",5)=$E(DRNAME,1,20),$P(Z,"^",6)=$E(REASON,1,17),$P(Z,"^",7)=MSG
S SORT=$S(FIELD="PA":PTNAME,FIELD="DR":DRNAME,FIELD="RX":RXNUM_" ",1:REASON)_RX_REJ
S INS="<NULL>"
I $G(PSOINGRP) S INS=REJLST(REJ,"INSURANCE NAME") S:INS="" INS="***UNKNOWN***"
; Separate Veteran RRR
S:$G(PSOTRIC)&(CODE'=79)&(CODE'=88)&(CODE'=943) INS=$$ELIGDISP^PSOREJP1(RX,FILL)_" - Non-DUR/RTS",SORTA=3
I '$G(PSOTRIC)&(CODE'=79)&(CODE'=88)&(CODE'=943) D
. I $G(REJLST(REJ,"RRR FLAG"))="YES" S INS="REJECT RESOLUTION REQUIRED",SORTA=2 Q
. S INS="OTHER REJECTS",SORTA=4
S ^TMP("PSOREJSR",$J,SORTA,INS,SORT)=Z
Q
;
PAT ; - Sort by Patient
D SORT("PA")
Q
DRG ; - Sort by Drug
D SORT("DR")
Q
RX ; - Sort by Rx
D SORT("RX")
Q
REA ; - Sort by Reason
D SORT("RE")
Q
SORT(FIELD) ; - Sort entries by FIELD
I PSORJSRT=FIELD S PSORJASC=$S(PSORJASC=1:-1,1:1)
E S PSORJSRT=FIELD,PSORJASC=1
D REF
Q
;
REF ; - Screen Refresh
W ?52,"Please wait..." D INIT S VALMBCK="R"
Q
GI ; - Group by Insurance
W ?52,"Please wait..." S PSOINGRP=$S($G(PSOINGRP):0,1:1) D INIT,HDR S VALMBCK="R"
Q
TRICTOG ; - Toggle TRICARE display
W ?52,"Please wait..." S PSOTRITG=$S($G(PSOTRITG):0,1:1) D INIT,HDR S VALMBCK="R"
Q
;
CVATOG ; - Toggle CHAMPVA display
W ?52,"Please wait..." S PSOCVATG=$S($G(PSOCVATG):0,1:1) D INIT,HDR S VALMBCK="R"
Q
;
SEL ; - Process selection of one entry
N PSOSEL,XQORM,Z,RX,REJ,PSOCHNG
S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q
S Z=$G(^TMP("PSOREJP0",$J,PSOSEL,"RX"))
S RX=$P(Z,"^"),REJ=$P(Z,"^",2) I 'RX!'REJ S VALMSG="Invalid selection!",VALMBCK="R" Q
S PSOCHNG=0 D EN^PSOREJP1(RX,REJ,.PSOCHNG) I $G(PSOCHNG) D REF
Q
;
EXIT ;
K ^TMP("PSOREJP0",$J),^TMP("PSOREJSR",$J)
Q
;
HELP Q
;
SITES() ; - Returns the list of sites along with their NCPDP #s
N CNT,SITE,SITES,NAME
I '$D(PSOREJST) Q ""
I $G(PSOREJST)="ALL" Q "Divisions : ALL"
S SITE=0 F S SITE=$O(PSOREJST(SITE)) Q:'SITE D
. S NAME=$$GET1^DIQ(59,SITE,.01)
. S SITES=$G(SITES)_", "_NAME
S $E(SITES,1,2)="",SITES="Division"_$S($L(SITES,",")>1:"s",1:" ")_" : "_SITES
Q SITES
;
DIV(RX,FILL) ; - Check if the Division for the Prescription/Fill was selected by the user
;
I $G(PSOREJST)="ALL" Q 1
I $D(PSOREJST($$RXSITE^PSOBPSUT(RX,FILL))) Q 1
Q 0
;
PTNAME(RX) ; - Returns header displayable - Patient Name (Last 4 SSN)
N DFN,VADM,PTNAME
S DFN=$$GET1^DIQ(52,RX,2,"I") D DEM^VADPT
S PTNAME=$E($G(VADM(1)),1,18)_"("_$P($P($G(VADM(2)),"^",2),"-",3)_")"
Q PTNAME
;
FILTER(RX,INS) ; - Filter entries based on user's selection
N FILTER
S FILTER=1
I $G(PSOPTFLT)'="ALL",$D(RX),'$D(PSOPTFLT($$GET1^DIQ(52,RX,2,"I"))) Q FILTER
I $G(PSODRFLT)'="ALL",$D(RX),'$D(PSODRFLT($$GET1^DIQ(52,RX,6,"I"))) Q FILTER
I $G(PSOINFLT)'="ALL",$D(INS),'$D(PSOINFLT(+INS)) Q FILTER
Q 0
;
FLTSTS(RX,REJ) ; - Filter for the Reject Status
N STS
S STS=$$GET1^DIQ(52.25,REJ_","_RX,9,"I")
I PSOSTFLT="U",STS=1 Q 1
I PSOSTFLT="R",STS=0 Q 1
Q 0
;
FLTRC(RX,REJ) ; - Filter for user selected Reject Codes
N REJCD
S REJCD=$$GET1^DIQ(52.25,REJ_","_RX,.01)
S REJCD=$O(^BPSF(9002313.93,"B",REJCD,""))
I '$D(PSORCFLT(REJCD)) Q 1
Q 0
;
NAME(TYPE) ; - Returns the name if ONE was selected or "MULTIPLE ..."
N I,CNT,RC01,RC02,RC
;
I TYPE="P",$O(PSOPTFLT($O(PSOPTFLT(""))))="" Q $$GET1^DIQ(2,$O(PSOPTFLT("")),.01)
I TYPE="D",$O(PSODRFLT($O(PSODRFLT(""))))="" Q $$GET1^DIQ(50,$O(PSODRFLT("")),.01)
I TYPE="I",$O(PSOINFLT($O(PSOINFLT(""))))="" Q $O(PSOINFLT(""))
I TYPE="R" Q $$GET1^DIQ(52,PSORXFLT,.01)
I TYPE="C",$O(PSORCFLT($O(PSORCFLT(""))))="" D Q RC
. S RC01=$$GET1^DIQ(9002313.93,$O(PSORCFLT("")),.01)
. S RC02=$$GET1^DIQ(9002313.93,$O(PSORCFLT("")),.02)
. S RC=RC01_" - "_RC02
Q "MULTIPLE "_$S(TYPE="P":"PATIENTS",TYPE="D":"DRUGS",TYPE="C":"REJECT CODES",1:"INSURANCE COMPANIES")
;
ENDT() ; Returns the upper limit for the date range
N ENDT
S ENDT=$P(PSODTRNG,"^",2)
I '$E(ENDT,4,7) Q (ENDT+10000)
I '$E(ENDT,6,7) Q (ENDT+100)
I $P(ENDT,"^",2) Q (ENDT+0.0000001)
Q (ENDT+.25)
VER ;Do VER Hidden Action in Rejects Worklist
N BPSVRX
D FULL^VALM1
D ^BPSVRX ;DBIA #5723
S VALMBCK="R"
Q
;
PRTEXCL ;
; Protocol to Print to Excel
;
; Use full screen
D FULL^VALM1
;
; Prompt to see if the user wants to print to Excel
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="Y"
S DIR("A")="Do you want to capture report data for an Excel document",DIR("B")="NO"
D ^DIR
I Y'=1 G PEXIT
;
; Display Warning Message
W !!?5,"Before continuing, please set up your terminal to capture the"
W !?5,"detail report data. On some terminals, this can be done by"
W !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
W !?5,"Incoming Data' to save to Desktop"
W !!?5,"Note: To avoid undesired wrapping of the data saved to the"
W !?10,"file, please enter '0;256;999' at the 'DEVICE:' prompt."
;
; Prompt for device
N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,OK
S OK=0
F D I POP!OK Q
. S %ZIS="QM"
. D ^%ZIS
. I POP Q
. I '$D(IO("Q")) S OK=1 Q
. I $D(IO("Q")) D
. . K IO("Q")
. . D HOME^%ZIS
. . W !,"Sorry, the output for this action cannot be queued. Please select a device that"
. . W !,"does not requiring queuing."
I POP G PEXIT
;
; If not queued, run the process directly
D RUN
;
PEXIT ;
; Reset before going back to ListMan
S VALMBCK="R"
Q
;
; Run the Report
RUN ;
N SORTA,INS,SORT,RX,REJ,FILL,PTNAME,DRNAME,RXNUM,REJLST,CODE,REASON,MSG
U IO
; Write Header
W !,"Section/Insurance^RX#^Patient(ID)^Drug^Reason^Payer Message"
;
; Loop through temp array and output
S SORTA="" F S SORTA=$O(^TMP("PSOREJSR",$J,SORTA)) Q:'SORTA D
. S INS="" F S INS=$O(^TMP("PSOREJSR",$J,SORTA,INS)) Q:INS="" D
. . S SORT="" F S SORT=$O(^TMP("PSOREJSR",$J,SORTA,INS,SORT)) Q:SORT="" D
. . . W !,$S(INS'="<NULL>":INS,1:"Refill Too Soon/DUR Rejects")_U
. . . S RX=$P(^TMP("PSOREJSR",$J,SORTA,INS,SORT),"^",1),REJ=$P(^TMP("PSOREJSR",$J,SORTA,INS,SORT),"^",2)
. . . S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
. . . S PTNAME=$$PTNAME(RX)
. . . S DRNAME=$$GET1^DIQ(52,RX,6)
. . . S RXNUM=$$GET1^DIQ(52,RX,.01)
. . . K REJLST D GET^PSOREJU2(RX,FILL,.REJLST,,1)
. . . S CODE=$G(REJLST(REJ,"CODE"))
. . . S REASON=$S(CODE=88!(CODE=943):"DUR:"_$G(REJLST(REJ,"REASON")),CODE=79:"79 :REFILL TOO SOON",1:CODE_" :"_$$EXP^PSOREJP1(CODE))
. . . S MSG=$G(REJLST(REJ,"PAYER MESSAGE"))
. . . W RXNUM_U_PTNAME_U_DRNAME_U_REASON_U_MSG
;
; Cleanup
I $E($G(IOST),1,2)'="C-" W !,@IOF
I $E($G(IOST),1,2)="C-" D
. N DIR,DTOUT,DUOUT,DIROUT,DIRUT
. S DIR(0)="E"
. D ^DIR
I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJP0 13120 printed Sep 23, 2025@20:09:56 Page 2
PSOREJP0 ;BIRM/MFR - Third Party Rejects Processing Screen ;04/28/05
+1 ;;7.0;OUTPATIENT PHARMACY;**148,260,287,289,385,421,427,448,549,562,704**;DEC 1997;Build 16
+2 ; Reference to ^BPSVRX in ICR #5723
+3 ;
+4 NEW PSOREJST,PSORJSRT,PSORJASC,PSOSTFLT,PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT,PSOINGRP,PSOTRITG
+5 NEW INSLN,HIGHLN,LASTLN,PSOEKEY,PSOCVATG,PSORCFLT
+6 ;
+7 ; - Division/Site selection
+8 DO SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$GET(PSOSITE),.01))
IF $GET(PSOREJST)="^"
GOTO EXIT
+9 ;
+10 ; - Initializing global variables
+11 SET PSORJSRT="PA"
SET PSORJASC=1
SET PSOSTFLT="U"
SET (PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT,PSORCFLT)="ALL"
+12 SET PSOINGRP=0
SET PSOTRITG=1
SET PSOCVATG=1
+13 ;
+14 DO LST("W")
+15 GOTO EXIT
+16 ;
LST(PSOMENU) ; - Invokes Listmanager
+1 WRITE !,"Please wait..."
+2 IF PSOMENU="W"
DO EN^VALM("PSO REJECTS WORKLIST")
+3 IF PSOMENU="VP"
DO EN^VALM("PSO REJECTS VIEW/PROCESS")
+4 DO FULL^VALM1
+5 QUIT
+6 ;
HDR ; - Header code
+1 NEW LINE1,LINE2,LINE3
+2 SET LINE1=$$SITES()
IF $LENGTH(LINE1)>80
SET $EXTRACT(LINE1,78,999)="..."
+3 ;
+4 SET LINE2="Selection : ALL "_$SELECT(PSOSTFLT="U":"UNRESOLVED ",PSOSTFLT="R":"RESOLVED ",1:"")_"REJECTS"
+5 IF $GET(PSOPTFLT)'="ALL"
SET LINE2=LINE2_" FOR "_$$NAME("P")
+6 IF $GET(PSODRFLT)'="ALL"
SET LINE2=LINE2_" FOR "_$$NAME("D")
+7 IF $GET(PSOINFLT)'="ALL"
SET LINE2=LINE2_" FOR "_$$NAME("I")
+8 IF $GET(PSORCFLT)'="ALL"
SET LINE2=LINE2_" FOR "_$$NAME("C")
+9 IF $GET(PSOINGRP)
SET LINE2=LINE2_" GROUPED BY INSURANCE"
+10 SET VALMHDR(1)=LINE1
SET VALMHDR(2)=LINE2
+11 IF PSOMENU="VP"
Begin DoDot:1
+12 IF $GET(PSORXFLT)
SET LINE3="Rx# : "_$$NAME("R")
+13 IF '$TEST
Begin DoDot:2
+14 SET LINE3="Date Range: "_$$FMTE^XLFDT(+PSODTRNG,2)
+15 IF +PSODTRNG'=$PIECE(PSODTRNG,"^",2)
SET LINE3=LINE3_" THRU "_$$FMTE^XLFDT($PIECE(PSODTRNG,"^",2),2)
End DoDot:2
+16 SET VALMHDR(3)=LINE3
End DoDot:1
+17 ;
+18 DO SETHDR()
+19 QUIT
+20 ;
SETHDR() ; - Displays the Header Line
+1 NEW HDR,ORD
+2 ;
+3 SET HDR=" #"
SET $EXTRACT(HDR,5)="Rx#"
SET $EXTRACT(HDR,18)="PATIENT(ID)"
SET $EXTRACT(HDR,43)="DRUG"
SET $EXTRACT(HDR,64)="REASON"
+4 SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_HDR_IOINORM,1,$SELECT(PSOMENU="W":4,1:5))
+5 SET ORD=$SELECT(PSORJASC=1:"[^]",1:"[v]")
+6 if PSORJSRT="RX"
SET POS=9
if PSORJSRT="PA"
SET POS=30
if PSORJSRT="DR"
SET POS=48
if PSORJSRT="RE"
SET POS=71
+7 DO INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,$SELECT(PSOMENU="W":4,1:5))
+8 QUIT
+9 ;
INIT ; - Populates the Body section for ListMan
+1 KILL ^TMP("PSOREJP0",$JOB)
+2 DO SETSORT(PSORJSRT)
DO SETLINE
+3 SET VALMSG="Select the entry # to view or ?? for more actions"
+4 QUIT
+5 ;
SETLINE ; - Sets the line to be displayed in ListMan
+1 NEW INS,SUB,SEQ,SORTA,LINE,Z,I,X,X1,X2
+2 IF '$DATA(^TMP("PSOREJSR",$JOB))
Begin DoDot:1
+3 FOR I=1:1:7
SET ^TMP("PSOREJP0",$JOB,I,0)=""
+4 SET ^TMP("PSOREJP0",$JOB,8,0)=" No Clinical Third Party Payer Rejects found."
+5 SET VALMCNT=1
End DoDot:1
QUIT
+6 ;
+7 FOR I=1:1:$GET(LASTLN)
DO RESTORE^VALM10(I)
+8 KILL INSLN,HIGHLN
+9 ;
+10 SET (SORTA,INS,SUB)=""
SET LINE=0
KILL ^TMP("PSOREJP0",$JOB)
+11 FOR
SET SORTA=$ORDER(^TMP("PSOREJSR",$JOB,SORTA))
if SORTA=""
QUIT
Begin DoDot:1
+12 FOR
SET INS=$ORDER(^TMP("PSOREJSR",$JOB,SORTA,INS))
if INS=""
QUIT
Begin DoDot:2
+13 IF INS'="<NULL>"
Begin DoDot:3
+14 DO GROUP(INS,.LINE)
End DoDot:3
+15 FOR
SET SUB=$ORDER(^TMP("PSOREJSR",$JOB,SORTA,INS,SUB),PSORJASC)
if SUB=""
QUIT
Begin DoDot:3
+16 SET Z=$GET(^TMP("PSOREJSR",$JOB,SORTA,INS,SUB))
+17 SET X1=""
SET SEQ=$GET(SEQ)+1
SET X1=$JUSTIFY(SEQ,3)
+18 SET $EXTRACT(X1,5)=$PIECE(Z,"^",3)
SET $EXTRACT(X1,18)=$PIECE(Z,"^",4)
SET $EXTRACT(X1,43)=$PIECE(Z,"^",5)
SET $EXTRACT(X1,64)=$PIECE(Z,"^",6)
+19 SET LINE=LINE+1
SET ^TMP("PSOREJP0",$JOB,LINE,0)=X1
SET HIGHLN(LINE)=""
+20 SET X2=""
SET $EXTRACT(X2,5)="Payer Message: "_$PIECE(Z,"^",7)
+21 SET LINE=LINE+1
SET ^TMP("PSOREJP0",$JOB,LINE,0)=X2
+22 SET ^TMP("PSOREJP0",$JOB,SEQ,"RX")=$PIECE(Z,"^",1,2)
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 IF LINE>$GET(LASTLN)
Begin DoDot:1
+25 FOR I=($GET(LASTLN)+1):1:LINE
DO SAVE^VALM10(I)
+26 SET LASTLN=LINE
End DoDot:1
+27 ;
+28 ; - Highlighting the prescription/insurance line
+29 FOR LN=1:1:LINE
Begin DoDot:1
+30 IF $DATA(HIGHLN(LN))
Begin DoDot:2
+31 DO CNTRL^VALM10(LN,1,80,IOINHI,IOINORM)
+32 DO CNTRL^VALM10(LN,64,3,IOUON,IOINORM)
+33 DO CNTRL^VALM10(LN,67,80,IOINHI,IOINORM)
End DoDot:2
QUIT
+34 IF $DATA(INSLN(LN))
Begin DoDot:2
+35 SET LBL=INSLN(LN)
SET POS=41-($LENGTH(LBL)/2+.5\1)
+36 DO CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM)
+37 DO CNTRL^VALM10(LN,POS,$LENGTH(LBL),IORVON_IOINHI,IORVOFF_IOINORM)
+38 DO CNTRL^VALM10(LN,POS+$LENGTH(LBL),(81-POS-$LENGTH(LBL)),IOUON_IOINHI,IOINORM)
End DoDot:2
End DoDot:1
+39 ;
+40 SET VALMCNT=+$GET(LINE)
+41 QUIT
+42 ;
GROUP(LBL,LINE) ; Sets an insurance delimiter line
+1 NEW X,POS
+2 SET POS=41-($LENGTH(LBL)/2+.5\1)
+3 SET X=""
SET $PIECE(X," ",81)=""
SET $EXTRACT(X,POS,POS-1+$LENGTH(LBL))=LBL
+4 SET LINE=LINE+1
SET ^TMP("PSOREJP0",$JOB,LINE,0)=X
SET INSLN(LINE)=LBL
+5 QUIT
+6 ;
SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified
+1 NEW RX,REJ,STS,DAT
+2 KILL ^TMP("PSOREJSR",$JOB)
+3 ;
+4 ; - Worklist
+5 IF PSOMENU="W"
Begin DoDot:1
+6 SET RX=0
FOR
SET RX=$ORDER(^PSRX("REJSTS",0,RX))
if 'RX
QUIT
Begin DoDot:2
+7 SET REJ=0
FOR
SET REJ=$ORDER(^PSRX("REJSTS",0,RX,REJ))
if 'REJ
QUIT
Begin DoDot:3
+8 DO SETTMP(RX,REJ,FIELD)
End DoDot:3
End DoDot:2
End DoDot:1
+9 ;
+10 ; - View/Process
+11 IF PSOMENU="VP"
Begin DoDot:1
+12 IF $GET(PSORXFLT)'="ALL"
Begin DoDot:2
+13 SET REJ=0
FOR
SET REJ=$ORDER(^PSRX(+PSORXFLT,"REJ",REJ))
if 'REJ
QUIT
Begin DoDot:3
+14 IF $$FLTSTS(+PSORXFLT,REJ)
QUIT
+15 DO SETTMP(+PSORXFLT,REJ,FIELD)
End DoDot:3
End DoDot:2
QUIT
+16 SET DAT=$PIECE(PSODTRNG,"^")-0.0000001
SET (RX,REJ)=0
+17 FOR
SET DAT=$ORDER(^PSRX("REJDAT",DAT))
if 'DAT!(DAT>$$ENDT())
QUIT
Begin DoDot:2
+18 FOR
SET RX=$ORDER(^PSRX("REJDAT",DAT,RX))
if 'RX
QUIT
Begin DoDot:3
+19 IF $$FILTER(RX)
QUIT
+20 FOR
SET REJ=$ORDER(^PSRX("REJDAT",DAT,RX,REJ))
if 'REJ
QUIT
Begin DoDot:4
+21 IF $$FLTSTS(RX,REJ)
QUIT
+22 IF $GET(PSORCFLT)'="ALL"
IF $$FLTRC(RX,REJ)
QUIT
+23 DO SETTMP(RX,REJ,FIELD)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
SETTMP(RX,REJ,FIELD) ; - Sets ^TMP global that will be displayed in the body section
+1 NEW CODE,DRNAME,FILL,I,INS,MSG,OREJ,PSOCOB,PSOTRIC,PTNAME,REASON,REJLST,RXNUM,SORT,SORTA,X,Z
+2 IF $GET(PSORXFLT)="ALL"
IF $$CLOSED^PSOREJP1(RX,REJ)
IF $$REOPN^PSOREJP1(RX,REJ)
QUIT
+3 SET FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
SET SORTA=1
+4 IF '$$DIV(RX,FILL)
QUIT
+5 KILL REJLST
DO GET^PSOREJU2(RX,FILL,.REJLST,,1)
IF '$DATA(REJLST)
QUIT
+6 IF $$FILTER(,REJLST(REJ,"INSURANCE POINTER"))
QUIT
+7 SET CODE=$GET(REJLST(REJ,"CODE"))
+8 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
+9 ;show/hide non-DUR/RTS TRICARE
if $GET(PSOTRIC)=1&('$GET(PSOTRITG))&(CODE'="79")&(CODE'="88")&(CODE'="943")
QUIT
+10 ;show/hide non-DUR/RTS CHAMPVA
if $GET(PSOTRIC)=2&('$GET(PSOCVATG))&(CODE'="79")&(CODE'="88")&(CODE'="943")
QUIT
+11 SET PTNAME=$$PTNAME(RX)
+12 SET DRNAME=$$GET1^DIQ(52,RX,6)
+13 SET RXNUM=$$GET1^DIQ(52,RX,.01)
+14 SET MSG=$GET(REJLST(REJ,"PAYER MESSAGE"))
IF $LENGTH(MSG)>60
SET MSG=$EXTRACT(MSG,1,58)_"..."
+15 SET PSOCOB=$SELECT(REJLST(REJ,"COB")="SECONDARY":2,1:1)
+16 IF $$STATUS^PSOBPSUT(RX,FILL,PSOCOB)="E PAYABLE"
Begin DoDot:1
+17 IF MSG["Not ECME Billable"
SET MSG=""
End DoDot:1
+18 SET REASON=$SELECT(CODE=88!(CODE=943):"DUR:"_$GET(REJLST(REJ,"REASON")),CODE=79:"79 :REFILL TOO SOON",1:CODE)
+19 IF CODE'=79&(CODE'=88)&(CODE'=943)
SET REASON=CODE_" :"_$$EXP^PSOREJP1(CODE)
+20 SET Z=""
SET $PIECE(Z,"^")=RX
SET $PIECE(Z,"^",2)=REJ
SET $PIECE(Z,"^",3)=RXNUM
SET $PIECE(Z,"^",4)=PTNAME
+21 SET $PIECE(Z,"^",5)=$EXTRACT(DRNAME,1,20)
SET $PIECE(Z,"^",6)=$EXTRACT(REASON,1,17)
SET $PIECE(Z,"^",7)=MSG
+22 SET SORT=$SELECT(FIELD="PA":PTNAME,FIELD="DR":DRNAME,FIELD="RX":RXNUM_" ",1:REASON)_RX_REJ
+23 SET INS="<NULL>"
+24 IF $GET(PSOINGRP)
SET INS=REJLST(REJ,"INSURANCE NAME")
if INS=""
SET INS="***UNKNOWN***"
+25 ; Separate Veteran RRR
+26 if $GET(PSOTRIC)&(CODE'=79)&(CODE'=88)&(CODE'=943)
SET INS=$$ELIGDISP^PSOREJP1(RX,FILL)_" - Non-DUR/RTS"
SET SORTA=3
+27 IF '$GET(PSOTRIC)&(CODE'=79)&(CODE'=88)&(CODE'=943)
Begin DoDot:1
+28 IF $GET(REJLST(REJ,"RRR FLAG"))="YES"
SET INS="REJECT RESOLUTION REQUIRED"
SET SORTA=2
QUIT
+29 SET INS="OTHER REJECTS"
SET SORTA=4
End DoDot:1
+30 SET ^TMP("PSOREJSR",$JOB,SORTA,INS,SORT)=Z
+31 QUIT
+32 ;
PAT ; - Sort by Patient
+1 DO SORT("PA")
+2 QUIT
DRG ; - Sort by Drug
+1 DO SORT("DR")
+2 QUIT
RX ; - Sort by Rx
+1 DO SORT("RX")
+2 QUIT
REA ; - Sort by Reason
+1 DO SORT("RE")
+2 QUIT
SORT(FIELD) ; - Sort entries by FIELD
+1 IF PSORJSRT=FIELD
SET PSORJASC=$SELECT(PSORJASC=1:-1,1:1)
+2 IF '$TEST
SET PSORJSRT=FIELD
SET PSORJASC=1
+3 DO REF
+4 QUIT
+5 ;
REF ; - Screen Refresh
+1 WRITE ?52,"Please wait..."
DO INIT
SET VALMBCK="R"
+2 QUIT
GI ; - Group by Insurance
+1 WRITE ?52,"Please wait..."
SET PSOINGRP=$SELECT($GET(PSOINGRP):0,1:1)
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
TRICTOG ; - Toggle TRICARE display
+1 WRITE ?52,"Please wait..."
SET PSOTRITG=$SELECT($GET(PSOTRITG):0,1:1)
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
+3 ;
CVATOG ; - Toggle CHAMPVA display
+1 WRITE ?52,"Please wait..."
SET PSOCVATG=$SELECT($GET(PSOCVATG):0,1:1)
DO INIT
DO HDR
SET VALMBCK="R"
+2 QUIT
+3 ;
SEL ; - Process selection of one entry
+1 NEW PSOSEL,XQORM,Z,RX,REJ,PSOCHNG
+2 SET PSOSEL=+$PIECE($PIECE(Y(1),"^",4),"=",2)
IF 'PSOSEL
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+3 SET Z=$GET(^TMP("PSOREJP0",$JOB,PSOSEL,"RX"))
+4 SET RX=$PIECE(Z,"^")
SET REJ=$PIECE(Z,"^",2)
IF 'RX!'REJ
SET VALMSG="Invalid selection!"
SET VALMBCK="R"
QUIT
+5 SET PSOCHNG=0
DO EN^PSOREJP1(RX,REJ,.PSOCHNG)
IF $GET(PSOCHNG)
DO REF
+6 QUIT
+7 ;
EXIT ;
+1 KILL ^TMP("PSOREJP0",$JOB),^TMP("PSOREJSR",$JOB)
+2 QUIT
+3 ;
HELP QUIT
+1 ;
SITES() ; - Returns the list of sites along with their NCPDP #s
+1 NEW CNT,SITE,SITES,NAME
+2 IF '$DATA(PSOREJST)
QUIT ""
+3 IF $GET(PSOREJST)="ALL"
QUIT "Divisions : ALL"
+4 SET SITE=0
FOR
SET SITE=$ORDER(PSOREJST(SITE))
if 'SITE
QUIT
Begin DoDot:1
+5 SET NAME=$$GET1^DIQ(59,SITE,.01)
+6 SET SITES=$GET(SITES)_", "_NAME
End DoDot:1
+7 SET $EXTRACT(SITES,1,2)=""
SET SITES="Division"_$SELECT($LENGTH(SITES,",")>1:"s",1:" ")_" : "_SITES
+8 QUIT SITES
+9 ;
DIV(RX,FILL) ; - Check if the Division for the Prescription/Fill was selected by the user
+1 ;
+2 IF $GET(PSOREJST)="ALL"
QUIT 1
+3 IF $DATA(PSOREJST($$RXSITE^PSOBPSUT(RX,FILL)))
QUIT 1
+4 QUIT 0
+5 ;
PTNAME(RX) ; - Returns header displayable - Patient Name (Last 4 SSN)
+1 NEW DFN,VADM,PTNAME
+2 SET DFN=$$GET1^DIQ(52,RX,2,"I")
DO DEM^VADPT
+3 SET PTNAME=$EXTRACT($GET(VADM(1)),1,18)_"("_$PIECE($PIECE($GET(VADM(2)),"^",2),"-",3)_")"
+4 QUIT PTNAME
+5 ;
FILTER(RX,INS) ; - Filter entries based on user's selection
+1 NEW FILTER
+2 SET FILTER=1
+3 IF $GET(PSOPTFLT)'="ALL"
IF $DATA(RX)
IF '$DATA(PSOPTFLT($$GET1^DIQ(52,RX,2,"I")))
QUIT FILTER
+4 IF $GET(PSODRFLT)'="ALL"
IF $DATA(RX)
IF '$DATA(PSODRFLT($$GET1^DIQ(52,RX,6,"I")))
QUIT FILTER
+5 IF $GET(PSOINFLT)'="ALL"
IF $DATA(INS)
IF '$DATA(PSOINFLT(+INS))
QUIT FILTER
+6 QUIT 0
+7 ;
FLTSTS(RX,REJ) ; - Filter for the Reject Status
+1 NEW STS
+2 SET STS=$$GET1^DIQ(52.25,REJ_","_RX,9,"I")
+3 IF PSOSTFLT="U"
IF STS=1
QUIT 1
+4 IF PSOSTFLT="R"
IF STS=0
QUIT 1
+5 QUIT 0
+6 ;
FLTRC(RX,REJ) ; - Filter for user selected Reject Codes
+1 NEW REJCD
+2 SET REJCD=$$GET1^DIQ(52.25,REJ_","_RX,.01)
+3 SET REJCD=$ORDER(^BPSF(9002313.93,"B",REJCD,""))
+4 IF '$DATA(PSORCFLT(REJCD))
QUIT 1
+5 QUIT 0
+6 ;
NAME(TYPE) ; - Returns the name if ONE was selected or "MULTIPLE ..."
+1 NEW I,CNT,RC01,RC02,RC
+2 ;
+3 IF TYPE="P"
IF $ORDER(PSOPTFLT($ORDER(PSOPTFLT(""))))=""
QUIT $$GET1^DIQ(2,$ORDER(PSOPTFLT("")),.01)
+4 IF TYPE="D"
IF $ORDER(PSODRFLT($ORDER(PSODRFLT(""))))=""
QUIT $$GET1^DIQ(50,$ORDER(PSODRFLT("")),.01)
+5 IF TYPE="I"
IF $ORDER(PSOINFLT($ORDER(PSOINFLT(""))))=""
QUIT $ORDER(PSOINFLT(""))
+6 IF TYPE="R"
QUIT $$GET1^DIQ(52,PSORXFLT,.01)
+7 IF TYPE="C"
IF $ORDER(PSORCFLT($ORDER(PSORCFLT(""))))=""
Begin DoDot:1
+8 SET RC01=$$GET1^DIQ(9002313.93,$ORDER(PSORCFLT("")),.01)
+9 SET RC02=$$GET1^DIQ(9002313.93,$ORDER(PSORCFLT("")),.02)
+10 SET RC=RC01_" - "_RC02
End DoDot:1
QUIT RC
+11 QUIT "MULTIPLE "_$SELECT(TYPE="P":"PATIENTS",TYPE="D":"DRUGS",TYPE="C":"REJECT CODES",1:"INSURANCE COMPANIES")
+12 ;
ENDT() ; Returns the upper limit for the date range
+1 NEW ENDT
+2 SET ENDT=$PIECE(PSODTRNG,"^",2)
+3 IF '$EXTRACT(ENDT,4,7)
QUIT (ENDT+10000)
+4 IF '$EXTRACT(ENDT,6,7)
QUIT (ENDT+100)
+5 IF $PIECE(ENDT,"^",2)
QUIT (ENDT+0.0000001)
+6 QUIT (ENDT+.25)
VER ;Do VER Hidden Action in Rejects Worklist
+1 NEW BPSVRX
+2 DO FULL^VALM1
+3 ;DBIA #5723
DO ^BPSVRX
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
PRTEXCL ;
+1 ; Protocol to Print to Excel
+2 ;
+3 ; Use full screen
+4 DO FULL^VALM1
+5 ;
+6 ; Prompt to see if the user wants to print to Excel
+7 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+8 SET DIR(0)="Y"
+9 SET DIR("A")="Do you want to capture report data for an Excel document"
SET DIR("B")="NO"
+10 DO ^DIR
+11 IF Y'=1
GOTO PEXIT
+12 ;
+13 ; Display Warning Message
+14 WRITE !!?5,"Before continuing, please set up your terminal to capture the"
+15 WRITE !?5,"detail report data. On some terminals, this can be done by"
+16 WRITE !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
+17 WRITE !?5,"Incoming Data' to save to Desktop"
+18 WRITE !!?5,"Note: To avoid undesired wrapping of the data saved to the"
+19 WRITE !?10,"file, please enter '0;256;999' at the 'DEVICE:' prompt."
+20 ;
+21 ; Prompt for device
+22 NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,OK
+23 SET OK=0
+24 FOR
Begin DoDot:1
+25 SET %ZIS="QM"
+26 DO ^%ZIS
+27 IF POP
QUIT
+28 IF '$DATA(IO("Q"))
SET OK=1
QUIT
+29 IF $DATA(IO("Q"))
Begin DoDot:2
+30 KILL IO("Q")
+31 DO HOME^%ZIS
+32 WRITE !,"Sorry, the output for this action cannot be queued. Please select a device that"
+33 WRITE !,"does not requiring queuing."
End DoDot:2
End DoDot:1
IF POP!OK
QUIT
+34 IF POP
GOTO PEXIT
+35 ;
+36 ; If not queued, run the process directly
+37 DO RUN
+38 ;
PEXIT ;
+1 ; Reset before going back to ListMan
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
+5 ; Run the Report
RUN ;
+1 NEW SORTA,INS,SORT,RX,REJ,FILL,PTNAME,DRNAME,RXNUM,REJLST,CODE,REASON,MSG
+2 USE IO
+3 ; Write Header
+4 WRITE !,"Section/Insurance^RX#^Patient(ID)^Drug^Reason^Payer Message"
+5 ;
+6 ; Loop through temp array and output
+7 SET SORTA=""
FOR
SET SORTA=$ORDER(^TMP("PSOREJSR",$JOB,SORTA))
if 'SORTA
QUIT
Begin DoDot:1
+8 SET INS=""
FOR
SET INS=$ORDER(^TMP("PSOREJSR",$JOB,SORTA,INS))
if INS=""
QUIT
Begin DoDot:2
+9 SET SORT=""
FOR
SET SORT=$ORDER(^TMP("PSOREJSR",$JOB,SORTA,INS,SORT))
if SORT=""
QUIT
Begin DoDot:3
+10 WRITE !,$SELECT(INS'="<NULL>":INS,1:"Refill Too Soon/DUR Rejects")_U
+11 SET RX=$PIECE(^TMP("PSOREJSR",$JOB,SORTA,INS,SORT),"^",1)
SET REJ=$PIECE(^TMP("PSOREJSR",$JOB,SORTA,INS,SORT),"^",2)
+12 SET FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
+13 SET PTNAME=$$PTNAME(RX)
+14 SET DRNAME=$$GET1^DIQ(52,RX,6)
+15 SET RXNUM=$$GET1^DIQ(52,RX,.01)
+16 KILL REJLST
DO GET^PSOREJU2(RX,FILL,.REJLST,,1)
+17 SET CODE=$GET(REJLST(REJ,"CODE"))
+18 SET REASON=$SELECT(CODE=88!(CODE=943):"DUR:"_$GET(REJLST(REJ,"REASON")),CODE=79:"79 :REFILL TOO SOON",1:CODE_" :"_$$EXP^PSOREJP1(CODE))
+19 SET MSG=$GET(REJLST(REJ,"PAYER MESSAGE"))
+20 WRITE RXNUM_U_PTNAME_U_DRNAME_U_REASON_U_MSG
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 ; Cleanup
+23 IF $EXTRACT($GET(IOST),1,2)'="C-"
WRITE !,@IOF
+24 IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+25 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT
+26 SET DIR(0)="E"
+27 DO ^DIR
End DoDot:1
+28 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+29 DO ^%ZISC
+30 QUIT
