PSDOPT0 ;BIR/JPW,LTL,BJW - Outpatient Rx Entry (cont'd) ; 22 Jun 98
;;3.0; CONTROLLED SUBSTANCES ;**10,30,37,39,45,48,66**;13 Feb 97;Build 3
;Reference to PS(52.5 supported by DBIA #786
;Reference to PS(59.7 supported by DBIA #1930
;References to ^PSD(58.8 are covered by DBIA #2711
;References to file 58.81 are covered by DBIA #2808
;Reference to ^PSDRUG( supported by DBIA #221
;Reference to PSRX( supported by DBIA #986
;called by ^PSDOPT,mod.for nois#:tua-0498-32173
;08/02/2004 KAM PSD*3*45 Modification to stop posting of the same
; partial multiple times
LOOP ;loop to find new, refills and partials
W !!,"Accessing the prescription history..."
N PSDOIN,PSDRXFD,PSDSUPN,PSDLBL S PSDOIN=+$P($G(^PS(59.7,1,49.99)),U,2)
;check for unposted refills not returned to stock and not in suspense
S (RF,DAT)=0 F JJ=0:0 S JJ=$O(^PSRX(PSDRX,1,JJ)) Q:'JJ I $D(^PSRX(PSDRX,1,JJ,0)),'$P(^(0),U,16),$P($G(^(0)),U)'<PSDOIN D
.;checking for suspense
.S PSDRXFD=$E($P(^PSRX(PSDRX,1,JJ,0),U),1,7)
.S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
.I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1 W !!,"Refill #",JJ," suspended." Q
.S RXNUM("RF",JJ)=+^PSRX(PSDRX,1,JJ,0)_U_$P(^(0),U,4),$P(PSDSEL("RF",JJ),"^",1)=$P(RXNUM("RF",JJ),"^",1),$P(PSDSEL("RF",JJ),"^",2)=$P(RXNUM("RF",JJ),"^",2),$P(PSDSEL("RF",JJ),"^",3)=$P($G(PSDRX("RF",JJ)),"^",3) K PSDLBLP
;
;check for unposted partials not returned to stock or suspended
;
S PRF=0 F JJ=0:0 S JJ=$O(^PSRX(PSDRX,"P",JJ)) Q:'JJ I $D(^PSRX(PSDRX,"P",JJ,0)),'$P(^(0),U,16),$P($G(^(0)),U)'<PSDOIN D
.;check for suspense
.S PSDRXFD=$E($P(^PSRX(PSDRX,"P",JJ,0),U),1,7)
.S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
.I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1,($G(JJ)=$P(^PS(52.5,PSDSUPN,0),U,5)) W !!,"Partial #",JJ," suspended." Q
.S RXNUM("PR",JJ)=+^PSRX(PSDRX,"P",JJ,0)_U_$P(^(0),U,4),$P(PSDSEL("PR",JJ),"^",1)=$P(RXNUM("PR",JJ),"^",1),$P(PSDSEL("PR",JJ),"^",2)=$P(RXNUM("PR",JJ),"^",2) K PSDLBL
;
;original returned to stock
;
S:$P($G(^PSRX(+PSDRX,2)),U,15) PSDRX(1)=""
;Check for suspense
I +$P($G(^PSRX(PSDRX,2)),U,2)'<PSDOIN S PSDRXFD=$P(^(2),U,2) D
.S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
.I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1 W !!,"Original suspended." S PSDRX(1)="" Q
PSDDAVE ;PSD*3*30 (Major overhaul, Dave B)
;PSDSEL("RF",#)=refill Date ^ QTY ^ posted (y/n) ^ released date
;PSDSEL("PR" ''
;PSDSEL("OR" same thing
;
I '$D(PSDRX(1)) S $P(PSDSEL("OR"),"^",2)=$P(^PSRX(+PSDRX,0),"^",7) ;Quantity
I $D(PSDRX("OR")) S $P(PSDSEL("OR"),"^",3)=1 ;Posted
I $P($G(^PSRX(+PSDRX,2)),"^",13)'="" S Y=$P(^PSRX(+PSDRX,2),"^",13) X ^DD("DD") S $P(PSDSEL("OR"),"^",4)=Y ;released date
I $D(PSDSEL("OR")),$P(PSDSEL("OR"),"^",3)'="",$P(PSDSEL("OR"),"^",4)'="" K PSDSEL("OR"),RXNUM("OR")
S (PSDRF1,PSDPR1)=0
RFLCHK ;
S PSDRF1=$O(PSDSEL("RF",PSDRF1)) G PRTLCHK:PSDRF1'>0 S DATA=PSDSEL("RF",PSDRF1)
I $P($G(^PSRX(+PSDRX,1,PSDRF1,0)),"^",18)'="" S Y=$P(^(0),"^",18) X ^DD("DD") S $P(PSDSEL("RF",PSDRF1),"^",4)=Y ;Already released
I $P(PSDSEL("RF",PSDRF1),"^",3)>0,$P(PSDSEL("RF",PSDRF1),"^",4)'="" K PSDSEL("RF",PSDRF1),RXNUM("RF",PSDRF1)
G RFLCHK
;
PRTLCHK S PSDPR1=$O(PSDSEL("PR",PSDPR1)) G CHKALL:PSDPR1'>0
; 08/02/2004 PSD*3*45 Added next line
I $D(PSDRX("PR",PSDPR1)) S $P(PSDSEL("PR",PSDPR1),"^",3)=1 ;Posted
I $P($G(^PSRX(+PSDRX,"P",PSDPR1,0)),"^",19)'="" S Y=$P(^(0),"^",19) X ^DD("DD") S $P(PSDSEL("PR",PSDPR1),"^",4)=Y
I $P(PSDSEL("PR",PSDPR1),"^",3)>0,$P(PSDSEL("PR",PSDPR1),"^",4)'="" K PSDSEL("PR",PSDPR1),RXNUM("PR",PSDPR1)
G PRTLCHK
;
CHKALL ;Check to see if any left to post or release
I $G(PSDERR)=1 G ASKP^PSDOPT
I $O(PSDSEL(0))="" W !!,"ALL FILLS FOR THIS PRESCRIPTION HAVE BEEN POSTED AND RELEASED." G ASKP^PSDOPT
;
;Check for DIR call
S CNT=0 K DIR
G CHK^PSDOPT
;
PSDRTS(PSDRX,PSDNUM,PSDSITE,PSDQTY) ; API for Outpatient Pharmacy; Patch PSD*3*30
; This subroutine is called each time an Rx is returned to stock
; in Outpatient Pharmacy. The code does the following:
; 1.Check Rx, quit if not a controlled substance.
; 2.Give the user the option to update the transaction and
; balance details
;PSDCS = 1 is controlled subs/0 for not CS
;PSDRS = 1 they have key, ok to return to stock, 0 - no key
;Variables:
;PSDRX = Prescription Number IEN
;PSDNUM = O^0 = The letter O for original fill and the number0
; R^# = The letter R for refill and # equal to refill #
; P^# = The letter P for partial and # equal to partial #
;PSDSITE = Division
;PSDQTY = Quantity being returned to stock
;
;PSD*3*30 Check for PSDMGR key
S PSDRS=0 I $D(^XUSEC("PSDMGR",DUZ)) S PSDRS=1 ;possess key
1 ;begin process
I $D(^PSD(58.81,"AOP",PSDRX)) D RTSCHK G RETERR:$G(PSDERR)>0
S PSDOUT=0,RXNUM=$P($G(^PSRX(+PSDRX,0)),"^") ;Prescription Number
S (RPDT,DAT)=$P($G(^PSRX(+PSDRX,2)),"^",2)
S DFN=+$P($G(^PSRX(+PSDRX,0)),"^",2)
S PSDS=$S($G(PSDSITE)["^":$P(PSDSITE,"^",3),1:PSDSITE)
S PSDR=$P($G(^PSRX(+PSDRX,0)),"^",6) I $G(PSDR)'="" S PSDRN=$P($G(^PSDRUG(PSDR,0)),"^")
;Setup like balance adjustment
S PSDRN=$S($G(PSDRN)="":"Unknown Drug "_PSDR,1:PSDRN)
I $P($G(^PSDRUG(PSDR,2)),"^",3)'["N" S PSDCS=0 Q
S PSDCS=1
I $G(PSDRS)'>0 W !,"Sorry you do not possess the PSDMGR key" G RETERR
;
POSTED ;check to see if posted
S (JJ,PSDPOST)=0
F S JJ=$O(^PSD(58.81,"AOP",+PSDRX,JJ)) Q:'JJ I $D(^PSD(58.81,JJ,6)) D
.S NODE6=$G(^PSD(58.81,JJ,6))
.I $P(PSDNUM,"^",1)="R",$P(NODE6,"^",2)'="",$P(NODE6,"^",2)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
.I $P(PSDNUM,"^",1)="P",$P(NODE6,"^",4)'="",$P(NODE6,"^",4)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
.I $P(PSDNUM,"^",1)="O",$P(NODE6,"^",4)="",$P(NODE6,"^",2)="" S PSDPOST=1 Q
;
;now check to see if CMOP
S X1=0 F S X1=$O(^PSRX(+PSDRX,4,X1)) Q:X1="" S DATA=$G(^PSRX(+PSDRX,4,X1,0)) D
.I $P(PSDNUM,"^",1)="R",$P(DATA,"^",3)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
.I $P(PSDNUM,"^",1)="P",$P(DATA,"^",3)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
.I $P(PSDNUM,"^",1)="O",$P(DATA,"^",3)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
I $G(PSDPOST)'=1 W !!,"Could not find any posting information in the Controlled Substance package,",!,"balance cannot be updated",!
;
ESIG K X D SIG^XUSESIG I X["^" W !,"No signature code entered, RX not returned to stock." S RETSK=1 Q
I X1="" W !,"An Electronic Signature Code is required to return a Controlled Substance RX to stock.",! G ESIG
ASK S DIR(0)="Y",DIR("A")="Do you want "_$G(PSDQTY)_" added to balance in the Narcotic vault",DIR("B")="Yes",DIR("?")="Answer Yes and the amount being returned to stock will be placed in inventory" D ^DIR K DIR I $D(DIRUT) G RETERR
I +Y'>0 W !,"Nothing updated" G RETERR
LOCATION S DIC(0)="QEA",DIC="^PSD(58.8,",DIC("A")="Return Drug to which vault: "
S DIC("S")="I ""MSN""[$P($G(^PSD(58.8,Y,0)),U,2)"
D ^DIC K DIC
I "MSN"'[$P($G(^PSD(58.8,+Y,0)),"^",2) W !,"Sorry, the location type must be a Master Vault, satellite or narcotic location." K Y G LOCATION
I +Y'>0 W !,"No selection made, no balance adjusted." G RETERR
S PSDS=+Y I '$D(^PSD(58.8,+PSDS,1,PSDR,0)) W !,"Sorry, the drug is not stocked in this vault." K PSDS G LOCATION
S PSDBAL=$P($G(^PSD(58.8,+PSDS,1,PSDR,0)),"^",4) W !,"Previous Balance: ",$G(PSDBAL)_" New Balance: "_($G(PSDBAL)+PSDQTY)
W !,"Updating balances"
F L +^PSD(58.8,+PSDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSDT=+%,BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4),$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
L -^PSD(58.8,+PSDS,1,PSDR,0) W "."
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND1 S PSDA=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDA)) S $P(^PSD(58.81,0),"^",3)=PSDA G FIND1
K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.81,DIC(0)="L",(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
L -^PSD(58.81,0)
S PSDNUM1=$P($G(PSDNUM),"^",2)
S ^PSD(58.81,PSDA,0)=PSDA_"^3^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_PSDQTY_"^"_DUZ_"^^^"_BAL
S ^PSD(58.81,PSDA,3)=PSDT_"^"_PSDQTY_"^"_"RX RETURNED TO STOCK"
S ^PSD(58.81,PSDA,"CS")=1
S ^PSD(58.81,PSDA,6)=PSDRX_"^"_$S($P(PSDNUM,"^")="R":PSDNUM1,1:"")_"^"_DAT_"^"_$S($P(PSDNUM,"^")="P":PSDNUM1,1:"")_"^"_RXNUM
S DIK="^PSD(58.81,",DA=PSDA D IX^DIK K DA,DIC,DIK
DIE I '$D(^PSD(58.8,+PSDS,1,PSDR,4,0)) S ^(0)="^58.800119PA^^"
K DA,DIC,DD,DO S DA(1)=PSDR,DA(2)=+PSDS,(X,DINUM)=PSDA,DIC(0)="L",DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",4," D FILE^DICN K DIC,DINUM
;monthly activity
I '$D(^PSD(58.8,+PSDS,1,PSDR,5,0)) S ^(0)="^58.801A^^"
I '$D(^PSD(58.8,+PSDS,1,PSDR,5,$E(DT,1,5)*100,0)) K DA,DIC S DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",5,",DIC(0)="LM",DLAYGO=58.8,(X,DINUM)=$E(DT,1,5)*100,DA(2)=+PSDS,DA(1)=PSDR D ^DIC K DA,DIC,DINUM,DLAYGO
K DA,DIE,DR S DIE="^PSD(58.8,"_+PSDS_",1,"_PSDR_",5,",DA(2)=+PSDS,DA(1)=PSDR,DA=$E(DT,1,5)*100,DR="9////^S X=$P($G(^(0)),""^"",6)+PSDQTY" D ^DIE K DA,DIE,DR
RETERR Q
RTSCHK ;Check to see if already returned to stock.
D RTSMUL
S PSD1=0
S:$D(PSDXXX) PSD1=PSDXXX-.1
K PSD1MUL,PSDMUL,PSDXXX
S PSDERR=0
F S PSD1=$O(^PSD(58.81,"AOP",PSDRX,PSD1)) Q:PSD1'>0 S DATA=$G(^PSD(58.81,PSD1,0)),DATA6=$G(^PSD(58.81,PSD1,6)) D
.S PSDFLL=$P(PSDNUM,"^",2)
.I PSDFLL>0,$D(^PSD(58.81,PSD1,6)),$P(^PSD(58.81,PSD1,6),"^",2)=PSDFLL,$D(^PSD(58.81,PSD1,3)) D ERRMSG
.I $D(^PSD(58.81,PSD1,3)),PSDFLL=0,'$D(^PSD(58.81,PSD1,6)) D ERRMSG
Q
ERRMSG S Y=$P(^PSD(58.81,PSD1,3),"^") X ^DD("DD") S PSDRTS(1)=Y,PSDUSER=$P(^PSD(58.81,PSD1,0),"^",7),PSDUSER=$P(^VA(200,PSDUSER,0),"^")
W !!?8,"According to the Controlled Substances package, this fill/refill",!?8,"was returned to stock on "_PSDRTS(1)_" by "_$G(PSDUSER)_".",!?16,"Nothing updated in the Controlled Substances package."
S PSDERR=1 Q
RTSMUL D RTSMUL^PSDOPT1
Q
PSDOPT0 ;BIR/JPW,LTL,BJW - Outpatient Rx Entry (cont'd) ; 22 Jun 98
+1 ;;3.0; CONTROLLED SUBSTANCES ;**10,30,37,39,45,48,66**;13 Feb 97;Build 3
+2 ;Reference to PS(52.5 supported by DBIA #786
+3 ;Reference to PS(59.7 supported by DBIA #1930
+4 ;References to ^PSD(58.8 are covered by DBIA #2711
+5 ;References to file 58.81 are covered by DBIA #2808
+6 ;Reference to ^PSDRUG( supported by DBIA #221
+7 ;Reference to PSRX( supported by DBIA #986
+8 ;called by ^PSDOPT,mod.for nois#:tua-0498-32173
+9 ;08/02/2004 KAM PSD*3*45 Modification to stop posting of the same
+10 ; partial multiple times
LOOP ;loop to find new, refills and partials
+1 WRITE !!,"Accessing the prescription history..."
+2 NEW PSDOIN,PSDRXFD,PSDSUPN,PSDLBL
SET PSDOIN=+$PIECE($GET(^PS(59.7,1,49.99)),U,2)
+3 ;check for unposted refills not returned to stock and not in suspense
+4 SET (RF,DAT)=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(PSDRX,1,JJ))
IF 'JJ
QUIT
IF $DATA(^PSRX(PSDRX,1,JJ,0))
IF '$PIECE(^(0),U,16)
IF $PIECE($GET(^(0)),U)'<PSDOIN
Begin DoDot:1
+5 ;checking for suspense
+6 SET PSDRXFD=$EXTRACT($PIECE(^PSRX(PSDRX,1,JJ,0),U),1,7)
+7 SET PSDSUPN=$ORDER(^PS(52.5,"B",PSDRX,0))
+8 IF PSDSUPN
IF $DATA(^PS(52.5,"C",PSDRXFD,PSDSUPN))
IF $GET(^PS(52.5,PSDSUPN,"P"))'=1
WRITE !!,"Refill #",JJ," suspended."
QUIT
+9 SET RXNUM("RF",JJ)=+^PSRX(PSDRX,1,JJ,0)_U_$PIECE(^(0),U,4)
SET $PIECE(PSDSEL("RF",JJ),"^",1)=$PIECE(RXNUM("RF",JJ),"^",1)
SET $PIECE(PSDSEL("RF",JJ),"^",2)=$PIECE(RXNUM("RF",JJ),"^",2)
SET $PIECE(PSDSEL("RF",JJ),"^",3)=$PIECE($GET(PSDRX("RF",JJ)),"^",3)
KILL PSDLBLP
End DoDot:1
+10 ;
+11 ;check for unposted partials not returned to stock or suspended
+12 ;
+13 SET PRF=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(PSDRX,"P",JJ))
IF 'JJ
QUIT
IF $DATA(^PSRX(PSDRX,"P",JJ,0))
IF '$PIECE(^(0),U,16)
IF $PIECE($GET(^(0)),U)'<PSDOIN
Begin DoDot:1
+14 ;check for suspense
+15 SET PSDRXFD=$EXTRACT($PIECE(^PSRX(PSDRX,"P",JJ,0),U),1,7)
+16 SET PSDSUPN=$ORDER(^PS(52.5,"B",PSDRX,0))
+17 IF PSDSUPN
IF $DATA(^PS(52.5,"C",PSDRXFD,PSDSUPN))
IF $GET(^PS(52.5,PSDSUPN,"P"))'=1
IF ($GET(JJ)=$PIECE(^PS(52.5,PSDSUPN,0),U,5))
WRITE !!,"Partial #",JJ," suspended."
QUIT
+18 SET RXNUM("PR",JJ)=+^PSRX(PSDRX,"P",JJ,0)_U_$PIECE(^(0),U,4)
SET $PIECE(PSDSEL("PR",JJ),"^",1)=$PIECE(RXNUM("PR",JJ),"^",1)
SET $PIECE(PSDSEL("PR",JJ),"^",2)=$PIECE(RXNUM("PR",JJ),"^",2)
KILL PSDLBL
End DoDot:1
+19 ;
+20 ;original returned to stock
+21 ;
+22 IF $PIECE($GET(^PSRX(+PSDRX,2)),U,15)
SET PSDRX(1)=""
+23 ;Check for suspense
+24 IF +$PIECE($GET(^PSRX(PSDRX,2)),U,2)'<PSDOIN
SET PSDRXFD=$PIECE(^(2),U,2)
Begin DoDot:1
+25 SET PSDSUPN=$ORDER(^PS(52.5,"B",PSDRX,0))
+26 IF PSDSUPN
IF $DATA(^PS(52.5,"C",PSDRXFD,PSDSUPN))
IF $GET(^PS(52.5,PSDSUPN,"P"))'=1
WRITE !!,"Original suspended."
SET PSDRX(1)=""
QUIT
End DoDot:1
PSDDAVE ;PSD*3*30 (Major overhaul, Dave B)
+1 ;PSDSEL("RF",#)=refill Date ^ QTY ^ posted (y/n) ^ released date
+2 ;PSDSEL("PR" ''
+3 ;PSDSEL("OR" same thing
+4 ;
+5 ;Quantity
IF '$DATA(PSDRX(1))
SET $PIECE(PSDSEL("OR"),"^",2)=$PIECE(^PSRX(+PSDRX,0),"^",7)
+6 ;Posted
IF $DATA(PSDRX("OR"))
SET $PIECE(PSDSEL("OR"),"^",3)=1
+7 ;released date
IF $PIECE($GET(^PSRX(+PSDRX,2)),"^",13)'=""
SET Y=$PIECE(^PSRX(+PSDRX,2),"^",13)
XECUTE ^DD("DD")
SET $PIECE(PSDSEL("OR"),"^",4)=Y
+8 IF $DATA(PSDSEL("OR"))
IF $PIECE(PSDSEL("OR"),"^",3)'=""
IF $PIECE(PSDSEL("OR"),"^",4)'=""
KILL PSDSEL("OR"),RXNUM("OR")
+9 SET (PSDRF1,PSDPR1)=0
RFLCHK ;
+1 SET PSDRF1=$ORDER(PSDSEL("RF",PSDRF1))
IF PSDRF1'>0
GOTO PRTLCHK
SET DATA=PSDSEL("RF",PSDRF1)
+2 ;Already released
IF $PIECE($GET(^PSRX(+PSDRX,1,PSDRF1,0)),"^",18)'=""
SET Y=$PIECE(^(0),"^",18)
XECUTE ^DD("DD")
SET $PIECE(PSDSEL("RF",PSDRF1),"^",4)=Y
+3 IF $PIECE(PSDSEL("RF",PSDRF1),"^",3)>0
IF $PIECE(PSDSEL("RF",PSDRF1),"^",4)'=""
KILL PSDSEL("RF",PSDRF1),RXNUM("RF",PSDRF1)
+4 GOTO RFLCHK
+5 ;
PRTLCHK SET PSDPR1=$ORDER(PSDSEL("PR",PSDPR1))
IF PSDPR1'>0
GOTO CHKALL
+1 ; 08/02/2004 PSD*3*45 Added next line
+2 ;Posted
IF $DATA(PSDRX("PR",PSDPR1))
SET $PIECE(PSDSEL("PR",PSDPR1),"^",3)=1
+3 IF $PIECE($GET(^PSRX(+PSDRX,"P",PSDPR1,0)),"^",19)'=""
SET Y=$PIECE(^(0),"^",19)
XECUTE ^DD("DD")
SET $PIECE(PSDSEL("PR",PSDPR1),"^",4)=Y
+4 IF $PIECE(PSDSEL("PR",PSDPR1),"^",3)>0
IF $PIECE(PSDSEL("PR",PSDPR1),"^",4)'=""
KILL PSDSEL("PR",PSDPR1),RXNUM("PR",PSDPR1)
+5 GOTO PRTLCHK
+6 ;
CHKALL ;Check to see if any left to post or release
+1 IF $GET(PSDERR)=1
GOTO ASKP^PSDOPT
+2 IF $ORDER(PSDSEL(0))=""
WRITE !!,"ALL FILLS FOR THIS PRESCRIPTION HAVE BEEN POSTED AND RELEASED."
GOTO ASKP^PSDOPT
+3 ;
+4 ;Check for DIR call
+5 SET CNT=0
KILL DIR
+6 GOTO CHK^PSDOPT
+7 ;
PSDRTS(PSDRX,PSDNUM,PSDSITE,PSDQTY) ; API for Outpatient Pharmacy; Patch PSD*3*30
+1 ; This subroutine is called each time an Rx is returned to stock
+2 ; in Outpatient Pharmacy. The code does the following:
+3 ; 1.Check Rx, quit if not a controlled substance.
+4 ; 2.Give the user the option to update the transaction and
+5 ; balance details
+6 ;PSDCS = 1 is controlled subs/0 for not CS
+7 ;PSDRS = 1 they have key, ok to return to stock, 0 - no key
+8 ;Variables:
+9 ;PSDRX = Prescription Number IEN
+10 ;PSDNUM = O^0 = The letter O for original fill and the number0
+11 ; R^# = The letter R for refill and # equal to refill #
+12 ; P^# = The letter P for partial and # equal to partial #
+13 ;PSDSITE = Division
+14 ;PSDQTY = Quantity being returned to stock
+15 ;
+16 ;PSD*3*30 Check for PSDMGR key
+17 ;possess key
SET PSDRS=0
IF $DATA(^XUSEC("PSDMGR",DUZ))
SET PSDRS=1
1 ;begin process
+1 IF $DATA(^PSD(58.81,"AOP",PSDRX))
DO RTSCHK
IF $GET(PSDERR)>0
GOTO RETERR
+2 ;Prescription Number
SET PSDOUT=0
SET RXNUM=$PIECE($GET(^PSRX(+PSDRX,0)),"^")
+3 SET (RPDT,DAT)=$PIECE($GET(^PSRX(+PSDRX,2)),"^",2)
+4 SET DFN=+$PIECE($GET(^PSRX(+PSDRX,0)),"^",2)
+5 SET PSDS=$SELECT($GET(PSDSITE)["^":$PIECE(PSDSITE,"^",3),1:PSDSITE)
+6 SET PSDR=$PIECE($GET(^PSRX(+PSDRX,0)),"^",6)
IF $GET(PSDR)'=""
SET PSDRN=$PIECE($GET(^PSDRUG(PSDR,0)),"^")
+7 ;Setup like balance adjustment
+8 SET PSDRN=$SELECT($GET(PSDRN)="":"Unknown Drug "_PSDR,1:PSDRN)
+9 IF $PIECE($GET(^PSDRUG(PSDR,2)),"^",3)'["N"
SET PSDCS=0
QUIT
+10 SET PSDCS=1
+11 IF $GET(PSDRS)'>0
WRITE !,"Sorry you do not possess the PSDMGR key"
GOTO RETERR
+12 ;
POSTED ;check to see if posted
+1 SET (JJ,PSDPOST)=0
+2 FOR
SET JJ=$ORDER(^PSD(58.81,"AOP",+PSDRX,JJ))
IF 'JJ
QUIT
IF $DATA(^PSD(58.81,JJ,6))
Begin DoDot:1
+3 SET NODE6=$GET(^PSD(58.81,JJ,6))
+4 IF $PIECE(PSDNUM,"^",1)="R"
IF $PIECE(NODE6,"^",2)'=""
IF $PIECE(NODE6,"^",2)=$PIECE(PSDNUM,"^",2)
SET PSDPOST=1
QUIT
+5 IF $PIECE(PSDNUM,"^",1)="P"
IF $PIECE(NODE6,"^",4)'=""
IF $PIECE(NODE6,"^",4)=$PIECE(PSDNUM,"^",2)
SET PSDPOST=1
QUIT
+6 IF $PIECE(PSDNUM,"^",1)="O"
IF $PIECE(NODE6,"^",4)=""
IF $PIECE(NODE6,"^",2)=""
SET PSDPOST=1
QUIT
End DoDot:1
+7 ;
+8 ;now check to see if CMOP
+9 SET X1=0
FOR
SET X1=$ORDER(^PSRX(+PSDRX,4,X1))
IF X1=""
QUIT
SET DATA=$GET(^PSRX(+PSDRX,4,X1,0))
Begin DoDot:1
+10 IF $PIECE(PSDNUM,"^",1)="R"
IF $PIECE(DATA,"^",3)=$PIECE(PSDNUM,"^",2)
SET PSDPOST=1
QUIT
+11 IF $PIECE(PSDNUM,"^",1)="P"
IF $PIECE(DATA,"^",3)=$PIECE(PSDNUM,"^",2)
SET PSDPOST=1
QUIT
+12 IF $PIECE(PSDNUM,"^",1)="O"
IF $PIECE(DATA,"^",3)=$PIECE(PSDNUM,"^",2)
SET PSDPOST=1
QUIT
End DoDot:1
+13 IF $GET(PSDPOST)'=1
WRITE !!,"Could not find any posting information in the Controlled Substance package,",!,"balance cannot be updated",!
+14 ;
ESIG KILL X
DO SIG^XUSESIG
IF X["^"
WRITE !,"No signature code entered, RX not returned to stock."
SET RETSK=1
QUIT
+1 IF X1=""
WRITE !,"An Electronic Signature Code is required to return a Controlled Substance RX to stock.",!
GOTO ESIG
ASK SET DIR(0)="Y"
SET DIR("A")="Do you want "_$GET(PSDQTY)_" added to balance in the Narcotic vault"
SET DIR("B")="Yes"
SET DIR("?")="Answer Yes and the amount being returned to stock will be placed in inventory"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO RETERR
+1 IF +Y'>0
WRITE !,"Nothing updated"
GOTO RETERR
LOCATION SET DIC(0)="QEA"
SET DIC="^PSD(58.8,"
SET DIC("A")="Return Drug to which vault: "
+1 SET DIC("S")="I ""MSN""[$P($G(^PSD(58.8,Y,0)),U,2)"
+2 DO ^DIC
KILL DIC
+3 IF "MSN"'[$PIECE($GET(^PSD(58.8,+Y,0)),"^",2)
WRITE !,"Sorry, the location type must be a Master Vault, satellite or narcotic location."
KILL Y
GOTO LOCATION
+4 IF +Y'>0
WRITE !,"No selection made, no balance adjusted."
GOTO RETERR
+5 SET PSDS=+Y
IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,0))
WRITE !,"Sorry, the drug is not stocked in this vault."
KILL PSDS
GOTO LOCATION
+6 SET PSDBAL=$PIECE($GET(^PSD(58.8,+PSDS,1,PSDR,0)),"^",4)
WRITE !,"Previous Balance: ",$GET(PSDBAL)_" New Balance: "_($GET(PSDBAL)+PSDQTY)
+7 WRITE !,"Updating balances"
+8 FOR
LOCK +^PSD(58.8,+PSDS,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+9 DO NOW^%DTC
SET PSDT=+%
SET BAL=+$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)
SET $PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
+10 LOCK -^PSD(58.8,+PSDS,1,PSDR,0)
WRITE "."
+11 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND1 SET PSDA=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSDA))
SET $PIECE(^PSD(58.81,0),"^",3)=PSDA
GOTO FIND1
+1 KILL DA,DIC,DLAYGO
SET (DIC,DLAYGO)=58.81
SET DIC(0)="L"
SET (X,DINUM)=PSDA
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.81,0)
+3 SET PSDNUM1=$PIECE($GET(PSDNUM),"^",2)
+4 SET ^PSD(58.81,PSDA,0)=PSDA_"^3^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_PSDQTY_"^"_DUZ_"^^^"_BAL
+5 SET ^PSD(58.81,PSDA,3)=PSDT_"^"_PSDQTY_"^"_"RX RETURNED TO STOCK"
+6 SET ^PSD(58.81,PSDA,"CS")=1
+7 SET ^PSD(58.81,PSDA,6)=PSDRX_"^"_$SELECT($PIECE(PSDNUM,"^")="R":PSDNUM1,1:"")_"^"_DAT_"^"_$SELECT($PIECE(PSDNUM,"^")="P":PSDNUM1,1:"")_"^"_RXNUM
+8 SET DIK="^PSD(58.81,"
SET DA=PSDA
DO IX^DIK
KILL DA,DIC,DIK
DIE IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,4,0))
SET ^(0)="^58.800119PA^^"
+1 KILL DA,DIC,DD,DO
SET DA(1)=PSDR
SET DA(2)=+PSDS
SET (X,DINUM)=PSDA
SET DIC(0)="L"
SET DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",4,"
DO FILE^DICN
KILL DIC,DINUM
+2 ;monthly activity
+3 IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,5,0))
SET ^(0)="^58.801A^^"
+4 IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,5,$EXTRACT(DT,1,5)*100,0))
KILL DA,DIC
SET DIC="^PSD(58.8,"_+PSDS_",1,"_PSDR_",5,"
SET DIC(0)="LM"
SET DLAYGO=58.8
SET (X,DINUM)=$EXTRACT(DT,1,5)*100
SET DA(2)=+PSDS
SET DA(1)=PSDR
DO ^DIC
KILL DA,DIC,DINUM,DLAYGO
+5 KILL DA,DIE,DR
SET DIE="^PSD(58.8,"_+PSDS_",1,"_PSDR_",5,"
SET DA(2)=+PSDS
SET DA(1)=PSDR
SET DA=$EXTRACT(DT,1,5)*100
SET DR="9////^S X=$P($G(^(0)),""^"",6)+PSDQTY"
DO ^DIE
KILL DA,DIE,DR
RETERR QUIT
RTSCHK ;Check to see if already returned to stock.
+1 DO RTSMUL
+2 SET PSD1=0
+3 IF $DATA(PSDXXX)
SET PSD1=PSDXXX-.1
+4 KILL PSD1MUL,PSDMUL,PSDXXX
+5 SET PSDERR=0
+6 FOR
SET PSD1=$ORDER(^PSD(58.81,"AOP",PSDRX,PSD1))
IF PSD1'>0
QUIT
SET DATA=$GET(^PSD(58.81,PSD1,0))
SET DATA6=$GET(^PSD(58.81,PSD1,6))
Begin DoDot:1
+7 SET PSDFLL=$PIECE(PSDNUM,"^",2)
+8 IF PSDFLL>0
IF $DATA(^PSD(58.81,PSD1,6))
IF $PIECE(^PSD(58.81,PSD1,6),"^",2)=PSDFLL
IF $DATA(^PSD(58.81,PSD1,3))
DO ERRMSG
+9 IF $DATA(^PSD(58.81,PSD1,3))
IF PSDFLL=0
IF '$DATA(^PSD(58.81,PSD1,6))
DO ERRMSG
End DoDot:1
+10 QUIT
ERRMSG SET Y=$PIECE(^PSD(58.81,PSD1,3),"^")
XECUTE ^DD("DD")
SET PSDRTS(1)=Y
SET PSDUSER=$PIECE(^PSD(58.81,PSD1,0),"^",7)
SET PSDUSER=$PIECE(^VA(200,PSDUSER,0),"^")
+1 WRITE !!?8,"According to the Controlled Substances package, this fill/refill",!?8,"was returned to stock on "_PSDRTS(1)_" by "_$GET(PSDUSER)_".",!?16,"Nothing updated in the Controlled Substances package."
+2 SET PSDERR=1
QUIT
RTSMUL DO RTSMUL^PSDOPT1
+1 QUIT
