PSORXL1 ;BIR/SAB-action to be taken on prescriptions ;29-May-2012 15:12;PLS
;;7.0;OUTPATIENT PHARMACY;**36,46,1010,148,260,274,287,289,1015**;DEC 1997;Build 62
S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
;Modified - IHS/MSC/PLS -02/10/2011 - Line SUS+6
S1 F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D
.I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q
.I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
I $G(SPPL)]"" D K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT
.W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
.I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction label!"
.S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL
S SUSPT="SUSPENSE" G D1
Q
SUS S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D Q:$G(DFLG)!($G(PSOWFLG))
.;checks to see if future fill exists
.S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG)
.K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG)
.S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0
G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK
D EN^APSPPCC1(PSODFN,RXN,1) ;IHS/MSC/PLS - 02/10/2011
I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q
LOCK I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ
S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1
.K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1
.I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN))
S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"."
S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM)
S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM
;
; - If not a PARTIAL, reverse ECME Claim, if necessary
I '$G(RXFL(RXN)) S RXFL(RXN)=$$LSTRFL^PSOBPSU1(RXN)
I '$G(RXP),'$G(PSONPROG) D REVERSE^PSOBPSU1(RXN,,"DC",3) ;PSONPROG - Tricare in progress, don't reverse
K COMM
SUSQ Q
;PSO*7*274 always recalculate RXF
ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA
S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
Q
D1 I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1
G:$D(RXRS) RXS^PSORXL
K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG
Q
WARN W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT"
S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD
I $G(RXCMOP)]"" D G WARN1
.W !!,"A partial entered for this Rx cannot be suspended."
.W !,"You may pull this fill from suspense or print the label now.",!!
.S DIR("A",2)=" ",DIR("A",3)=" Do you want to Queue to print",DIR("A")=" or Exit: "
S DIR("A",2)=" ",DIR("A",3)=" Do you want to: Suspend Partial",DIR("A",4)=" Queue to print",DIR("A")=" or Exit: "
WARN1 S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR
I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q
I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q
Q
HLP I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",!
I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense."
W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",!
W !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered."
Q
SWARN ;
S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2)
W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD
W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",!
N PSORF,PSOTRIC D TRIC(DA)
I PSOTRIC,$$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE" S PSOQFLAG=1 Q
K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR
I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ
I $G(Y)="Q" D G SWARNQ
. S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1
. S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL
. S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA))
W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1
SWARNQ ;
S DA=$G(PSORXLDA) K PSORXLDA
Q
SWARS ;
S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q
S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99)
S PSOZXFPN=$L(PSOZXFPL,PPL)-1
I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN)
K PSOZXFL,PSOZXFPL,PSOZXFPN
Q
TRIC(PSORX) ;
S PSORF=$$LSTRFL^PSOBPSU1(PSORX)
S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(PSORX,PSORF,.PSOTRIC)
Q
ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED
N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP,PSOSTA,PSOTRIC,ESTAT,EACTION
S PPLTMP=$G(PPL)
F PSOI=1:1 S PSORX=+$P($G(PPLTMP),",",PSOI) Q:'PSORX D
. D TRIC(PSORX) S ESTAT=$P($$STATUS^PSOBPSUT(PSORX,PSORF),"^")
. I PSOTRIC S EACTION=$S(ESTAT["PAYABLE":1,ESTAT["Inactive ECME Tricare":1,ESTAT="":1,1:0)
. I PSOTRIC,'EACTION,$G(PPL) D RMV(PSORX,.PPL) Q ;no labels for "In Progress" Tricare Rx's.
. I $G(PSOCKDC) D Q ;PSOCKDC variable is set in PSORXL and is used to eliminate label print for DC'ed Rx's
. . S PSOSTA=$$GET1^DIQ(52,PSORX,100,"I") I PSOSTA=12!(PSOSTA=11),'$G(RXPR(PSORX)),$G(PPL) D RMV(PSORX,.PPL)
. I $G(RXPR(PSORX)) Q
. S PSOACT="",BWH=$S(PSORF:"RF",1:"OF")
. I $$FIND^PSOREJUT(PSORX,PSORF) D I PSOACT="Q" D RMV(PSORX,.PPL) Q
. . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q")
Q
RMV(RX,PPL) ; Remove the Rx from the label print queue
N XPPL,I
S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_","
I PPL="" K PPL
Q
PSORXL1 ;BIR/SAB-action to be taken on prescriptions ;29-May-2012 15:12;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**36,46,1010,148,260,274,287,289,1015**;DEC 1997;Build 62
S SET SPPL=""
SET PPL1=1
IF '$GET(PPL)
SET PPL=$GET(PSORX("PSOL",PPL1))
IF $GET(PPL)']""
GOTO D1
+1 ;Modified - IHS/MSC/PLS -02/10/2011 - Line SUS+6
S1 FOR PI=1:1
IF $PIECE(PPL,",",PI)=""
QUIT
SET DA=$PIECE(PPL,",",PI)
Begin DoDot:1
+1 IF $PIECE(^PSRX(DA,"STA"),"^")<10
IF $PIECE(^("STA"),"^")'=4
DO SUS
QUIT
+2 IF $PIECE(^PSRX(DA,"STA"),"^")=4
SET SPPL=SPPL_DA_","
QUIT
End DoDot:1
+3 IF $GET(SPPL)]""
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"Drug Interaction Rx(s) "
FOR I=1:1
IF $PIECE(SPPL,",",I)=""
QUIT
WRITE $PIECE(^PSRX($PIECE(SPPL,",",I),0),"^")_", "
+5 IF $GET(PSOLAP)=""!($GET(PSOLAP)=$GET(ION))
WRITE !,"Label device must be selected for Drug Interaction label!"
+6 SET PPL=SPPL
SET DG=1
NEW PPL1
DO Q^PSORXL
KILL DG,SPPL
End DoDot:1
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DUOUT,DTOUT,DIRUT
+7 SET SUSPT="SUSPENSE"
GOTO D1
+8 QUIT
SUS SET ACT=1
SET RXN=DA
SET RX0=^PSRX(DA,0)
SET SD=$SELECT($GET(ZD(DA)):$EXTRACT(ZD(DA),1,7),1:$PIECE(^(3),"^"))
SET RXS=$ORDER(^PS(52.5,"B",DA,0))
IF RXS
SET RXCMOP=$PIECE($GET(^PS(52.5,RXS,0)),"^",7)
Begin DoDot:1
+1 ;checks to see if future fill exists
+2 SET PSOWFLG=0
IF '$GET(RXPR(DA))
IF $PIECE($GET(^PS(52.5,RXS,"P")),"^")=0
IF $PIECE($GET(^PSRX(DA,"STA")),"^")=5
DO SWARN
IF $GET(PSOWFLG)
QUIT
+3 KILL PSOWFLG
IF $GET(RXPR(DA))
IF '$PIECE($GET(^PS(52.5,RXS,"P")),"^")
DO WARN
IF $GET(DFLG)
QUIT
+4 SET DA=RXS
SET DIK="^PS(52.5,"
DO ^DIK
SET DA=RXN
IF $PIECE($GET(^PSRX(RXN,"STA")),"^")=5
SET $PIECE(^("STA"),"^")=0
End DoDot:1
IF $GET(DFLG)!($GET(PSOWFLG))
QUIT
+5 IF $GET(RXRP(DA))!($GET(RXPR(DA)))
GOTO LOCK
+6 ;IHS/MSC/PLS - 02/10/2011
DO EN^APSPPCC1(PSODFN,RXN,1)
+7 IF $GET(PSXSYS)
DO SUS1^PSOCMOP
IF $GET(XFLAG)=1
KILL XFLAG
QUIT
LOCK IF $PIECE($GET(^PSRX(RXN,"STA")),"^")=3
GOTO SUSQ
+1 SET RXP=+$GET(RXPR(DA))
SET DIC="^PS(52.5,"
SET DIC(0)="L"
SET X=RXN
SET DIC("DR")=".02///"_SD_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0"
KILL DD,DO
DO FILE^DICN
Begin DoDot:1
+2 KILL DD,DO
IF +Y
IF $GET(PSOEXREP)
SET $PIECE(^PS(52.5,+Y,0),"^",12)=1
+3 IF +Y
SET $PIECE(^PS(52.5,+Y,0),"^",13)=$GET(RXFL(RXN))
End DoDot:1
IF +Y
IF '$GET(RXP)
IF $GET(RXRP(RXN))
SET $PIECE(^PS(52.5,+Y,0),"^",12)=1
+4 SET $PIECE(^PSRX(RXN,"STA"),"^")=5
SET LFD=$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)
DO ACT
+5 WRITE !!,$SELECT(RXP:"Partial ",1:"")_"RX# ",$PIECE(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"."
+6 SET VALMSG=$SELECT(RXP:"Partial ",1:"")_"Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$SELECT($GET(RXRP(RXN))&('$GET(RXP)):" (Reprint)",1:"")
+7 SET COMM=$SELECT(RXP:"Partial ",1:"")_"Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$SELECT($GET(RXRP(RXN))&('$GET(RXP)):" (Reprint)",1:"")
+8 IF '$DATA(^TMP("PSORXN",$JOB,RXN))
DO EN^PSOHLSN1(RXN,"SC","ZS",COMM)
+9 IF $DATA(^TMP("PSORXN",$JOB,RXN))
SET $PIECE(^TMP("PSORXN",$JOB,RXN),"^",4)=COMM
+10 ;
+11 ; - If not a PARTIAL, reverse ECME Claim, if necessary
+12 IF '$GET(RXFL(RXN))
SET RXFL(RXN)=$$LSTRFL^PSOBPSU1(RXN)
+13 ;PSONPROG - Tricare in progress, don't reverse
IF '$GET(RXP)
IF '$GET(PSONPROG)
DO REVERSE^PSOBPSU1(RXN,,"DC",3)
+14 KILL COMM
SUSQ QUIT
+1 ;PSO*7*274 always recalculate RXF
ACT SET RXF=0
FOR I=0:0
SET I=$ORDER(^PSRX(DA,1,I))
IF 'I
QUIT
SET RXF=I
IF I>5
SET RXF=I+1
+1 SET IR=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(DA,"A",FDA))
IF 'FDA
QUIT
SET IR=FDA
+2 SET IR=IR+1
SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
+3 DO NOW^%DTC
SET ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$SELECT(RXP:"Partial ",1:"")_"RX "_$SELECT($GET(RXRP(DA))&('$GET(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD
KILL RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
+4 QUIT
D1 IF $ORDER(PSORX("PSOL",$GET(PPL1)))
SET PPL1=$ORDER(PSORX("PSOL",$GET(PPL1)))
SET PPL=PSORX("PSOL",PPL1)
GOTO S1
+1 IF $DATA(RXRS)
GOTO RXS^PSORXL
+2 KILL LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG
+3 QUIT
WARN WRITE !
KILL DIR,DIRUT,DUOUT,DTOUT,DFLG
SET Y=$PIECE(^PS(52.5,RXS,0),"^",2)
XECUTE ^DD("DD")
SET RXPD=Y
SET DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT"
+1 SET DIR("A",1)="Rx #"_$PIECE(^PSRX(DA,0),"^")_" is suspended "_$SELECT($GET(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD
+2 IF $GET(RXCMOP)]""
Begin DoDot:1
+3 WRITE !!,"A partial entered for this Rx cannot be suspended."
+4 WRITE !,"You may pull this fill from suspense or print the label now.",!!
+5 SET DIR("A",2)=" "
SET DIR("A",3)=" Do you want to Queue to print"
SET DIR("A")=" or Exit: "
End DoDot:1
GOTO WARN1
+6 SET DIR("A",2)=" "
SET DIR("A",3)=" Do you want to: Suspend Partial"
SET DIR("A",4)=" Queue to print"
SET DIR("A")=" or Exit: "
WARN1 SET DIR("B")="EXIT"
SET DIR("?")="^D HLP^PSORXL1"
DO ^DIR
KILL DIR
+1 IF Y="E"!($DATA(DIRUT))!(Y="S"&($GET(RXCMOP)]""))
SET DA(1)=DA
SET DA=RXPR(DA)
SET DIK="^PSRX("_DA(1)_",""P"","
DO ^DIK
SET ^PSRX(DA(1),"TYPE")=0
SET DFLG=1
WRITE $CHAR(7)," Partial Removed!"
QUIT
+2 IF Y="Q"
SET DPPL=PPL
SET HOLDPPL1=$GET(PPL1)
SET DPI=PI
SET RXLTOP=1
SET PPL=$GET(RXN)_","
SET PSPARTXX=1
DO Q^PSORXL
KILL PSPARTXX
SET DFLG=1
SET PPL=DPPL
SET PI=DPI
SET PPL1=$GET(HOLDPPL1)
KILL HOLDPPL1,DPPL,DPPI,DPI,RXLTOP
QUIT
+3 QUIT
HLP IF $GET(RXCMOP)']""
WRITE !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",!
+1 IF $GET(RXCMOP)]""
WRITE !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense."
+2 WRITE !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",!
+3 WRITE !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered."
+4 QUIT
SWARN ;
+1 SET PSORXLDA=$GET(DA)
SET PSORXZD=$PIECE($GET(^PS(52.5,RXS,0)),"^",2)
+2 WRITE $CHAR(7),!!,"Rx "_$PIECE($GET(^PSRX(DA,0)),"^")_" is already suspended "_$SELECT($GET(RXCMOP)]"":"for CMOP ",1:"")_"until "_$EXTRACT(PSORXZD,4,5)_"-"_$EXTRACT(PSORXZD,6,7)_"-"_$EXTRACT(PSORXZD,2,3)_"."
KILL PSORXZD
+3 WRITE !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",!
+4 NEW PSORF,PSOTRIC
DO TRIC(DA)
+5 IF PSOTRIC
IF $$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE"
SET PSOQFLAG=1
QUIT
+6 KILL DIR
SET DIR(0)="SA^Q:QUEUE;S:SUSPEND"
SET DIR("B")="Q"
SET DIR("A")="Do you want to Queue to print or Suspend Rx "_$PIECE($GET(^PSRX(DA,0)),"^")_": "
DO ^DIR
KILL DIR
+7 IF $GET(Y)="S"
KILL RXFL(PSORXLDA)
GOTO SWARNQ
+8 IF $GET(Y)="Q"
Begin DoDot:1
+9 SET PSOKSPPL=$GET(PPL)
SET PSOZXPPL=$GET(PPL1)
SET PSOZXPI=$GET(PI)
SET RXLTOP=1
+10 SET PPL=$GET(RXN)_","
DO SWARS
DO Q^PSORXL
SET PSOWFLG=1
SET PPL=PSOKSPPL
+11 SET PI=PSOZXPI
SET PPL1=PSOZXPPL
KILL PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$GET(PSORXLDA))
End DoDot:1
GOTO SWARNQ
+12 WRITE !!,"Nothing queued to print for Rx "_$PIECE($GET(^PSRX(PSORXLDA,0)),"^"),!
SET PSOWFLG=1
SWARNQ ;
+1 SET DA=$GET(PSORXLDA)
KILL PSORXLDA
+2 QUIT
SWARS ;
+1 SET PSOZXFL(PSORXLDA)=+$PIECE($GET(^PS(52.5,+$GET(RXS),0)),"^",13)
IF '$GET(PSOZXFL(PSORXLDA))
KILL PSOZXFL
QUIT
+2 SET PSOZXFPL=$PIECE(PSOKSPPL,",",+$GET(PI),99)
+3 SET PSOZXFPN=$LENGTH(PSOZXFPL,PPL)-1
+4 IF $GET(PSOZXFL(PSORXLDA))
IF $GET(PSOZXFPN)
SET RXFL(PSORXLDA)=$GET(PSOZXFL(PSORXLDA))-$GET(PSOZXFPN)
+5 KILL PSOZXFL,PSOZXFPL,PSOZXFPN
+6 QUIT
TRIC(PSORX) ;
+1 SET PSORF=$$LSTRFL^PSOBPSU1(PSORX)
+2 SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(PSORX,PSORF,.PSOTRIC)
+3 QUIT
ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED
+1 NEW PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP,PSOSTA,PSOTRIC,ESTAT,EACTION
+2 SET PPLTMP=$GET(PPL)
+3 FOR PSOI=1:1
SET PSORX=+$PIECE($GET(PPLTMP),",",PSOI)
IF 'PSORX
QUIT
Begin DoDot:1
+4 DO TRIC(PSORX)
SET ESTAT=$PIECE($$STATUS^PSOBPSUT(PSORX,PSORF),"^")
+5 IF PSOTRIC
SET EACTION=$SELECT(ESTAT["PAYABLE":1,ESTAT["Inactive ECME Tricare":1,ESTAT="":1,1:0)
+6 ;no labels for "In Progress" Tricare Rx's.
IF PSOTRIC
IF 'EACTION
IF $GET(PPL)
DO RMV(PSORX,.PPL)
QUIT
+7 ;PSOCKDC variable is set in PSORXL and is used to eliminate label print for DC'ed Rx's
IF $GET(PSOCKDC)
Begin DoDot:2
+8 SET PSOSTA=$$GET1^DIQ(52,PSORX,100,"I")
IF PSOSTA=12!(PSOSTA=11)
IF '$GET(RXPR(PSORX))
IF $GET(PPL)
DO RMV(PSORX,.PPL)
End DoDot:2
QUIT
+9 IF $GET(RXPR(PSORX))
QUIT
+10 SET PSOACT=""
SET BWH=$SELECT(PSORF:"RF",1:"OF")
+11 IF $$FIND^PSOREJUT(PSORX,PSORF)
Begin DoDot:2
+12 SET PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q")
End DoDot:2
IF PSOACT="Q"
DO RMV(PSORX,.PPL)
QUIT
End DoDot:1
+13 QUIT
RMV(RX,PPL) ; Remove the Rx from the label print queue
+1 NEW XPPL,I
+2 SET XPPL=PPL
SET PPL=""
FOR I=1:1:$LENGTH(XPPL,",")
IF $PIECE(XPPL,",",I)'=""
IF $PIECE(XPPL,",",I)'=RX
SET PPL=PPL_$PIECE(XPPL,",",I)_","
+3 IF PPL=""
KILL PPL
+4 QUIT
