PSOREJP2 ;BIRM/MFR - Third Party Rejects View/Process ;04/28/05
;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289**;DEC 1997;Build 107
;Reference to ^PSSLOCK supported by IA #2789
;
N PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT
N PSOINFLT,PSODTRNG,PSOINGRP,PSOTRITG
S PSORJASC=1,PSOINGRP=0,PSOTRITG=1
;
; - Division/Site selection
D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT
;
; - Date range selection
W ! S PSODTRNG=$$DTRNG("T-90","T") I PSODTRNG="^" G EXIT
;
SEL ; - Field Selection (Patient/Drug/Rx)
S DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE",DIR("B")="P"
S DIR("A")="By (P)atient, (D)rug, (R)x or (I)nsurance" D ^DIR I $D(DIRUT) G EXIT
S PSOBYFLD=Y,DIR("B")=""
;
I PSOBYFLD="P" D I $G(PSOPTFLT)="^" G SEL
. S (PSODRFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="DR"
. D SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT)
;
I PSOBYFLD="D" D I $G(PSODRFLT)="^" G SEL
. S (PSOPTFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="PA"
. D SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT)
;
I PSOBYFLD="R" D I $D(DUOUT)!$D(DTOUT)!'$G(PSORXFLT) G SEL
. S (PSOPTFLT,PSODRFLT,PSOINFLT)="ALL",PSORJSRT="PA"
. N DIC,Y,X,OK K PSOSTFLT,PSORXFLT
. S DIC=52,DIC(0)="QEZA",DIC("A")="PRESCRIPTION: "
. F W ! D ^DIC D Q:$G(OK)
. . I $D(DUOUT)!$D(DTOUT)!(X="") S OK=1 Q
. . I '$O(^PSRX(+Y,"REJ",0)) D Q
. . . W !?40,"Prescription does not have rejects!",$C(7)
. . S PSORXFLT=+Y,OK=1
;
I PSOBYFLD="I" D I $O(PSOINFLT(""))="" G SEL
. S (PSOPTFLT,PSODRFLT,PSORXFLT)="ALL",PSORJSRT="PA"
. N DIR,Y,X,OK K PSOINFLT W !
. S DIR("A",1)="Enter the whole or part of the Insurance Company"
. S DIR("A",2)="name for which you want to view/process REJECTS."
. S DIR("A",3)=""
. S DIR(0)="FO^3:30",DIR("A")=" INSURANCE"
. F D ^DIR D Q:$G(OK)
. . I $D(DIRUT)!(X="") S OK=1 Q
. . S PSOINFLT(X)="" K DIR("A") S DIR("A")="ANOTHER ONE"
;
; - Status Selection (UNRESOLVED or RESOLVED)
I $G(PSOSTFLT)="" D I $D(DIRUT) G EXIT
. S DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH",DIR("B")="B"
. S DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses" D ^DIR
. S PSOSTFLT=Y
;
D LST^PSOREJP0("VP")
;
EXIT Q
;
CLO ; - Ignore a REJECT hidden action
N PSOTRIC,X
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
I $G(PSOTRIC) S VALMSG="INVALID: TRICARE rejected Rxs may not be ignored.",VALMBCK="R" Q
I $$CLOSED^PSOREJP1(RX,REJ) D Q
. S VALMSG="This Reject is marked resolved!",VALMBCK="R"
N DIR,COM
D FULL^VALM1
I '$$SIG^PSOREJU1() S VALMBCK="R" Q
W !
S COM=$$COM^PSOREJU1() I COM="^" S VALMBCK="R" Q
W !
S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="NO"
S DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED."
S DIR("A",2)=" "
D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
W ?40,"[Closing..." D CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM) W "OK]",!,$C(7) H 1
I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
;
I $$PTLBL(RX,FILL) D PRINT^PSOREJP3(RX,FILL)
;
Q
;
OPN ; - Re-open a Closed/Resolved Reject
I '$$CLOSED^PSOREJP1(RX,REJ) D Q
. S VALMSG="This Reject is NOT marked resolved!",VALMBCK="R"
N DIR,COM,REJDATA,NEWDATA,X,REOPEN
D FULL^VALM1
I '$$SIG^PSOREJU1() S VALMBCK="R" Q
W !
S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="NO"
S DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED."
S DIR("A",2)=" "
D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
;
W ?40,"[Re-opening..."
K REJDATA D GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1) D SETOPN^PSOREJU2(RX,REJ)
K NEWDATA M NEWDATA=REJDATA(REJ) S NEWDATA("PHARMACIST")=DUZ
S REOPEN=1 D SAVE^PSOREJUT(RX,FILL,.NEWDATA,REOPEN)
I $G(NEWDATA("REJECT IEN")),$D(REJDATA(REJ,"COMMENTS")) D
. S COM=0 F S COM=$O(REJDATA(REJ,"COMMENTS",COM)) Q:'COM D
. . S X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS")
. . S X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME")
. . S X(3)=REJDATA(REJ,"COMMENTS",COM,"USER")
. . D SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3))
D RETRXF^PSOREJU2(RX,FILL,0)
W "OK]",!,$C(7) H 1
S CHANGE=1
Q
;
CHG ; - Change Suspense Date action
I $$CLOSED^PSOREJP1(RX,REJ) D Q
. S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7)
;
N SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG,CUTDT,FILDT
;
S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL)
I RFL>0 S FILDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
E S FILDT=$$GET1^DIQ(52,RX,22,"I")
I SUSDT="" S VALMSG="Prescription is not suspended!",VALMBCK="R" W $C(7) Q
I $$RXRLDT^PSOBPSUT(RX,RFL) S VALMSG="Prescription has been released already!",VALMBCK="R" W $C(7) Q
D PSOL^PSSLOCK(RX) I '$G(PSOMSG) S VALMSG=$P(PSOMSG,"^",2),VALMBCK="R" W $C(7) Q
;
S ISSDT=$$GET1^DIQ(52,RX,1,"I"),EXPDT=$$GET1^DIQ(52,RX,26,"I")
S SUSRX=$O(^PS(52.5,"B",RX,0))
;
SUDT ; Asks for the new Suspense Date
S X1=FILDT,X2=+89 D C^%DTC S CUTDT=X
D FULL^VALM1 S %DT("B")=$$FMTE^XLFDT(SUSDT),%DT="EA",%DT("A")="SUSPENSE DATE: "
W ! D ^%DT I Y<0!($D(DTOUT)) D PSOUL^PSSLOCK(RX) S VALMBCK="R" Q
I Y<ISSDT D G SUDT
. W !!?5,"Suspense Date cannot be before Issue Date: ",$$FMTE^XLFDT(ISSDT),".",$C(7)
I Y>EXPDT D G SUDT
. W !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),".",$C(7)
I Y>CUTDT D G SUDT
. W !!?5,"Suspense Date cannot be after fill date plus 90 days: "_$$FMTE^XLFDT(CUTDT),".",$C(7)
S SUSDT=Y
;
N DIR,DIRUT W !
S DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A"
S DIR("A",2)=" new claim will be re-submitted to the 3rd party payer"
I $$GET1^DIQ(52.5,SUSRX,3)="" D
. I SUSDT>DT D
. . S DIR("A",3)=" when the prescription label for this fill is printed"
. . S DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"."
. . S DIR("A",5)=" "
. . S DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE"
. . S DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
. E D
. . S DIR("A",3)=" the next time local labels are printed from suspense."
E D
. I SUSDT>DT D
. . S DIR("A",3)=" when the prescription is transmitted to CMOP on "
. . S DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"."
. . S DIR("A",5)=" "
. . S DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO"
. . S DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
. E D
. . S DIR("A",3)=" when this prescription fill is transmitted to CMOP on"
. . S DIR("A",4)=" the next CMOP transmission."
;
S DIR("A",$O(DIR("A",""),-1)+1)=" "
S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" D PSOUL^PSSLOCK(RX) Q
;
; - Suspense/Fill Date updates
I SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL) D
. N DA,DIE,DR,PSOX,SFN,INDT,DEAD
. S DA=SUSRX,DIE="^PS(52.5,",DR=".02///"_SUSDT D ^DIE
. S SFN=SUSRX,DEAD=0,INDT=SUSDT D CHANGE^PSOSUCH1(RX,RFL)
;
; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense
D RETRXF^PSOREJU2(RX,RFL,1)
W ?40,"[Closing..."
D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,8,"Fill Date changed to "_$$FMTE^XLFDT(SUSDT)_". A new claim will be re-submitted on this date.")
W "OK]",!,$C(7) H 1 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
D PSOUL^PSSLOCK(RX)
Q
;
PTLBL(RX,RFL) ; Returns whether the user should be prompted for 'Print Label?' or not
N PTLBL,CMP,LBL,REPRINT
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
I $$FIND^PSOREJUT(RX,RFL) Q 0 ; Has OPEN/UNRESOLVED 3rd pary payer reject
I $$GET1^DIQ(52,RX,100,"I") Q 0 ; Rx status not ACTIVE
I $$RXRLDT^PSOBPSUT(RX,RFL),'PSOTRIC Q 0 ; Rx Released
; - CMOP Rx fill?
S PTLBL=1,CMP=0
F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D Q:'PTLBL
. I +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL S PTLBL=0
I 'PTLBL Q 0
; - Label already printed for Rx fill?
S LBL=0
F S LBL=$O(^PSRX(RX,"L",LBL)) Q:'LBL D Q:'PTLBL
. I +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL Q
. I $G(PSOTRIC)&($$RXRLDT^PSOBPSUT(RX,RFL)) S REPRINT=1 Q
. I $$GET1^DIQ(52.032,LBL_","_RX,4,"I") Q
. I $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION" Q
. S PTLBL=0
;
I PTLBL D
. N DIR,DIRUT,Y
. W ! S DIR(0)="Y",DIR("A")=$S('$G(REPRINT):"Print Label",1:"Reprint Label"),DIR("B")="YES"
. D ^DIR I $G(Y)=0!$D(DIRUT) S PTLBL=0 Q
;
Q PTLBL
;
DTRNG(BGN,END) ; Date Range Selection
;Input: (o) BGN - Default Begin Date
; (o) END - Default End Date
;
N %DT,DTOUT,DUOUT,DTRNG,X,Y
S DTRNG=""
S %DT="AEST",%DT("A")="BEGIN REJECT DATE: ",%DT("B")=$G(BGN) K:$G(BGN)="" %DT("B") D ^%DT
I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
S $P(DTRNG,U)=Y
;
W ! K %DT
S %DT="AEST",%DT("A")="END REJECT DATE: ",%DT("B")=$G(END),%DT(0)=Y K:$G(END)="" %DT("B") D ^%DT
I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^"
;
;Define Entry
S $P(DTRNG,U,2)=Y
;
Q DTRNG
PSOREJP2 ;BIRM/MFR - Third Party Rejects View/Process ;04/28/05
+1 ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289**;DEC 1997;Build 107
+2 ;Reference to ^PSSLOCK supported by IA #2789
+3 ;
+4 NEW PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT
+5 NEW PSOINFLT,PSODTRNG,PSOINGRP,PSOTRITG
+6 SET PSORJASC=1
SET PSOINGRP=0
SET PSOTRITG=1
+7 ;
+8 ; - Division/Site selection
+9 DO SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$GET(PSOSITE),.01))
IF $GET(PSOREJST)="^"
GOTO EXIT
+10 ;
+11 ; - Date range selection
+12 WRITE !
SET PSODTRNG=$$DTRNG("T-90","T")
IF PSODTRNG="^"
GOTO EXIT
+13 ;
SEL ; - Field Selection (Patient/Drug/Rx)
+1 SET DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE"
SET DIR("B")="P"
+2 SET DIR("A")="By (P)atient, (D)rug, (R)x or (I)nsurance"
DO ^DIR
IF $DATA(DIRUT)
GOTO EXIT
+3 SET PSOBYFLD=Y
SET DIR("B")=""
+4 ;
+5 IF PSOBYFLD="P"
Begin DoDot:1
+6 SET (PSODRFLT,PSORXFLT,PSOINFLT)="ALL"
SET PSORJSRT="DR"
+7 DO SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT)
End DoDot:1
IF $GET(PSOPTFLT)="^"
GOTO SEL
+8 ;
+9 IF PSOBYFLD="D"
Begin DoDot:1
+10 SET (PSOPTFLT,PSORXFLT,PSOINFLT)="ALL"
SET PSORJSRT="PA"
+11 DO SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT)
End DoDot:1
IF $GET(PSODRFLT)="^"
GOTO SEL
+12 ;
+13 IF PSOBYFLD="R"
Begin DoDot:1
+14 SET (PSOPTFLT,PSODRFLT,PSOINFLT)="ALL"
SET PSORJSRT="PA"
+15 NEW DIC,Y,X,OK
KILL PSOSTFLT,PSORXFLT
+16 SET DIC=52
SET DIC(0)="QEZA"
SET DIC("A")="PRESCRIPTION: "
+17 FOR
WRITE !
DO ^DIC
Begin DoDot:2
+18 IF $DATA(DUOUT)!$DATA(DTOUT)!(X="")
SET OK=1
QUIT
+19 IF '$ORDER(^PSRX(+Y,"REJ",0))
Begin DoDot:3
+20 WRITE !?40,"Prescription does not have rejects!",$CHAR(7)
End DoDot:3
QUIT
+21 SET PSORXFLT=+Y
SET OK=1
End DoDot:2
IF $GET(OK)
QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)!'$GET(PSORXFLT)
GOTO SEL
+22 ;
+23 IF PSOBYFLD="I"
Begin DoDot:1
+24 SET (PSOPTFLT,PSODRFLT,PSORXFLT)="ALL"
SET PSORJSRT="PA"
+25 NEW DIR,Y,X,OK
KILL PSOINFLT
WRITE !
+26 SET DIR("A",1)="Enter the whole or part of the Insurance Company"
+27 SET DIR("A",2)="name for which you want to view/process REJECTS."
+28 SET DIR("A",3)=""
+29 SET DIR(0)="FO^3:30"
SET DIR("A")=" INSURANCE"
+30 FOR
DO ^DIR
Begin DoDot:2
+31 IF $DATA(DIRUT)!(X="")
SET OK=1
QUIT
+32 SET PSOINFLT(X)=""
KILL DIR("A")
SET DIR("A")="ANOTHER ONE"
End DoDot:2
IF $GET(OK)
QUIT
End DoDot:1
IF $ORDER(PSOINFLT(""))=""
GOTO SEL
+33 ;
+34 ; - Status Selection (UNRESOLVED or RESOLVED)
+35 IF $GET(PSOSTFLT)=""
Begin DoDot:1
+36 SET DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH"
SET DIR("B")="B"
+37 SET DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses"
DO ^DIR
+38 SET PSOSTFLT=Y
End DoDot:1
IF $DATA(DIRUT)
GOTO EXIT
+39 ;
+40 DO LST^PSOREJP0("VP")
+41 ;
EXIT QUIT
+1 ;
CLO ; - Ignore a REJECT hidden action
+1 NEW PSOTRIC,X
+2 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
+3 IF $GET(PSOTRIC)
SET VALMSG="INVALID: TRICARE rejected Rxs may not be ignored."
SET VALMBCK="R"
QUIT
+4 IF $$CLOSED^PSOREJP1(RX,REJ)
Begin DoDot:1
+5 SET VALMSG="This Reject is marked resolved!"
SET VALMBCK="R"
End DoDot:1
QUIT
+6 NEW DIR,COM
+7 DO FULL^VALM1
+8 IF '$$SIG^PSOREJU1()
SET VALMBCK="R"
QUIT
+9 WRITE !
+10 SET COM=$$COM^PSOREJU1()
IF COM="^"
SET VALMBCK="R"
QUIT
+11 WRITE !
+12 SET DIR(0)="Y"
SET DIR("A")=" Confirm? "
SET DIR("B")="NO"
+13 SET DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED."
+14 SET DIR("A",2)=" "
+15 DO ^DIR
IF $GET(Y)=0!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+16 WRITE ?40,"[Closing..."
DO CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM)
WRITE "OK]",!,$CHAR(7)
HANG 1
+17 IF $DATA(PSOSTFLT)
IF PSOSTFLT'="B"
SET CHANGE=1
+18 ;
+19 IF $$PTLBL(RX,FILL)
DO PRINT^PSOREJP3(RX,FILL)
+20 ;
+21 QUIT
+22 ;
OPN ; - Re-open a Closed/Resolved Reject
+1 IF '$$CLOSED^PSOREJP1(RX,REJ)
Begin DoDot:1
+2 SET VALMSG="This Reject is NOT marked resolved!"
SET VALMBCK="R"
End DoDot:1
QUIT
+3 NEW DIR,COM,REJDATA,NEWDATA,X,REOPEN
+4 DO FULL^VALM1
+5 IF '$$SIG^PSOREJU1()
SET VALMBCK="R"
QUIT
+6 WRITE !
+7 SET DIR(0)="Y"
SET DIR("A")=" Confirm"
SET DIR("B")="NO"
+8 SET DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED."
+9 SET DIR("A",2)=" "
+10 DO ^DIR
IF $GET(Y)=0!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+11 ;
+12 WRITE ?40,"[Re-opening..."
+13 KILL REJDATA
DO GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1)
DO SETOPN^PSOREJU2(RX,REJ)
+14 KILL NEWDATA
MERGE NEWDATA=REJDATA(REJ)
SET NEWDATA("PHARMACIST")=DUZ
+15 SET REOPEN=1
DO SAVE^PSOREJUT(RX,FILL,.NEWDATA,REOPEN)
+16 IF $GET(NEWDATA("REJECT IEN"))
IF $DATA(REJDATA(REJ,"COMMENTS"))
Begin DoDot:1
+17 SET COM=0
FOR
SET COM=$ORDER(REJDATA(REJ,"COMMENTS",COM))
IF 'COM
QUIT
Begin DoDot:2
+18 SET X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS")
+19 SET X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME")
+20 SET X(3)=REJDATA(REJ,"COMMENTS",COM,"USER")
+21 DO SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3))
End DoDot:2
End DoDot:1
+22 DO RETRXF^PSOREJU2(RX,FILL,0)
+23 WRITE "OK]",!,$CHAR(7)
HANG 1
+24 SET CHANGE=1
+25 QUIT
+26 ;
CHG ; - Change Suspense Date action
+1 IF $$CLOSED^PSOREJP1(RX,REJ)
Begin DoDot:1
+2 SET VALMSG="This Reject is marked resolved!"
SET VALMBCK="R"
WRITE $CHAR(7)
End DoDot:1
QUIT
+3 ;
+4 NEW SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG,CUTDT,FILDT
+5 ;
+6 SET RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5)
SET SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL)
+7 IF RFL>0
SET FILDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I")
+8 IF '$TEST
SET FILDT=$$GET1^DIQ(52,RX,22,"I")
+9 IF SUSDT=""
SET VALMSG="Prescription is not suspended!"
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+10 IF $$RXRLDT^PSOBPSUT(RX,RFL)
SET VALMSG="Prescription has been released already!"
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+11 DO PSOL^PSSLOCK(RX)
IF '$GET(PSOMSG)
SET VALMSG=$PIECE(PSOMSG,"^",2)
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+12 ;
+13 SET ISSDT=$$GET1^DIQ(52,RX,1,"I")
SET EXPDT=$$GET1^DIQ(52,RX,26,"I")
+14 SET SUSRX=$ORDER(^PS(52.5,"B",RX,0))
+15 ;
SUDT ; Asks for the new Suspense Date
+1 SET X1=FILDT
SET X2=+89
DO C^%DTC
SET CUTDT=X
+2 DO FULL^VALM1
SET %DT("B")=$$FMTE^XLFDT(SUSDT)
SET %DT="EA"
SET %DT("A")="SUSPENSE DATE: "
+3 WRITE !
DO ^%DT
IF Y<0!($DATA(DTOUT))
DO PSOUL^PSSLOCK(RX)
SET VALMBCK="R"
QUIT
+4 IF Y<ISSDT
Begin DoDot:1
+5 WRITE !!?5,"Suspense Date cannot be before Issue Date: ",$$FMTE^XLFDT(ISSDT),".",$CHAR(7)
End DoDot:1
GOTO SUDT
+6 IF Y>EXPDT
Begin DoDot:1
+7 WRITE !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),".",$CHAR(7)
End DoDot:1
GOTO SUDT
+8 IF Y>CUTDT
Begin DoDot:1
+9 WRITE !!?5,"Suspense Date cannot be after fill date plus 90 days: "_$$FMTE^XLFDT(CUTDT),".",$CHAR(7)
End DoDot:1
GOTO SUDT
+10 SET SUSDT=Y
+11 ;
+12 NEW DIR,DIRUT
WRITE !
+13 SET DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A"
+14 SET DIR("A",2)=" new claim will be re-submitted to the 3rd party payer"
+15 IF $$GET1^DIQ(52.5,SUSRX,3)=""
Begin DoDot:1
+16 IF SUSDT>DT
Begin DoDot:2
+17 SET DIR("A",3)=" when the prescription label for this fill is printed"
+18 SET DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"."
+19 SET DIR("A",5)=" "
+20 SET DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE"
+21 SET DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
End DoDot:2
+22 IF '$TEST
Begin DoDot:2
+23 SET DIR("A",3)=" the next time local labels are printed from suspense."
End DoDot:2
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 IF SUSDT>DT
Begin DoDot:2
+26 SET DIR("A",3)=" when the prescription is transmitted to CMOP on "
+27 SET DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"."
+28 SET DIR("A",5)=" "
+29 SET DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO"
+30 SET DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"."
End DoDot:2
+31 IF '$TEST
Begin DoDot:2
+32 SET DIR("A",3)=" when this prescription fill is transmitted to CMOP on"
+33 SET DIR("A",4)=" the next CMOP transmission."
End DoDot:2
End DoDot:1
+34 ;
+35 SET DIR("A",$ORDER(DIR("A",""),-1)+1)=" "
+36 SET DIR(0)="Y"
SET DIR("A")=" Confirm? "
SET DIR("B")="YES"
+37 DO ^DIR
IF $GET(Y)=0!$DATA(DIRUT)
SET VALMBCK="R"
DO PSOUL^PSSLOCK(RX)
QUIT
+38 ;
+39 ; - Suspense/Fill Date updates
+40 IF SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL)
Begin DoDot:1
+41 NEW DA,DIE,DR,PSOX,SFN,INDT,DEAD
+42 SET DA=SUSRX
SET DIE="^PS(52.5,"
SET DR=".02///"_SUSDT
DO ^DIE
+43 SET SFN=SUSRX
SET DEAD=0
SET INDT=SUSDT
DO CHANGE^PSOSUCH1(RX,RFL)
End DoDot:1
+44 ;
+45 ; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense
+46 DO RETRXF^PSOREJU2(RX,RFL,1)
+47 WRITE ?40,"[Closing..."
+48 DO CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,8,"Fill Date changed to "_$$FMTE^XLFDT(SUSDT)_". A new claim will be re-submitted on this date.")
+49 WRITE "OK]",!,$CHAR(7)
HANG 1
IF $DATA(PSOSTFLT)
IF PSOSTFLT'="B"
SET CHANGE=1
+50 DO PSOUL^PSSLOCK(RX)
+51 QUIT
+52 ;
PTLBL(RX,RFL) ; Returns whether the user should be prompted for 'Print Label?' or not
+1 NEW PTLBL,CMP,LBL,REPRINT
+2 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC)
+3 ; Has OPEN/UNRESOLVED 3rd pary payer reject
IF $$FIND^PSOREJUT(RX,RFL)
QUIT 0
+4 ; Rx status not ACTIVE
IF $$GET1^DIQ(52,RX,100,"I")
QUIT 0
+5 ; Rx Released
IF $$RXRLDT^PSOBPSUT(RX,RFL)
IF 'PSOTRIC
QUIT 0
+6 ; - CMOP Rx fill?
+7 SET PTLBL=1
SET CMP=0
+8 FOR
SET CMP=$ORDER(^PSRX(RX,4,CMP))
IF 'CMP
QUIT
Begin DoDot:1
+9 IF +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL
SET PTLBL=0
End DoDot:1
IF 'PTLBL
QUIT
+10 IF 'PTLBL
QUIT 0
+11 ; - Label already printed for Rx fill?
+12 SET LBL=0
+13 FOR
SET LBL=$ORDER(^PSRX(RX,"L",LBL))
IF 'LBL
QUIT
Begin DoDot:1
+14 IF +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL
QUIT
+15 IF $GET(PSOTRIC)&($$RXRLDT^PSOBPSUT(RX,RFL))
SET REPRINT=1
QUIT
+16 IF $$GET1^DIQ(52.032,LBL_","_RX,4,"I")
QUIT
+17 IF $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION"
QUIT
+18 SET PTLBL=0
End DoDot:1
IF 'PTLBL
QUIT
+19 ;
+20 IF PTLBL
Begin DoDot:1
+21 NEW DIR,DIRUT,Y
+22 WRITE !
SET DIR(0)="Y"
SET DIR("A")=$SELECT('$GET(REPRINT):"Print Label",1:"Reprint Label")
SET DIR("B")="YES"
+23 DO ^DIR
IF $GET(Y)=0!$DATA(DIRUT)
SET PTLBL=0
QUIT
End DoDot:1
+24 ;
+25 QUIT PTLBL
+26 ;
DTRNG(BGN,END) ; Date Range Selection
+1 ;Input: (o) BGN - Default Begin Date
+2 ; (o) END - Default End Date
+3 ;
+4 NEW %DT,DTOUT,DUOUT,DTRNG,X,Y
+5 SET DTRNG=""
+6 SET %DT="AEST"
SET %DT("A")="BEGIN REJECT DATE: "
SET %DT("B")=$GET(BGN)
IF $GET(BGN)=""
KILL %DT("B")
DO ^%DT
+7 IF $GET(DUOUT)!$GET(DTOUT)!($GET(Y)=-1)
QUIT "^"
+8 SET $PIECE(DTRNG,U)=Y
+9 ;
+10 WRITE !
KILL %DT
+11 SET %DT="AEST"
SET %DT("A")="END REJECT DATE: "
SET %DT("B")=$GET(END)
SET %DT(0)=Y
IF $GET(END)=""
KILL %DT("B")
DO ^%DT
+12 IF $GET(DUOUT)!$GET(DTOUT)!($GET(Y)=-1)
QUIT "^"
+13 ;
+14 ;Define Entry
+15 SET $PIECE(DTRNG,U,2)=Y
+16 ;
+17 QUIT DTRNG
