- 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
