- PSDOPT0 ;BIR/JPW,LTL,BJW - Outpatient Rx Entry (cont'd) ;Jun 22, 1998@12:15
- ;;3.0;CONTROLLED SUBSTANCES ;**10,30,37,39,45,48,66,79,90,93**;13 Feb 97;Build 6
- ;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
- S $P(PSDSEL("OR"),"^",3)=$P($G(PSDRX("OR",0)),"^",3) ;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)'="",'$$PSDREPR(+PSDRX) 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
- ;
- PSDREPR(PSDRXIN) ; p93
- ; Function should return zero to kill PSDSEL("OR") and RXNUM("OR") arrays
- Q:$G(^PSRX(PSDRXIN,"RTS",0))="" 0 ;Rx was not RTS
- N PSDTT,PSDTRANS,PSDREC,PSDTYPE,PSDLAST,PSDFILL
- S PSDTT("POSTED")=$O(^PSD(58.84,"B","OUTPATIENT RX",0)),PSDTT("RTS")=$O(^PSD(58.84,"B","RETURNED TO STOCK",0))
- S PSDTRANS=0 F S PSDTRANS=$O(^PSD(58.81,"AOP",PSDRXIN,PSDTRANS)) Q:'PSDTRANS D
- . S PSDFILL=$P($G(^PSD(58.81,PSDTRANS,6)),"^",2) Q:PSDFILL
- . S PSDREC=$G(^PSD(58.81,PSDTRANS,0)),PSDTYPE=$P(PSDREC,"^",2)
- . Q:(PSDTYPE'=PSDTT("POSTED"))&(PSDTYPE'=PSDTT("RTS"))
- . S PSDLAST=PSDTYPE
- Q:'$G(PSDLAST) 1 ; quit if not posted or not RTS
- ; if last trans was RTS then reset post flag in PSDSEL(0) to zero to allow posting
- I $P($G(PSDSEL("OR")),"^",3),$G(PSDLAST)=PSDTT("RTS") S $P(PSDSEL("OR"),"^",3)=0 Q 1 ; remove posted flag
- Q 0
- 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) S RETSK=1 G RETERR
- I Y=0 S PSDRET=0 D G RETERR
- .I '$D(PSDEL) S PSDMSG="RX RETURNED 0 TO STOCK("_PSDQTY_" TO BE DESTROYED)"
- .D NOW^%DTC S PSDS=$$PSDS(PSDRX,PSDNUM),PSDT=+%,PSDQTY=0
- .I PSDS,$D(^PSD(58.8,+PSDS,1,PSDR,0)) S BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4) D FND1 Q
- .W !,"Nothing updated" G RETERR
- S:Y'=0 PSDMSG="RX RETURNED TO STOCK"
- 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 $D(DTOUT)!($D(DUOUT)) W !,"No selection made, no balance adjusted." W !!?5,"Prescription Not Returned to Stock!",$C(7),! S RETSK=1 G RETERR
- I X="" W !,"The Vault is required. Please, select a valid Vault or '^' to exit.",$C(7),! G LOCATION
- 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
- 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)
- S $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 "."
- ;
- FND1 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_"^"_$G(PSDMSG)
- 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,PSDRET
- 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
- PSDS(RXIEN,FLNUM) ; Returns the Vault where the fill was last dispensed from or 0 (none)
- ;RXIEN = Prescription Number IEN
- ;FLNUM = Fill Number:
- ; O^0 = The letter O for original fill and the number 0
- ; R^# = The letter R for refill and # equal to refill #
- ; P^# = The letter P for partial and # equal to partial #
- ;
- N PSDS,TRX,NODE0,NODE6 S PSDS=0
- S TRX=99999999 F S TRX=$O(^PSD(58.81,"AOP",RXIEN,TRX),-1) Q:'TRX D I PSDS Q
- . I $$GET1^DIQ(58.81,TRX,1)="RETURNED TO STOCK" Q ; Not an Outpatient Pharmacy Transaction
- . I $$GET1^DIQ(58.81,TRX,34,"I") Q ; Returned To Stock Transaction
- . S NODE0=$G(^PSD(58.81,TRX,0)),NODE6=$G(^PSD(58.81,TRX,6))
- . I $P(FLNUM,"^")="O",'$P(NODE6,"^",2) S PSDS=+$P(NODE0,"^",3) Q
- . I $P(FLNUM,"^")="R",$P(NODE6,"^",2)=$P(FLNUM,"^",2) S PSDS=$P(NODE0,"^",3) Q
- . I $P(FLNUM,"^")="P",$P(NODE6,"^",4)=$P(FLNUM,"^",2) S PSDS=$P(NODE0,"^",3) Q
- Q PSDS
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDOPT0 12134 printed Jan 18, 2025@02:48:31 Page 2
- PSDOPT0 ;BIR/JPW,LTL,BJW - Outpatient Rx Entry (cont'd) ;Jun 22, 1998@12:15
- +1 ;;3.0;CONTROLLED SUBSTANCES ;**10,30,37,39,45,48,66,79,90,93**;13 Feb 97;Build 6
- +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 if $PIECE($GET(^PSRX(+PSDRX,2)),U,15)
- SET PSDRX(1)=""
- +22 ;Check for suspense
- +23 IF +$PIECE($GET(^PSRX(PSDRX,2)),U,2)'<PSDOIN
- SET PSDRXFD=$PIECE(^(2),U,2)
- Begin DoDot:1
- +24 SET PSDSUPN=$ORDER(^PS(52.5,"B",PSDRX,0))
- +25 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
- SET $PIECE(PSDSEL("OR"),"^",3)=$PIECE($GET(PSDRX("OR",0)),"^",3)
- +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)'=""
- IF '$$PSDREPR(+PSDRX)
- 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 ;
- PSDREPR(PSDRXIN) ; p93
- +1 ; Function should return zero to kill PSDSEL("OR") and RXNUM("OR") arrays
- +2 ;Rx was not RTS
- if $GET(^PSRX(PSDRXIN,"RTS",0))=""
- QUIT 0
- +3 NEW PSDTT,PSDTRANS,PSDREC,PSDTYPE,PSDLAST,PSDFILL
- +4 SET PSDTT("POSTED")=$ORDER(^PSD(58.84,"B","OUTPATIENT RX",0))
- SET PSDTT("RTS")=$ORDER(^PSD(58.84,"B","RETURNED TO STOCK",0))
- +5 SET PSDTRANS=0
- FOR
- SET PSDTRANS=$ORDER(^PSD(58.81,"AOP",PSDRXIN,PSDTRANS))
- if 'PSDTRANS
- QUIT
- Begin DoDot:1
- +6 SET PSDFILL=$PIECE($GET(^PSD(58.81,PSDTRANS,6)),"^",2)
- if PSDFILL
- QUIT
- +7 SET PSDREC=$GET(^PSD(58.81,PSDTRANS,0))
- SET PSDTYPE=$PIECE(PSDREC,"^",2)
- +8 if (PSDTYPE'=PSDTT("POSTED"))&(PSDTYPE'=PSDTT("RTS"))
- QUIT
- +9 SET PSDLAST=PSDTYPE
- End DoDot:1
- +10 ; quit if not posted or not RTS
- if '$GET(PSDLAST)
- QUIT 1
- +11 ; if last trans was RTS then reset post flag in PSDSEL(0) to zero to allow posting
- +12 ; remove posted flag
- IF $PIECE($GET(PSDSEL("OR")),"^",3)
- IF $GET(PSDLAST)=PSDTT("RTS")
- SET $PIECE(PSDSEL("OR"),"^",3)=0
- QUIT 1
- +13 QUIT 0
- 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)
- SET RETSK=1
- GOTO RETERR
- +1 IF Y=0
- SET PSDRET=0
- Begin DoDot:1
- +2 IF '$DATA(PSDEL)
- SET PSDMSG="RX RETURNED 0 TO STOCK("_PSDQTY_" TO BE DESTROYED)"
- +3 DO NOW^%DTC
- SET PSDS=$$PSDS(PSDRX,PSDNUM)
- SET PSDT=+%
- SET PSDQTY=0
- +4 IF PSDS
- IF $DATA(^PSD(58.8,+PSDS,1,PSDR,0))
- SET BAL=+$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)
- DO FND1
- QUIT
- +5 WRITE !,"Nothing updated"
- GOTO RETERR
- End DoDot:1
- GOTO RETERR
- +6 if Y'=0
- SET PSDMSG="RX RETURNED TO STOCK"
- 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)"
- DO ^DIC
- KILL DIC
- +2 IF $DATA(DTOUT)!($DATA(DUOUT))
- WRITE !,"No selection made, no balance adjusted."
- WRITE !!?5,"Prescription Not Returned to Stock!",$CHAR(7),!
- SET RETSK=1
- GOTO RETERR
- +3 IF X=""
- WRITE !,"The Vault is required. Please, select a valid Vault or '^' to exit.",$CHAR(7),!
- GOTO LOCATION
- +4 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
- +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 ;
- +8 WRITE !,"Updating balances"
- +9 FOR
- LOCK +^PSD(58.8,+PSDS,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +10 DO NOW^%DTC
- SET PSDT=+%
- SET BAL=+$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)
- +11 SET $PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$PIECE(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
- +12 LOCK -^PSD(58.8,+PSDS,1,PSDR,0)
- WRITE "."
- +13 ;
- FND1 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_"^"_$GET(PSDMSG)
- +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,PSDRET
- 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
- PSDS(RXIEN,FLNUM) ; Returns the Vault where the fill was last dispensed from or 0 (none)
- +1 ;RXIEN = Prescription Number IEN
- +2 ;FLNUM = Fill Number:
- +3 ; O^0 = The letter O for original fill and the number 0
- +4 ; R^# = The letter R for refill and # equal to refill #
- +5 ; P^# = The letter P for partial and # equal to partial #
- +6 ;
- +7 NEW PSDS,TRX,NODE0,NODE6
- SET PSDS=0
- +8 SET TRX=99999999
- FOR
- SET TRX=$ORDER(^PSD(58.81,"AOP",RXIEN,TRX),-1)
- if 'TRX
- QUIT
- Begin DoDot:1
- +9 ; Not an Outpatient Pharmacy Transaction
- IF $$GET1^DIQ(58.81,TRX,1)="RETURNED TO STOCK"
- QUIT
- +10 ; Returned To Stock Transaction
- IF $$GET1^DIQ(58.81,TRX,34,"I")
- QUIT
- +11 SET NODE0=$GET(^PSD(58.81,TRX,0))
- SET NODE6=$GET(^PSD(58.81,TRX,6))
- +12 IF $PIECE(FLNUM,"^")="O"
- IF '$PIECE(NODE6,"^",2)
- SET PSDS=+$PIECE(NODE0,"^",3)
- QUIT
- +13 IF $PIECE(FLNUM,"^")="R"
- IF $PIECE(NODE6,"^",2)=$PIECE(FLNUM,"^",2)
- SET PSDS=$PIECE(NODE0,"^",3)
- QUIT
- +14 IF $PIECE(FLNUM,"^")="P"
- IF $PIECE(NODE6,"^",4)=$PIECE(FLNUM,"^",2)
- SET PSDS=$PIECE(NODE0,"^",3)
- QUIT
- End DoDot:1
- IF PSDS
- QUIT
- +15 QUIT PSDS