PSORESK1 ;BHAM ISC/SAB - return to stock continued ;17-Jan-2014 11:18;DU
;;7.0;OUTPATIENT PHARMACY;**9,201,1018**;DEC 1997;Build 21
;IHS/MSC/MGH entry point CHECK ADDED 01/07/2014
HP W !!,"Wand the barcode number of the Rx or manually key in",!,"the number below the barcode or the Rx number."
W !,"The barcode number format is - 'NNN-NNNNNNN'",!!,"Press 'ENTER' to process Rx or ""^"" to quit"
Q
STAT S RX0=^PSRX(RXP,0),RX2=^PSRX(RXP,2),J=RXP S $P(RX0,"^",15)=$P($G(^PSRX(RXP,"STA")),"^") D ^PSOFUNC
W !!,$C(7),$C(7),"Rx status of "_ST_" and cannot be returned to stock.",! K RX0,ST Q
CP D NOW^%DTC S PSODT=%
S PSOCPRX=$P(^PSRX(RXP,0),"^") S PSO=1,PSODA=RXP,PSOPAR7=$G(^PS(59,PSOSITE,"IB")) W !!,"Attempting to remove copay charges",! D RXED^PSOCPA
I COPAYFLG=0 W !!,"Reason must be entered. Rx "_$P(^PSRX(RXP,0),"^")_" not returned to stock.",!
;PFS: send Rx info to external billing system when copay and no copay.
Q
ACT S IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I S IFN=I
I $G(PSOWHERE) S COM=$G(COM)_" (Released by CMOP)"
I +$G(PSOPFS) S:$P(PSOPFS,"^",3)'="" COM=$G(COM)_" (External Billing Charge ID: "_$P(PSOPFS,"^",3)_")"
D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^"_DUZ_"^"_$S(XTYPE="O":0,$G(TYPE)'<0&($G(TYPE)<6)&(XTYPE):TYPE,$G(TYPE)>5&(XTYPE):(TYPE+1),1:6)_"^"_COM
K DA Q
CMOP ;original released by CMOP? Called by PSORESK
S PSXREL=$P($G(^PSRX(RXP,2)),"^",13)
I $G(PSXREL),($D(^PSRX("AR",PSXREL,RXP,0))) W !!,$C(7),"Rx # "_$P(^PSRX(RXP,0),"^")_":",?20," Was dispensed by the CMOP and may not be returned"
I W !,?20," to stock at this facility." Q
K PSXREL
Q
CMOP1 ; REFILL released by CMOP? Called by PSORESK
I +$G(XTYPE) S PSXREL=$P($G(^PSRX(RXP,1,TYPE,0)),"^",18)
I $G(PSXREL),($D(^PSRX("AR",PSXREL,RXP,TYPE))) W !!,"REFILL # "_TYPE_":",?20," Was dispensed by the CMOP and may not be returned"
I W !,?20," to stock at this facility." Q
K PSXREL
Q
CHECK(RX) ;IHS/MSC/MGH Check and update the expiration date as needed
N EXP,OLDEXP,REF,REMFILL
S OLDEXP=$$GET1^DIQ(52,RX,26,"I")
S REF=$$GET1^DIQ(52,RX,9)
I REF=0 S EXP=$$CHANGE(RX) ;This is an original fill, change expiration date back after RTS
E D
.S REMFILL=$$RMNRFL^APSPFUNC(RX)
.I REMFILL>1 S EXP=OLDEXP ;There are still more refills left, keep original expiration date
.E S EXP=$$CHANGE(RX) ;One or no fills left, change expiration date back after RTS
Q EXP
CHANGE(RX) ;Change the expiration date back based on issue date and other logic
N EXPDTE,CS,DRG,EXTEXP,ISSDT
S DRG=$$GET1^DIQ(52,RX,6,"I")
S CS=$$ISSCH^APSPFNC2(DRG,"2345")
S $P(CS,U,2)=$$ISSCH^APSPFNC2(DRG,"2")
S EXTEXP=$$GET1^DIQ(50,DRG,9999999.08,"I")
S ISSDT=$$GET1^DIQ(52,RX,1,"I")
S X2=$S(EXTEXP:EXTEXP,$P(CS,U,2):184,CS:184,1:366)
S EXPDTE=$$FMADD^XLFDT(ISSDT,X2)
Q EXPDTE
PSORESK1 ;BHAM ISC/SAB - return to stock continued ;17-Jan-2014 11:18;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**9,201,1018**;DEC 1997;Build 21
+2 ;IHS/MSC/MGH entry point CHECK ADDED 01/07/2014
HP WRITE !!,"Wand the barcode number of the Rx or manually key in",!,"the number below the barcode or the Rx number."
+1 WRITE !,"The barcode number format is - 'NNN-NNNNNNN'",!!,"Press 'ENTER' to process Rx or ""^"" to quit"
+2 QUIT
STAT SET RX0=^PSRX(RXP,0)
SET RX2=^PSRX(RXP,2)
SET J=RXP
SET $PIECE(RX0,"^",15)=$PIECE($GET(^PSRX(RXP,"STA")),"^")
DO ^PSOFUNC
+1 WRITE !!,$CHAR(7),$CHAR(7),"Rx status of "_ST_" and cannot be returned to stock.",!
KILL RX0,ST
QUIT
CP DO NOW^%DTC
SET PSODT=%
+1 SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
SET PSO=1
SET PSODA=RXP
SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
WRITE !!,"Attempting to remove copay charges",!
DO RXED^PSOCPA
+2 IF COPAYFLG=0
WRITE !!,"Reason must be entered. Rx "_$PIECE(^PSRX(RXP,0),"^")_" not returned to stock.",!
+3 ;PFS: send Rx info to external billing system when copay and no copay.
+4 QUIT
ACT SET IFN=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXP,"A",I))
IF 'I
QUIT
SET IFN=I
+1 IF $GET(PSOWHERE)
SET COM=$GET(COM)_" (Released by CMOP)"
+2 IF +$GET(PSOPFS)
IF $PIECE(PSOPFS,"^",3)'=""
SET COM=$GET(COM)_" (External Billing Charge ID: "_$PIECE(PSOPFS,"^",3)_")"
+3 DO NOW^%DTC
SET IFN=IFN+1
SET ^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN
SET ^PSRX(RXP,"A",IFN,0)=%_"^I^"_DUZ_"^"_$SELECT(XTYPE="O":0,$GET(TYPE)'<0&($GET(TYPE)<6)&(XTYPE):TYPE,$GET(TYPE)>5&(XTYPE):(TYPE+1),1:6)_"^"_COM
+4 KILL DA
QUIT
CMOP ;original released by CMOP? Called by PSORESK
+1 SET PSXREL=$PIECE($GET(^PSRX(RXP,2)),"^",13)
+2 IF $GET(PSXREL)
IF ($DATA(^PSRX("AR",PSXREL,RXP,0)))
WRITE !!,$CHAR(7),"Rx # "_$PIECE(^PSRX(RXP,0),"^")_":",?20," Was dispensed by the CMOP and may not be returned"
+3 IF $TEST
WRITE !,?20," to stock at this facility."
QUIT
+4 KILL PSXREL
+5 QUIT
CMOP1 ; REFILL released by CMOP? Called by PSORESK
+1 IF +$GET(XTYPE)
SET PSXREL=$PIECE($GET(^PSRX(RXP,1,TYPE,0)),"^",18)
+2 IF $GET(PSXREL)
IF ($DATA(^PSRX("AR",PSXREL,RXP,TYPE)))
WRITE !!,"REFILL # "_TYPE_":",?20," Was dispensed by the CMOP and may not be returned"
+3 IF $TEST
WRITE !,?20," to stock at this facility."
QUIT
+4 KILL PSXREL
+5 QUIT
CHECK(RX) ;IHS/MSC/MGH Check and update the expiration date as needed
+1 NEW EXP,OLDEXP,REF,REMFILL
+2 SET OLDEXP=$$GET1^DIQ(52,RX,26,"I")
+3 SET REF=$$GET1^DIQ(52,RX,9)
+4 ;This is an original fill, change expiration date back after RTS
IF REF=0
SET EXP=$$CHANGE(RX)
+5 IF '$TEST
Begin DoDot:1
+6 SET REMFILL=$$RMNRFL^APSPFUNC(RX)
+7 ;There are still more refills left, keep original expiration date
IF REMFILL>1
SET EXP=OLDEXP
+8 ;One or no fills left, change expiration date back after RTS
IF '$TEST
SET EXP=$$CHANGE(RX)
End DoDot:1
+9 QUIT EXP
CHANGE(RX) ;Change the expiration date back based on issue date and other logic
+1 NEW EXPDTE,CS,DRG,EXTEXP,ISSDT
+2 SET DRG=$$GET1^DIQ(52,RX,6,"I")
+3 SET CS=$$ISSCH^APSPFNC2(DRG,"2345")
+4 SET $PIECE(CS,U,2)=$$ISSCH^APSPFNC2(DRG,"2")
+5 SET EXTEXP=$$GET1^DIQ(50,DRG,9999999.08,"I")
+6 SET ISSDT=$$GET1^DIQ(52,RX,1,"I")
+7 SET X2=$SELECT(EXTEXP:EXTEXP,$PIECE(CS,U,2):184,CS:184,1:366)
+8 SET EXPDTE=$$FMADD^XLFDT(ISSDT,X2)
+9 QUIT EXPDTE
