APSPFNC3 ;IHS/MSC/PLS - auto return to stock/delete support ;21-Aug-2008 14:57;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1007**;Sep 23, 2004
; IHS/MSC/PLS - 08/21/08 - Added additional parameter to CALLPOS calls
;Code copied from PSORXDL
EN(DA) ; EP
N PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF,RXP
N PSDEL,PSOXXDEL,PS,RXN,PSOPLCK,PSOMSG,COM
N PSORXDFN,REL,PSOGGFL,PSOGG,PSOXYZF,X,Y,Z,DFN,I,PKI1
N PSODEF
S (PSDEL,PSOXXDEL)=1,PS="DELETE"
S RXN=+$G(DA)
S PSORXDFN=+$P($G(^PSRX(RXN,0)),U,2)
S PSOPLCK=$$L^PSSLOCK(PSORXDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY Q
D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) D Q
.W !,$S($P($G(PSOMSG),U,2)'="":$P($G(PSOMSG),U,2),1:"Another person is editing this order."),!
.D ULP
S (REL,PSOGGFL)=0
F PSOGG=0:0 S PSOGG=$O(^PSRX(DA,1,PSOGG)) Q:'PSOGG S:$D(^PSRX(DA,1,PSOGG,0)) PSOGGFL=PSOGG
S REL=$S($G(PSOGGFL)&($P($G(^PSRX(DA,1,+$G(PSOGGFL),0)),U,18))&('$P($G(^(0)),U,16)):1,'$G(PSOGGFL)&($P($G(^PSRX(DA,2)),U,13))&('$P($G(^(2)),U,15)):1,1:0)
PASS ;N PSORXDAC K PSOXYZF S PSORXDAC=$O(^PS(52.5,"B",DA,0)) I PSORXDAC,$P($G(^PS(52.5,PSORXDAC,0)),U,7)="L" N PSOXYZ S PSOXYZF=0 W !!,"Please wait, Rx is Loading for CMOP Transmission.." D
;.F PSOXYZ=1:1:5 W "." H 1 I $P($G(^PS(52.5,PSORXDAC,0)),U,7)'="L" S PSOXYZF=1
;I $G(PSOXYZF)=0 W !!,"Sorry, still loading for CMOP transmission, try again later.",! D ULK,ULP,KILL K PSOXYZF G PSORXDL
I $G(REL) S PSOHLRE=REL,PSOHLDAH=$G(DA)
I $G(REL) S RXP=DA S PSODEFLG=0 D RESK I $G(PSODEFLG) D ULK,ULP,KILL Q
S:$G(PSOHLRE) DA=$G(PSOHLDAH),REL=$G(PSOHLRE)
S PSONOOR="S" ; Service Corrected
I $G(PKI1) N INCOM S INCOM="Per Pharmacy Request" D DCV^PSOPKIV1,ULK,ULP Q
ENQ S PSOIB=$S($D(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0) ;Check if copay
S RX=^PSRX(DA,0),RXN=DA
S $P(^PSRX(RXN,"STA"),U)=13,$P(^PSRX(RXN,"D"),U)=$G(Y)
S DA=RXN K ^PSRX("ACP",$P(^PSRX(DA,0),U,2),+$P(^(2),U,2),0,DA) D ACT
S DA=RXN I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",+$P(^PSRX(DA,"H"),U),DA) S ^PSRX(DA,"H")=""
D EN^PSOHLSN1(DA,"OC","",$P(^PSRX(DA,"D"),U),PSONOOR)
S DA=$O(^PS(52.5,"B",RXN,0)) I DA S DIK="^PS(52.5," D ^DIK
S DA=RXN I $D(^PS(52.4,RXN)) S DIK="^PS(52.4," D ^DIK
K PSOABCDA I $G(DA) S PSOABCDA=$G(DA)
I $O(^PS(52.41,"ARF",RXN,0)) S DA=$O(^PS(52.41,"ARF",RXN,0)),DIK="^PS(52.41," D ^DIK K DA,DIK
I $G(PSOABCDA) S DA=$G(PSOABCDA)
;I +PSOIB>0,+$P(PSOIB,U,2)>0 D RXDEL^PSOCPA ;If charged, delete copay
I $G(PSOABCDA) S DA=$G(PSOABCDA) K PSOABCDA
Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG)) I $D(DA),'$G(PSOZVER) D ULK,ULP Q
S ^PSDRUG(+$P(RX,U,6),660.1)=$S($D(^PSDRUG(+$P(RX,U,6),660.1)):^(660.1),1:0)+$P(RX,U,7)
S DFN=+$P(RX,U,2) F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I I +^(I,0)=RXN K ^(0) S ^(0)=$P(^PS(55,DFN,"P",0),U,1,3)_U_($P(^(0),U,4)-1)
D:'$P($G(^PSRX(RXN,2)),U,15) CALLPOS^APSPFUNC(RXN,"","D","Returned to stock.")
F I=0:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I I $D(^(I,RXN)) K ^(RXN)
K STAT,COM,RX,RXN Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG)) I $G(PSDEL) D ULK,ULP Q
;
KILL K PSORXDFN,RXO,RX0,RX2,RESK,PSOPCECT,PSDEL,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM
K DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,PSONODF,PSONOOR,PSOXYZF,TYPE,QDRUG,QTY,PSOLOCRL,PSODT,PSOINVTX,PSROF,PSOABCDA,PSOXXDEL
Q
ACT ;adds activity info for deleted rx
N RXF,PSOREF,I,DA,FDA,%,%H,%I
S (RXF,PSOREF)=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S (RXF,PSOREF)=I S:I>5 RXF=I+1 K ^PSRX("ACP",$P(^PSRX(RXN,0),U,2),$P(^PSRX(RXN,1,I,0),U),I,RXN)
S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA
D NOW^%DTC
S DA=DA+1
S ^PSRX(RXN,"A",0)="^52.3DA^"_DA_U_DA
S ^PSRX(RXN,"A",DA,0)=%_U_"D"_U_DUZ_U_RXF_U_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
EX S DA=RXN
Q
RESK ;
N RX0,RX2,J,ST0,ST,PSODLCOM,COM,PSOWHERE,RESK,PSIN,XTYPE,COPAYFLG
N IFN,I,%,DIR,PSOLOUD,DIE,DIK,QDRUG
S RESK=1,PSIN=+$P(^PS(59.7,1,49.99),U,2) K PSODEF S PSOPCECT=1
S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),U,2),0)),U,6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),U,2)) K PSOLOUD
I $S('+$P($G(^PSRX(+RXP,"STA")),U):0,$P(^("STA"),U)=11:0,$P(^("STA"),U)=12:0,$P(^("STA"),U)=14:0,$P(^("STA"),U)=15:0,1:1) D STAT^PSORESK1 S PSODEFLG=1 Q
K DIR
S (COM,PSODLCOM)="Auto RTS/Delete" ;todo-what should the comment text be ;Y I Y[U!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q
;The next two lines make use of the MUMPS naked reference syntax.
S QDRUG=+$P($G(^PSRX(RXP,0)),U,6)
S QTY=$P($G(^(0)),U,7) I $O(^PSRX(RXP,1,0)) G REF
S XTYPE="O" I $P($G(^PSRX(RXP,2)),U,15) Q ;Already returned to stock
I $P($G(^PSRX(RXP,2)),U,2)<$G(PSIN) Q ;Fill Date < OP v6 Install Date
K PSOLOCRL,PSOWHERE S PSOLOCRL=$P($G(^PSRX(RXP,2)),U,13) ; Released D/T
Q:'$G(PSOLOCRL)
S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,0)):1,1:0)
I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG) I $G(PSOINVTX) D INVINC
I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,0)
D NOW^%DTC K DIE S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE
D ACT^PSORESK1
S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
D EN^PSOHLSN1(RXP,"ZD")
D CALLPOS^APSPFUNC(RXP,"","D","Returned to stock.")
Q
REF ;
N TYPE
F PSROF=0:0 S PSROF=$O(^PSRX(RXP,1,PSROF)) Q:'PSROF S:$P($G(^PSRX(RXP,1,PSROF,0)),U) TYPE=PSROF
Q:'$G(TYPE)
S XTYPE=1
Q:$P($G(^PSRX(RXP,1,TYPE,0)),U,16)
Q:'$P($G(^PSRX(RXP,1,TYPE,0)),U,18)
I '$P($G(^PSRX(RXP,1,TYPE,0)),U,18),$P($G(^(0)),U)'<PSIN Q
S PSOLOCRL=$P($G(^PSRX(RXP,1,TYPE,0)),U,18)
Q:'$G(PSOLOCRL)
S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)):1,1:0)
S QTY=$P($G(^PSRX(RXP,1,TYPE,0)),U,4)
I +$G(^PSRX(RXP,"IB")) S COPAYFLG=1 D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG) I $G(PSOINVTX) D INVINC
I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)
D NOW^%DTC K DIE S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_",1,",DR="17////@;.01///@" W ! D ^DIE K DIE
D ACT^PSORESK1
S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
D EN^PSOHLSN1(RXP,"ZD")
D CALLPOS^APSPFUNC(RXP,$S(TYPE:TYPE,1:""),"D","Returned to stock.")
Q
INVT ;
S PSOINVTX=1
Q
INVINC ;
S ^PSDRUG(QDRUG,660.1)=$S($P($G(^PSDRUG(QDRUG,660.1)),U):$P($G(^PSDRUG(QDRUG,660.1)),U),1:0)+$G(QTY)
Q
ULK ;
I $G(RXN) D PSOUL^PSSLOCK(RXN)
Q
ULP ;
D UL^PSSLOCK(+$G(PSORXDFN))
Q
APSPFNC3 ;IHS/MSC/PLS - auto return to stock/delete support ;21-Aug-2008 14:57;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1007**;Sep 23, 2004
+2 ; IHS/MSC/PLS - 08/21/08 - Added additional parameter to CALLPOS calls
+3 ;Code copied from PSORXDL
EN(DA) ; EP
+1 NEW PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF,RXP
+2 NEW PSDEL,PSOXXDEL,PS,RXN,PSOPLCK,PSOMSG,COM
+3 NEW PSORXDFN,REL,PSOGGFL,PSOGG,PSOXYZF,X,Y,Z,DFN,I,PKI1
+4 NEW PSODEF
+5 SET (PSDEL,PSOXXDEL)=1
SET PS="DELETE"
+6 SET RXN=+$GET(DA)
+7 SET PSORXDFN=+$PIECE($GET(^PSRX(RXN,0)),U,2)
+8 SET PSOPLCK=$$L^PSSLOCK(PSORXDFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
QUIT
+9 DO PSOL^PSSLOCK(RXN)
IF '$GET(PSOMSG)
Begin DoDot:1
+10 WRITE !,$SELECT($PIECE($GET(PSOMSG),U,2)'="":$PIECE($GET(PSOMSG),U,2),1:"Another person is editing this order."),!
+11 DO ULP
End DoDot:1
QUIT
+12 SET (REL,PSOGGFL)=0
+13 FOR PSOGG=0:0
SET PSOGG=$ORDER(^PSRX(DA,1,PSOGG))
IF 'PSOGG
QUIT
IF $DATA(^PSRX(DA,1,PSOGG,0))
SET PSOGGFL=PSOGG
+14 SET REL=$SELECT($GET(PSOGGFL)&($PIECE($GET(^PSRX(DA,1,+$GET(PSOGGFL),0)),U,18))&('$PIECE($GET(^(0)),U,16)):1,'$GET(PSOGGFL)&($PIECE($GET(^PSRX(DA,2)),U,13))&('$PIECE($GET(^(2)),U,15)):1,1:0)
PASS ;N PSORXDAC K PSOXYZF S PSORXDAC=$O(^PS(52.5,"B",DA,0)) I PSORXDAC,$P($G(^PS(52.5,PSORXDAC,0)),U,7)="L" N PSOXYZ S PSOXYZF=0 W !!,"Please wait, Rx is Loading for CMOP Transmission.." D
+1 ;.F PSOXYZ=1:1:5 W "." H 1 I $P($G(^PS(52.5,PSORXDAC,0)),U,7)'="L" S PSOXYZF=1
+2 ;I $G(PSOXYZF)=0 W !!,"Sorry, still loading for CMOP transmission, try again later.",! D ULK,ULP,KILL K PSOXYZF G PSORXDL
+3 IF $GET(REL)
SET PSOHLRE=REL
SET PSOHLDAH=$GET(DA)
+4 IF $GET(REL)
SET RXP=DA
SET PSODEFLG=0
DO RESK
IF $GET(PSODEFLG)
DO ULK
DO ULP
DO KILL
QUIT
+5 IF $GET(PSOHLRE)
SET DA=$GET(PSOHLDAH)
SET REL=$GET(PSOHLRE)
+6 ; Service Corrected
SET PSONOOR="S"
+7 IF $GET(PKI1)
NEW INCOM
SET INCOM="Per Pharmacy Request"
DO DCV^PSOPKIV1
DO ULK
DO ULP
QUIT
ENQ ;Check if copay
SET PSOIB=$SELECT($DATA(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0)
+1 SET RX=^PSRX(DA,0)
SET RXN=DA
+2 SET $PIECE(^PSRX(RXN,"STA"),U)=13
SET $PIECE(^PSRX(RXN,"D"),U)=$GET(Y)
+3 SET DA=RXN
KILL ^PSRX("ACP",$PIECE(^PSRX(DA,0),U,2),+$PIECE(^(2),U,2),0,DA)
DO ACT
+4 SET DA=RXN
IF $GET(^PSRX(DA,"H"))]""
KILL ^PSRX("AH",+$PIECE(^PSRX(DA,"H"),U),DA)
SET ^PSRX(DA,"H")=""
+5 DO EN^PSOHLSN1(DA,"OC","",$PIECE(^PSRX(DA,"D"),U),PSONOOR)
+6 SET DA=$ORDER(^PS(52.5,"B",RXN,0))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
+7 SET DA=RXN
IF $DATA(^PS(52.4,RXN))
SET DIK="^PS(52.4,"
DO ^DIK
+8 KILL PSOABCDA
IF $GET(DA)
SET PSOABCDA=$GET(DA)
+9 IF $ORDER(^PS(52.41,"ARF",RXN,0))
SET DA=$ORDER(^PS(52.41,"ARF",RXN,0))
SET DIK="^PS(52.41,"
DO ^DIK
KILL DA,DIK
+10 IF $GET(PSOABCDA)
SET DA=$GET(PSOABCDA)
+11 ;I +PSOIB>0,+$P(PSOIB,U,2)>0 D RXDEL^PSOCPA ;If charged, delete copay
+12 IF $GET(PSOABCDA)
SET DA=$GET(PSOABCDA)
KILL PSOABCDA
+13 IF +$GET(PSORX("INTERVENE"))!($GET(PSVFLAG))
QUIT
IF $DATA(DA)
IF '$GET(PSOZVER)
DO ULK
DO ULP
QUIT
+14 SET ^PSDRUG(+$PIECE(RX,U,6),660.1)=$SELECT($DATA(^PSDRUG(+$PIECE(RX,U,6),660.1)):^(660.1),1:0)+$PIECE(RX,U,7)
+15 SET DFN=+$PIECE(RX,U,2)
FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"P",I))
IF 'I
QUIT
IF +^(I,0)=RXN
KILL ^(0)
SET ^(0)=$PIECE(^PS(55,DFN,"P",0),U,1,3)_U_($PIECE(^(0),U,4)-1)
+16 IF '$PIECE($GET(^PSRX(RXN,2)),U,15)
DO CALLPOS^APSPFUNC(RXN,"","D","Returned to stock.")
+17 FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"P","A",I))
IF 'I
QUIT
IF $DATA(^(I,RXN))
KILL ^(RXN)
+18 KILL STAT,COM,RX,RXN
IF +$GET(PSORX("INTERVENE"))!($GET(PSVFLAG))
QUIT
IF $GET(PSDEL)
DO ULK
DO ULP
QUIT
+19 ;
KILL KILL PSORXDFN,RXO,RX0,RX2,RESK,PSOPCECT,PSDEL,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM
+1 KILL DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,PSONODF,PSONOOR,PSOXYZF,TYPE,QDRUG,QTY,PSOLOCRL,PSODT,PSOINVTX,PSROF,PSOABCDA,PSOXXDEL
+2 QUIT
ACT ;adds activity info for deleted rx
+1 NEW RXF,PSOREF,I,DA,FDA,%,%H,%I
+2 SET (RXF,PSOREF)=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXN,1,I))
IF 'I
QUIT
SET (RXF,PSOREF)=I
IF I>5
SET RXF=I+1
KILL ^PSRX("ACP",$PIECE(^PSRX(RXN,0),U,2),$PIECE(^PSRX(RXN,1,I,0),U),I,RXN)
+3 SET DA=0
FOR FDA=0:0
SET FDA=$ORDER(^PSRX(RXN,"A",FDA))
IF 'FDA
QUIT
SET DA=FDA
+4 DO NOW^%DTC
+5 SET DA=DA+1
+6 SET ^PSRX(RXN,"A",0)="^52.3DA^"_DA_U_DA
+7 SET ^PSRX(RXN,"A",DA,0)=%_U_"D"_U_DUZ_U_RXF_U_"RX DELETED on "_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)
EX SET DA=RXN
+1 QUIT
RESK ;
+1 NEW RX0,RX2,J,ST0,ST,PSODLCOM,COM,PSOWHERE,RESK,PSIN,XTYPE,COPAYFLG
+2 NEW IFN,I,%,DIR,PSOLOUD,DIE,DIK,QDRUG
+3 SET RESK=1
SET PSIN=+$PIECE(^PS(59.7,1,49.99),U,2)
KILL PSODEF
SET PSOPCECT=1
+4 SET PSOLOUD=1
IF $PIECE($GET(^PS(55,+$PIECE(^PSRX(RXP,0),U,2),0)),U,6)'=2
DO EN^PSOHLUP($PIECE(^PSRX(RXP,0),U,2))
KILL PSOLOUD
+5 IF $SELECT('+$PIECE($GET(^PSRX(+RXP,"STA")),U):0,$PIECE(^("STA"),U)=11:0,$PIECE(^("STA"),U)=12:0,$PIECE(^("STA"),U)=14:0,$PIECE(^("STA"),U)=15:0,1:1)
DO STAT^PSORESK1
SET PSODEFLG=1
QUIT
+6 KILL DIR
+7 ;todo-what should the comment text be ;Y I Y[U!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q
SET (COM,PSODLCOM)="Auto RTS/Delete"
+8 ;The next two lines make use of the MUMPS naked reference syntax.
+9 SET QDRUG=+$PIECE($GET(^PSRX(RXP,0)),U,6)
+10 SET QTY=$PIECE($GET(^(0)),U,7)
IF $ORDER(^PSRX(RXP,1,0))
GOTO REF
+11 ;Already returned to stock
SET XTYPE="O"
IF $PIECE($GET(^PSRX(RXP,2)),U,15)
QUIT
+12 ;Fill Date < OP v6 Install Date
IF $PIECE($GET(^PSRX(RXP,2)),U,2)<$GET(PSIN)
QUIT
+13 ; Released D/T
KILL PSOLOCRL,PSOWHERE
SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,2)),U,13)
+14 IF '$GET(PSOLOCRL)
QUIT
+15 SET PSOWHERE=$SELECT($DATA(^PSRX("AR",$GET(PSOLOCRL),RXP,0)):1,1:0)
+16 IF $GET(^PSDRUG(QDRUG,660.1))
IF $GET(PSOWHERE)
DO INVT
IF $GET(PSODEFLG)
WRITE !!?5,"No Action Taken!",!
IF $GET(PSODEFLG)
QUIT
IF $GET(PSOINVTX)
DO INVINC
+17 IF $GET(^PSDRUG(QDRUG,660.1))
IF '$GET(PSOWHERE)
DO INVINC
+18 IF $GET(PSOWHERE)
KILL ^PSRX("AR",$GET(PSOLOCRL),RXP,0)
+19 DO NOW^%DTC
KILL DIE
SET DA=RXP
SET DIE="^PSRX("
SET DR="31///@;32.1///"_%
DO ^DIE
KILL DIE
+20 DO ACT^PSORESK1
+21 SET DA=$ORDER(^PS(52.5,"B",RXP,0))
IF DA
KILL DIK
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+22 DO EN^PSOHLSN1(RXP,"ZD")
+23 DO CALLPOS^APSPFUNC(RXP,"","D","Returned to stock.")
+24 QUIT
REF ;
+1 NEW TYPE
+2 FOR PSROF=0:0
SET PSROF=$ORDER(^PSRX(RXP,1,PSROF))
IF 'PSROF
QUIT
IF $PIECE($GET(^PSRX(RXP,1,PSROF,0)),U)
SET TYPE=PSROF
+3 IF '$GET(TYPE)
QUIT
+4 SET XTYPE=1
+5 IF $PIECE($GET(^PSRX(RXP,1,TYPE,0)),U,16)
QUIT
+6 IF '$PIECE($GET(^PSRX(RXP,1,TYPE,0)),U,18)
QUIT
+7 IF '$PIECE($GET(^PSRX(RXP,1,TYPE,0)),U,18)
IF $PIECE($GET(^(0)),U)'<PSIN
QUIT
+8 SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,1,TYPE,0)),U,18)
+9 IF '$GET(PSOLOCRL)
QUIT
+10 SET PSOWHERE=$SELECT($DATA(^PSRX("AR",$GET(PSOLOCRL),RXP,TYPE)):1,1:0)
+11 SET QTY=$PIECE($GET(^PSRX(RXP,1,TYPE,0)),U,4)
+12 IF +$GET(^PSRX(RXP,"IB"))
SET COPAYFLG=1
DO CP^PSORESK1
IF '$GET(COPAYFLG)
SET PSODEFLG=1
QUIT
+13 IF $GET(^PSDRUG(QDRUG,660.1))
IF $GET(PSOWHERE)
DO INVT
IF $GET(PSODEFLG)
WRITE !!?5,"No Action Taken!",!
IF $GET(PSODEFLG)
QUIT
IF $GET(PSOINVTX)
DO INVINC
+14 IF $GET(^PSDRUG(QDRUG,660.1))
IF '$GET(PSOWHERE)
DO INVINC
+15 IF $GET(PSOWHERE)
KILL ^PSRX("AR",$GET(PSOLOCRL),RXP,TYPE)
+16 DO NOW^%DTC
KILL DIE
SET DA(1)=RXP
SET DA=TYPE
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="17////@;.01///@"
WRITE !
DO ^DIE
KILL DIE
+17 DO ACT^PSORESK1
+18 SET DA=$ORDER(^PS(52.5,"B",RXP,0))
IF DA
KILL DIK
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+19 DO EN^PSOHLSN1(RXP,"ZD")
+20 DO CALLPOS^APSPFUNC(RXP,$SELECT(TYPE:TYPE,1:""),"D","Returned to stock.")
+21 QUIT
INVT ;
+1 SET PSOINVTX=1
+2 QUIT
INVINC ;
+1 SET ^PSDRUG(QDRUG,660.1)=$SELECT($PIECE($GET(^PSDRUG(QDRUG,660.1)),U):$PIECE($GET(^PSDRUG(QDRUG,660.1)),U),1:0)+$GET(QTY)
+2 QUIT
ULK ;
+1 IF $GET(RXN)
DO PSOUL^PSSLOCK(RXN)
+2 QUIT
ULP ;
+1 DO UL^PSSLOCK(+$GET(PSORXDFN))
+2 QUIT
