APSPRIS ;IHS/MSC/PLS- Support for speed REISSUE ;10-Oct-2017 10:55;DU
;;7.0;OUTPATIENT PHARMACY;**1015,1016,1021,1022**;DEC 1997;Build 20
REISSUE ;speed REISSUE
K LST,PSORX("FILL DATE")
N APSPVAL
N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
K PSONEW,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D G:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG"))) REISSUEX
.;D ASKVAL(.APSPVAL)
.;Q:$G(APSPVAL("DFLG"))
.F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSONEW("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
..I '$P($G(^PSRX($P(PSOLST(ORN),U,2),2)),U,15) D Q
...W !!,"This prescription has not been returned to stock and is not available for reissue."
...D DIRZ^APSPUTIL("Press ENTER to exit")
..I +$G(^PSRX($P(PSOLST(ORN),U,2),"STA"))'=0 D Q
...W !!,"This prescription lacks an Active status and is not available for reissue."
...D DIRZ^APSPUTIL("Press ENTER to exit")
..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D D ULK Q
...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
...D:$G(PSONEW("QFLG")) ULK
..D RIS($P(PSOLST(ORN),U,2))
..D ULK
S:'$G(PSOOELSE) VALMBCK=""
S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1
REISSUEX D EX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE S:'$D(VALMBCK) VALMBCK="R"
K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
Q
;
ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
Q
;
ULP D ULP^PSOHLD
Q
RIS(DA) ;EP-
D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT,PSLST,PSORXED
N RXREF,UPDATE,FLDS,CHGNDC,AO
N APSPRCHK,APSPRFLG S APSPRCHK=0,APSPRFLG=0
;S DIE="^PSRX("
;S DR="22///^S X=APSPVAL(""FILL DATE"");Q;"
;D ^DIE
S PSORXED("IRXN")=DA
D ASKVAL(.PSORXED,DA)
Q:$G(PSORXED("DFLG"))
Q:'$$ESIG^APSPFUNC ;P1016
;S PSORXED("FLD",22)=PSORXED("FILL DATE")
D NDCCH(PSORXED("IRXN"))
D BLDFLD(.PSORXED)
S APSPREIS=1
;IHS/MSC/MGH added from PSOORED6
I $D(^PSRX(PSORXED("IRXN"),1,0)) D
.S RXREF=$P(^PSRX(PSORXED("IRXN"),0),U,9)-$P(^PSRX(PSORXED("IRXN"),1,0),U,4)
E S RXREF=0
S POERR=1
D UPDATE1^PSOORED6
;P1021 - Call Suspend function if auto suspend is true
D CHKSUSP
;I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
;.N DA,RXFL
;.S DA=PSORXED("IRXN")
;.S RXFL(DA)=0
;.D SUS^PSORXL
D COSTSAVE(PSORXED("IRXN"),PSORXED("COST"))
D BCK1^PSORXRPT
M PSLST=LST
K ^PSRX(PSORXED("IRXN"),999999911) ;1015-Remove PCC Link
;IHS/MSC/MGH added from PSODISPS
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D S VALMBCK="" G EX
.W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
D OERR1^PSODISPS
Q
EX ;D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
D ^PSOBUILD
K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q
K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
;
; Ask user for values
ASKVAL(APSPVAL,RXIEN) ;EP-
N DATAARY,DIR,PSOID,PSOEDIT
S PSOEDIT=1
S (DATAARY("DFLG"),DATAARY("QFLG"))=0
S DATAARY("FIELD")=0
S DATAARY("DAYS SUPPLY")=$P($G(^PSRX(RXIEN,0)),U,8)
S DATAARY("# OF REFILLS")=$P($G(^PSRX(RXIEN,0)),U,9)
S PSOID=$P($G(^PSRX(RXIEN,0)),U,13)
S DATAARY("CS")=$$ISSCH^APSPFNC2($P($G(^PSRX(RXIEN,0)),U,6),"2345")
D PHNAME(.APSPVAL) ;P1016
Q:APSPVAL("DFLG")=1 ;P1016
D FILLDT^PSODIR2(.DATAARY)
I $G(DATAARY("DFLG")) S APSPVAL("DFLG")=1 Q
S APSPVAL("FILL DATE")=DATAARY("FILL DATE")
D ASKNEWV(.DATAARY) ;P1021
I $G(DATAARY("DFLG")) S APSPVAL("DFLG")=1 Q
I $D(DATAARY("MAIL/WINDOW")) S APSPVAL("MAIL/WINDOW")=DATAARY("MAIL/WINDOW")
I $D(DATAARY("EXPIRATION DATE")) S APSPVAL("EXPIRATION DATE")=DATAARY("EXPIRATION DATE")
I $D(DATAARY("BST")) S APSPVAL("BST")=DATAARY("BST")
I $D(DATAARY("NDC")) S APSPVAL("NDC")=DATAARY("NDC")
I $D(DATAARY("AWP")) S APSPVAL("AWP")=DATAARY("AWP")
I $D(DATAARY("COST")) S APSPVAL("COST")=DATAARY("COST")
I $D(DATAARY("INSURER")) S APSPVAL("INSURER")=DATAARY("INSURER")
I $D(DATAARY("DUR")) S APSPVAL("DUR")=DATAARY("DUR")
I $D(DATAARY("METHOD OF PICK-UP")) S APSPVAL("METHOD OF PICK-UP")=DATAARY("METHOD OF PICK-UP")
Q
;
ASKNEWV(DATAARY) ;EP - 03/28/2016
S DATAARY("MAIL/WINDOW")=$P($G(^PSRX(RXIEN,0)),U,11)
D MW^PSODIR2(.DATAARY)
Q:$G(DATAARY("DFLG"))
;D CLERK^PSODIR2(.DATAARY)
;Q:$G(DATAARY("DFLG"))
;IHS/MSC/PLS - 10/10/2017 P1022 Changed to grab the drug expiration date field
;S DATAARY("EXPIRATION DATE")=$P($G(^PSRX(RXIEN,2)),U,6)
S DATAARY("EXPIRATION DATE")=$P($G(^PSRX(RXIEN,2)),U,11)
D EXP^PSODIR2(.DATAARY)
Q:$G(DATAARY("DFLG"))
I $G(PSOBILST) D
.D BST^APSPDIR(.DATAARY)
.Q:$G(DATAARY("DFLG"))
.S DATAARY("INSURER")=$P($G(^PSRX(RXIEN,9999999)),U,12)
.S DATAARY("DUR")=$P($G(^PSRX(RXIEN,9999999)),U,13)
.D INSURER^APSPDIR(.DATAARY)
Q:$G(DATAARY("DFLG"))
I $G(PSONDC) D
.S DATAARY("NDC")=$P($G(^PSRX(RXIEN,2)),U,7)
.D NDC^APSPDIR(.DATAARY)
Q:$G(DATAARY("DFLG"))
S DATAARY("AWP")=$P($G(^PSRX(RXIEN,9999999)),U,6)
D AWP^APSPDIR(.DATAARY)
Q:$G(DATAARY("DFLG"))
S DATAARY("COST")=$P($G(^PSRX(RXIEN,0)),U,17)
D COST(.DATAARY)
Q
PHNAME(APSPVAL) ;Get pharmacist
PHNAME1 S APSPVAL("DFLG")=0
S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM"
D ^DIC G:$L(X)=0 PHNAME1 K DIC
I X="^"!($D(DTOUT))!($D(DUOUT))!($D(DIRUT))!(Y=-1) S APSPVAL("DFLG")=1
E S PSRH=+Y
Q
RI ;EP- Called from APSP REISSUE protocol
N POERR,PSORXED
N RXREF,UPDATE,FLDS,CHGNDC,APSPVAK,APSPVAL
N APSPRCHK,APSPRFLG S APSPRCHK=0,APSPRFLG=0
I +PSOLST(ORN)'=52 D Q
.W !!,"A prescription entry was not selected."
.D DIRZ^APSPUTIL("Press ENTER to exit")
S PSORXED("IRXN")=$P(PSOLST(ORN),U,2)
I '$P($G(^PSRX(PSORXED("IRXN"),2)),U,15) D Q
.W !!,"This order has not been returned to stock and is not available for reissue."
.D DIRZ^APSPUTIL("Press ENTER to exit")
I +$G(^PSRX(PSORXED("IRXN"),"STA"))'=0 D Q
.W !!,"This prescription lacks an Active status and is not available for reissue."
.D DIRZ^APSPUTIL("Press ENTER to exit")
S PSORXED("DFLG")=0
D ASKVAL(.PSORXED,PSORXED("IRXN"))
;D PHNAME(.APSPVAL) ;p1016
;I APSPVAL("DFLG") S VALMBCK="R" Q ;P1016
;D FILLDT^PSODIR2(.PSORXED)
I PSORXED("DFLG") S VALMBCK="R" Q
Q:'$$ESIG^APSPFUNC ;P1016
D NDCCH($P(PSOLST(ORN),U,2))
D BLDFLD(.PSORXED)
S APSPREIS=1
;IHS/MSC/MGH added from PSOORED6
I $D(^PSRX(PSORXED("IRXN"),1,0)) D
.S RXREF=$P(^PSRX(PSORXED("IRXN"),0),"^",9)-$P(^PSRX(PSORXED("IRXN"),1,0),"^",4)
E S RXREF=0
D UPDATE1^PSOORED6
D CHKSUSP
;I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
;.N DA,RXFL
;.S DA=PSORXED("IRXN")
;.S RXFL(DA)=0
;.D SUS^PSORXL
D COSTSAVE(PSORXED("IRXN"),PSORXED("COST"))
S POERR=1 D BCK1^PSORXRPT ;P1016
K ^PSRX(PSORXED("IRXN"),999999911) ;1015-Remove PCC Link
;IHS/MSC/MGH Added from PSODISPS
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! S VALMBCK="" Q
S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D S VALMBCK="" G EX
.W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2),RXP=$P(PSOLST($P(PSLST,",",ORD)),"^",2)
D OERR1^PSODISPS
Q
NDCCH(RX) ;Check and see if the NDC changed since RX written
N RXDRG,RXNDC,DRNDC,AWP,COST,FDA,ERR,MESS
S DRNDC=""
S RXDRG=$$GET1^DIQ(52,RX,6,"I")
S RXNDC=$$GET1^DIQ(52,RX,27,"I")
I +RXDRG S DRNDC=$$GET1^DIQ(50,RXDRG,31,"I")
;NDC code has changed, then update the cost as well.
I RXNDC'=DRNDC D
.S AWP=$$AWP^APSQDAWP(DRNDC,RXDRG,.MESS)
.S COST=$$COST^APSQDAWP(DRNDC,RXDRG,.MESS)
.S FDA=$NA(FDA(52,RX_","))
.S @FDA@(27)=DRNDC
.S @FDA@(17)=COST
.S @FDA@(9999999.06)=AWP
.D UPDATE^DIE(,"FDA",,"ERR")
Q
BLDFLD(ARY) ;EP-
S:$D(ARY("FILL DATE")) ARY("FLD",22)=ARY("FILL DATE")
S:$D(ARY("MAIL/WINDOW")) ARY("FLD",11)=ARY("MAIL/WINDOW")
S:$D(ARY("METHOD OF PICK-UP")) ARY("FLD",35)=ARY("METHOD OF PICK-UP")
S:$D(ARY("AWP")) ARY("FLD",9999999.06)=ARY("AWP")
S:$D(ARY("COST")) ARY("FLD",17)=ARY("COST")
;IHS/MSC/PLS - 10/2/2017 - P1022
;S:$D(ARY("EXPIRATION DATE")) ARY("FLD",26)=ARY("EXPIRATION DATE")
S:$D(ARY("EXPIRATION DATE")) ARY("FLD",29)=ARY("EXPIRATION DATE")
S:$D(ARY("NDC")) ARY("FLD",27)=ARY("NDC")
S:$D(ARY("BST")) ARY("FLD",9999999.07)=ARY("BST")
S:$D(ARY("DUR")) ARY("FLD",9999999.13)=ARY("DUR")
S:$D(ARY("INSURER")) ARY("FLD",9999999.12)=ARY("INSURER")
Q
COST(PSODIR) ;EP-
N DIR,DIC,U
S DIR(0)="52,17"
S DIR("A")="UNIT PRICE OF DRUG"
S DIR("B")=$S($D(PSODIR("COST")):PSODIR("COST"),1:0)
D DIR^PSODIR1
I 'PSODIR("DFLG") S PSODIR("COST")=Y
Q
COSTSAVE(RX,VAL) ;EP- Update UNIT PRICE OF DRUG field based on user input
N DA,DIE,X,DR,DIR
S DA=RX
S DIE="^PSRX("
S DR="17////"_VAL
D ^DIE
Q
CHKSUSP ;EP-P1021 - Call Suspend function if auto suspend is true
I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
.N DA,RXFL
.S DA=PSORXED("IRXN")
.S RXFL(DA)=0
.D SUS^PSORXL
Q
APSPRIS ;IHS/MSC/PLS- Support for speed REISSUE ;10-Oct-2017 10:55;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**1015,1016,1021,1022**;DEC 1997;Build 20
REISSUE ;speed REISSUE
+1 KILL LST,PSORX("FILL DATE")
+2 NEW APSPVAL
+3 NEW VALMCNT
IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+4 KILL PSONEW,PSOFDR,DIR,DUOUT,DIRUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DUOUT
SET VALMBCK=""
QUIT
+5 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
IF +Y
SET (SPEED,PSOOELSE)=1
DO FULL^VALM1
SET LST=Y
Begin DoDot:1
+6 ;D ASKVAL(.APSPVAL)
+7 ;Q:$G(APSPVAL("DFLG"))
+8 FOR ORD=1:1:$LENGTH(LST,",")
IF $PIECE(LST,",",ORD)']""!($GET(PSONEW("QFLG")))
QUIT
SET ORN=$PIECE(LST,",",ORD)
IF +PSOLST(ORN)=52
Begin DoDot:2
+9 IF '$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),U,2),2)),U,15)
Begin DoDot:3
+10 WRITE !!,"This prescription has not been returned to stock and is not available for reissue."
+11 DO DIRZ^APSPUTIL("Press ENTER to exit")
End DoDot:3
QUIT
+12 IF +$GET(^PSRX($PIECE(PSOLST(ORN),U,2),"STA"))'=0
Begin DoDot:3
+13 WRITE !!,"This prescription lacks an Active status and is not available for reissue."
+14 DO DIRZ^APSPUTIL("Press ENTER to exit")
End DoDot:3
QUIT
+15 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
WRITE $CHAR(7),!!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")),!
DO PAUSE^VALM1
KILL PSOMSG
QUIT
+16 IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=11
Begin DoDot:3
+17 WRITE $CHAR(7),!!?5,"RX "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status."
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
QUIT
+18 IF $GET(PSONEW("QFLG"))
DO ULK
End DoDot:3
DO ULK
QUIT
+19 DO RIS($PIECE(PSOLST(ORN),U,2))
+20 DO ULK
End DoDot:2
End DoDot:1
IF $GET(PSONEW("DFLG"))!($GET(PSONEW("QFLG")))
GOTO REISSUEX
+21 IF '$GET(PSOOELSE)
SET VALMBCK=""
+22 SET PSORXED=1
DO ^PSOBUILD
DO BLD^PSOORUT1
REISSUEX DO EX
KILL PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE")
+1 KILL LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE
IF '$DATA(VALMBCK)
SET VALMBCK="R"
+2 KILL PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+3 QUIT
+4 ;
ULK DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+1 QUIT
+2 ;
ULP DO ULP^PSOHLD
+1 QUIT
RIS(DA) ;EP-
+1 DO FULL^VALM1
KILL DIR,DTOUT,DUOUT,DIRUT,PSLST,PSORXED
+2 NEW RXREF,UPDATE,FLDS,CHGNDC,AO
+3 NEW APSPRCHK,APSPRFLG
SET APSPRCHK=0
SET APSPRFLG=0
+4 ;S DIE="^PSRX("
+5 ;S DR="22///^S X=APSPVAL(""FILL DATE"");Q;"
+6 ;D ^DIE
+7 SET PSORXED("IRXN")=DA
+8 DO ASKVAL(.PSORXED,DA)
+9 IF $GET(PSORXED("DFLG"))
QUIT
+10 ;P1016
IF '$$ESIG^APSPFUNC
QUIT
+11 ;S PSORXED("FLD",22)=PSORXED("FILL DATE")
+12 DO NDCCH(PSORXED("IRXN"))
+13 DO BLDFLD(.PSORXED)
+14 SET APSPREIS=1
+15 ;IHS/MSC/MGH added from PSOORED6
+16 IF $DATA(^PSRX(PSORXED("IRXN"),1,0))
Begin DoDot:1
+17 SET RXREF=$PIECE(^PSRX(PSORXED("IRXN"),0),U,9)-$PIECE(^PSRX(PSORXED("IRXN"),1,0),U,4)
End DoDot:1
+18 IF '$TEST
SET RXREF=0
+19 SET POERR=1
+20 DO UPDATE1^PSOORED6
+21 ;P1021 - Call Suspend function if auto suspend is true
+22 DO CHKSUSP
+23 ;I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
+24 ;.N DA,RXFL
+25 ;.S DA=PSORXED("IRXN")
+26 ;.S RXFL(DA)=0
+27 ;.D SUS^PSORXL
+28 DO COSTSAVE(PSORXED("IRXN"),PSORXED("COST"))
+29 DO BCK1^PSORXRPT
+30 MERGE PSLST=LST
+31 ;1015-Remove PCC Link
KILL ^PSRX(PSORXED("IRXN"),999999911)
+32 ;IHS/MSC/MGH added from PSODISPS
+33 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use the Release option!",!
SET VALMBCK=""
QUIT
+34 SET VALMBCK="Q"
SET Y=$GET(^PS(59,PSOSITE,"IB"))
SET PSOIBSS=$$SERV^IBARX1(+Y)
IF 'PSOIBSS
DO IBSSR^PSOUTL
IF 'PSOIBFL
Begin DoDot:1
+35 WRITE $CHAR(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
End DoDot:1
SET VALMBCK=""
GOTO EX
+36 WRITE !!
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
SET RXP=$PIECE(PSOLST($PIECE(PSLST,",",ORD)),"^",2)
+37 DO OERR1^PSODISPS
+38 QUIT
EX ;D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
+1 DO ^PSOBUILD
+2 KILL PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG
+3 KILL HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ
QUIT
+4 KILL PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+5 ;
+6 ; Ask user for values
ASKVAL(APSPVAL,RXIEN) ;EP-
+1 NEW DATAARY,DIR,PSOID,PSOEDIT
+2 SET PSOEDIT=1
+3 SET (DATAARY("DFLG"),DATAARY("QFLG"))=0
+4 SET DATAARY("FIELD")=0
+5 SET DATAARY("DAYS SUPPLY")=$PIECE($GET(^PSRX(RXIEN,0)),U,8)
+6 SET DATAARY("# OF REFILLS")=$PIECE($GET(^PSRX(RXIEN,0)),U,9)
+7 SET PSOID=$PIECE($GET(^PSRX(RXIEN,0)),U,13)
+8 SET DATAARY("CS")=$$ISSCH^APSPFNC2($PIECE($GET(^PSRX(RXIEN,0)),U,6),"2345")
+9 ;P1016
DO PHNAME(.APSPVAL)
+10 ;P1016
IF APSPVAL("DFLG")=1
QUIT
+11 DO FILLDT^PSODIR2(.DATAARY)
+12 IF $GET(DATAARY("DFLG"))
SET APSPVAL("DFLG")=1
QUIT
+13 SET APSPVAL("FILL DATE")=DATAARY("FILL DATE")
+14 ;P1021
DO ASKNEWV(.DATAARY)
+15 IF $GET(DATAARY("DFLG"))
SET APSPVAL("DFLG")=1
QUIT
+16 IF $DATA(DATAARY("MAIL/WINDOW"))
SET APSPVAL("MAIL/WINDOW")=DATAARY("MAIL/WINDOW")
+17 IF $DATA(DATAARY("EXPIRATION DATE"))
SET APSPVAL("EXPIRATION DATE")=DATAARY("EXPIRATION DATE")
+18 IF $DATA(DATAARY("BST"))
SET APSPVAL("BST")=DATAARY("BST")
+19 IF $DATA(DATAARY("NDC"))
SET APSPVAL("NDC")=DATAARY("NDC")
+20 IF $DATA(DATAARY("AWP"))
SET APSPVAL("AWP")=DATAARY("AWP")
+21 IF $DATA(DATAARY("COST"))
SET APSPVAL("COST")=DATAARY("COST")
+22 IF $DATA(DATAARY("INSURER"))
SET APSPVAL("INSURER")=DATAARY("INSURER")
+23 IF $DATA(DATAARY("DUR"))
SET APSPVAL("DUR")=DATAARY("DUR")
+24 IF $DATA(DATAARY("METHOD OF PICK-UP"))
SET APSPVAL("METHOD OF PICK-UP")=DATAARY("METHOD OF PICK-UP")
+25 QUIT
+26 ;
ASKNEWV(DATAARY) ;EP - 03/28/2016
+1 SET DATAARY("MAIL/WINDOW")=$PIECE($GET(^PSRX(RXIEN,0)),U,11)
+2 DO MW^PSODIR2(.DATAARY)
+3 IF $GET(DATAARY("DFLG"))
QUIT
+4 ;D CLERK^PSODIR2(.DATAARY)
+5 ;Q:$G(DATAARY("DFLG"))
+6 ;IHS/MSC/PLS - 10/10/2017 P1022 Changed to grab the drug expiration date field
+7 ;S DATAARY("EXPIRATION DATE")=$P($G(^PSRX(RXIEN,2)),U,6)
+8 SET DATAARY("EXPIRATION DATE")=$PIECE($GET(^PSRX(RXIEN,2)),U,11)
+9 DO EXP^PSODIR2(.DATAARY)
+10 IF $GET(DATAARY("DFLG"))
QUIT
+11 IF $GET(PSOBILST)
Begin DoDot:1
+12 DO BST^APSPDIR(.DATAARY)
+13 IF $GET(DATAARY("DFLG"))
QUIT
+14 SET DATAARY("INSURER")=$PIECE($GET(^PSRX(RXIEN,9999999)),U,12)
+15 SET DATAARY("DUR")=$PIECE($GET(^PSRX(RXIEN,9999999)),U,13)
+16 DO INSURER^APSPDIR(.DATAARY)
End DoDot:1
+17 IF $GET(DATAARY("DFLG"))
QUIT
+18 IF $GET(PSONDC)
Begin DoDot:1
+19 SET DATAARY("NDC")=$PIECE($GET(^PSRX(RXIEN,2)),U,7)
+20 DO NDC^APSPDIR(.DATAARY)
End DoDot:1
+21 IF $GET(DATAARY("DFLG"))
QUIT
+22 SET DATAARY("AWP")=$PIECE($GET(^PSRX(RXIEN,9999999)),U,6)
+23 DO AWP^APSPDIR(.DATAARY)
+24 IF $GET(DATAARY("DFLG"))
QUIT
+25 SET DATAARY("COST")=$PIECE($GET(^PSRX(RXIEN,0)),U,17)
+26 DO COST(.DATAARY)
+27 QUIT
PHNAME(APSPVAL) ;Get pharmacist
PHNAME1 SET APSPVAL("DFLG")=0
+1 SET DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
SET DIC("A")="Enter PHARMACIST: "
SET DIC="^VA(200,"
SET DIC(0)="QEAM"
+2 DO ^DIC
IF $LENGTH(X)=0
GOTO PHNAME1
KILL DIC
+3 IF X="^"!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))!(Y=-1)
SET APSPVAL("DFLG")=1
+4 IF '$TEST
SET PSRH=+Y
+5 QUIT
RI ;EP- Called from APSP REISSUE protocol
+1 NEW POERR,PSORXED
+2 NEW RXREF,UPDATE,FLDS,CHGNDC,APSPVAK,APSPVAL
+3 NEW APSPRCHK,APSPRFLG
SET APSPRCHK=0
SET APSPRFLG=0
+4 IF +PSOLST(ORN)'=52
Begin DoDot:1
+5 WRITE !!,"A prescription entry was not selected."
+6 DO DIRZ^APSPUTIL("Press ENTER to exit")
End DoDot:1
QUIT
+7 SET PSORXED("IRXN")=$PIECE(PSOLST(ORN),U,2)
+8 IF '$PIECE($GET(^PSRX(PSORXED("IRXN"),2)),U,15)
Begin DoDot:1
+9 WRITE !!,"This order has not been returned to stock and is not available for reissue."
+10 DO DIRZ^APSPUTIL("Press ENTER to exit")
End DoDot:1
QUIT
+11 IF +$GET(^PSRX(PSORXED("IRXN"),"STA"))'=0
Begin DoDot:1
+12 WRITE !!,"This prescription lacks an Active status and is not available for reissue."
+13 DO DIRZ^APSPUTIL("Press ENTER to exit")
End DoDot:1
QUIT
+14 SET PSORXED("DFLG")=0
+15 DO ASKVAL(.PSORXED,PSORXED("IRXN"))
+16 ;D PHNAME(.APSPVAL) ;p1016
+17 ;I APSPVAL("DFLG") S VALMBCK="R" Q ;P1016
+18 ;D FILLDT^PSODIR2(.PSORXED)
+19 IF PSORXED("DFLG")
SET VALMBCK="R"
QUIT
+20 ;P1016
IF '$$ESIG^APSPFUNC
QUIT
+21 DO NDCCH($PIECE(PSOLST(ORN),U,2))
+22 DO BLDFLD(.PSORXED)
+23 SET APSPREIS=1
+24 ;IHS/MSC/MGH added from PSOORED6
+25 IF $DATA(^PSRX(PSORXED("IRXN"),1,0))
Begin DoDot:1
+26 SET RXREF=$PIECE(^PSRX(PSORXED("IRXN"),0),"^",9)-$PIECE(^PSRX(PSORXED("IRXN"),1,0),"^",4)
End DoDot:1
+27 IF '$TEST
SET RXREF=0
+28 DO UPDATE1^PSOORED6
+29 DO CHKSUSP
+30 ;I PSORXED("FILL DATE")>DT,$P(PSOPAR,U,6) D
+31 ;.N DA,RXFL
+32 ;.S DA=PSORXED("IRXN")
+33 ;.S RXFL(DA)=0
+34 ;.D SUS^PSORXL
+35 DO COSTSAVE(PSORXED("IRXN"),PSORXED("COST"))
+36 ;P1016
SET POERR=1
DO BCK1^PSORXRPT
+37 ;1015-Remove PCC Link
KILL ^PSRX(PSORXED("IRXN"),999999911)
+38 ;IHS/MSC/MGH Added from PSODISPS
+39 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use the Release option!",!
SET VALMBCK=""
QUIT
+40 SET VALMBCK="Q"
SET Y=$GET(^PS(59,PSOSITE,"IB"))
SET PSOIBSS=$$SERV^IBARX1(+Y)
IF 'PSOIBSS
DO IBSSR^PSOUTL
IF 'PSOIBFL
Begin DoDot:1
+41 WRITE $CHAR(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
End DoDot:1
SET VALMBCK=""
GOTO EX
+42 WRITE !!
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
SET RXP=$PIECE(PSOLST($PIECE(PSLST,",",ORD)),"^",2)
+43 DO OERR1^PSODISPS
+44 QUIT
NDCCH(RX) ;Check and see if the NDC changed since RX written
+1 NEW RXDRG,RXNDC,DRNDC,AWP,COST,FDA,ERR,MESS
+2 SET DRNDC=""
+3 SET RXDRG=$$GET1^DIQ(52,RX,6,"I")
+4 SET RXNDC=$$GET1^DIQ(52,RX,27,"I")
+5 IF +RXDRG
SET DRNDC=$$GET1^DIQ(50,RXDRG,31,"I")
+6 ;NDC code has changed, then update the cost as well.
+7 IF RXNDC'=DRNDC
Begin DoDot:1
+8 SET AWP=$$AWP^APSQDAWP(DRNDC,RXDRG,.MESS)
+9 SET COST=$$COST^APSQDAWP(DRNDC,RXDRG,.MESS)
+10 SET FDA=$NAME(FDA(52,RX_","))
+11 SET @FDA@(27)=DRNDC
+12 SET @FDA@(17)=COST
+13 SET @FDA@(9999999.06)=AWP
+14 DO UPDATE^DIE(,"FDA",,"ERR")
End DoDot:1
+15 QUIT
BLDFLD(ARY) ;EP-
+1 IF $DATA(ARY("FILL DATE"))
SET ARY("FLD",22)=ARY("FILL DATE")
+2 IF $DATA(ARY("MAIL/WINDOW"))
SET ARY("FLD",11)=ARY("MAIL/WINDOW")
+3 IF $DATA(ARY("METHOD OF PICK-UP"))
SET ARY("FLD",35)=ARY("METHOD OF PICK-UP")
+4 IF $DATA(ARY("AWP"))
SET ARY("FLD",9999999.06)=ARY("AWP")
+5 IF $DATA(ARY("COST"))
SET ARY("FLD",17)=ARY("COST")
+6 ;IHS/MSC/PLS - 10/2/2017 - P1022
+7 ;S:$D(ARY("EXPIRATION DATE")) ARY("FLD",26)=ARY("EXPIRATION DATE")
+8 IF $DATA(ARY("EXPIRATION DATE"))
SET ARY("FLD",29)=ARY("EXPIRATION DATE")
+9 IF $DATA(ARY("NDC"))
SET ARY("FLD",27)=ARY("NDC")
+10 IF $DATA(ARY("BST"))
SET ARY("FLD",9999999.07)=ARY("BST")
+11 IF $DATA(ARY("DUR"))
SET ARY("FLD",9999999.13)=ARY("DUR")
+12 IF $DATA(ARY("INSURER"))
SET ARY("FLD",9999999.12)=ARY("INSURER")
+13 QUIT
COST(PSODIR) ;EP-
+1 NEW DIR,DIC,U
+2 SET DIR(0)="52,17"
+3 SET DIR("A")="UNIT PRICE OF DRUG"
+4 SET DIR("B")=$SELECT($DATA(PSODIR("COST")):PSODIR("COST"),1:0)
+5 DO DIR^PSODIR1
+6 IF 'PSODIR("DFLG")
SET PSODIR("COST")=Y
+7 QUIT
COSTSAVE(RX,VAL) ;EP- Update UNIT PRICE OF DRUG field based on user input
+1 NEW DA,DIE,X,DR,DIR
+2 SET DA=RX
+3 SET DIE="^PSRX("
+4 SET DR="17////"_VAL
+5 DO ^DIE
+6 QUIT
CHKSUSP ;EP-P1021 - Call Suspend function if auto suspend is true
+1 IF PSORXED("FILL DATE")>DT
IF $PIECE(PSOPAR,U,6)
Begin DoDot:1
+2 NEW DA,RXFL
+3 SET DA=PSORXED("IRXN")
+4 SET RXFL(DA)=0
+5 DO SUS^PSORXL
End DoDot:1
+6 QUIT
