- 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
