Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSDOPT0

PSDOPT0.m

Go to the documentation of this file.
  1. 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
  1. ;Reference to PS(52.5 supported by DBIA #786
  1. ;Reference to PS(59.7 supported by DBIA #1930
  1. ;References to ^PSD(58.8 are covered by DBIA #2711
  1. ;References to file 58.81 are covered by DBIA #2808
  1. ;Reference to ^PSDRUG( supported by DBIA #221
  1. ;Reference to PSRX( supported by DBIA #986
  1. ;called by ^PSDOPT,mod.for nois#:tua-0498-32173
  1. ;08/02/2004 KAM PSD*3*45 Modification to stop posting of the same
  1. ; partial multiple times
  1. LOOP ;loop to find new, refills and partials
  1. W !!,"Accessing the prescription history..."
  1. N PSDOIN,PSDRXFD,PSDSUPN,PSDLBL S PSDOIN=+$P($G(^PS(59.7,1,49.99)),U,2)
  1. ;check for unposted refills not returned to stock and not in suspense
  1. 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
  1. .;checking for suspense
  1. .S PSDRXFD=$E($P(^PSRX(PSDRX,1,JJ,0),U),1,7)
  1. .S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
  1. .I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1 W !!,"Refill #",JJ," suspended." Q
  1. .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
  1. ;
  1. ;check for unposted partials not returned to stock or suspended
  1. ;
  1. 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
  1. .;check for suspense
  1. .S PSDRXFD=$E($P(^PSRX(PSDRX,"P",JJ,0),U),1,7)
  1. .S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
  1. .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
  1. .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
  1. ;
  1. ;original returned to stock
  1. S:$P($G(^PSRX(+PSDRX,2)),U,15) PSDRX(1)=""
  1. ;Check for suspense
  1. I +$P($G(^PSRX(PSDRX,2)),U,2)'<PSDOIN S PSDRXFD=$P(^(2),U,2) D
  1. .S PSDSUPN=$O(^PS(52.5,"B",PSDRX,0))
  1. .I PSDSUPN,$D(^PS(52.5,"C",PSDRXFD,PSDSUPN)),$G(^PS(52.5,PSDSUPN,"P"))'=1 W !!,"Original suspended." S PSDRX(1)="" Q
  1. PSDDAVE ;PSD*3*30 (Major overhaul, Dave B)
  1. ;PSDSEL("RF",#)=refill Date ^ QTY ^ posted (y/n) ^ released date
  1. ;PSDSEL("PR" ''
  1. ;PSDSEL("OR" same thing
  1. ;
  1. I '$D(PSDRX(1)) S $P(PSDSEL("OR"),"^",2)=$P(^PSRX(+PSDRX,0),"^",7) ;Quantity
  1. S $P(PSDSEL("OR"),"^",3)=$P($G(PSDRX("OR",0)),"^",3) ;Posted
  1. 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
  1. I $D(PSDSEL("OR")),$P(PSDSEL("OR"),"^",3)'="",$P(PSDSEL("OR"),"^",4)'="",'$$PSDREPR(+PSDRX) K PSDSEL("OR"),RXNUM("OR")
  1. S (PSDRF1,PSDPR1)=0
  1. RFLCHK ;
  1. S PSDRF1=$O(PSDSEL("RF",PSDRF1)) G PRTLCHK:PSDRF1'>0 S DATA=PSDSEL("RF",PSDRF1)
  1. 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
  1. I $P(PSDSEL("RF",PSDRF1),"^",3)>0,$P(PSDSEL("RF",PSDRF1),"^",4)'="" K PSDSEL("RF",PSDRF1),RXNUM("RF",PSDRF1)
  1. G RFLCHK
  1. ;
  1. PRTLCHK S PSDPR1=$O(PSDSEL("PR",PSDPR1)) G CHKALL:PSDPR1'>0
  1. ; 08/02/2004 PSD*3*45 Added next line
  1. I $D(PSDRX("PR",PSDPR1)) S $P(PSDSEL("PR",PSDPR1),"^",3)=1 ;Posted
  1. I $P($G(^PSRX(+PSDRX,"P",PSDPR1,0)),"^",19)'="" S Y=$P(^(0),"^",19) X ^DD("DD") S $P(PSDSEL("PR",PSDPR1),"^",4)=Y
  1. I $P(PSDSEL("PR",PSDPR1),"^",3)>0,$P(PSDSEL("PR",PSDPR1),"^",4)'="" K PSDSEL("PR",PSDPR1),RXNUM("PR",PSDPR1)
  1. G PRTLCHK
  1. ;
  1. CHKALL ;Check to see if any left to post or release
  1. I $G(PSDERR)=1 G ASKP^PSDOPT
  1. I $O(PSDSEL(0))="" W !!,"ALL FILLS FOR THIS PRESCRIPTION HAVE BEEN POSTED AND RELEASED." G ASKP^PSDOPT
  1. ;
  1. ;Check for DIR call
  1. S CNT=0 K DIR
  1. G CHK^PSDOPT
  1. ;
  1. PSDREPR(PSDRXIN) ; p93
  1. ; Function should return zero to kill PSDSEL("OR") and RXNUM("OR") arrays
  1. Q:$G(^PSRX(PSDRXIN,"RTS",0))="" 0 ;Rx was not RTS
  1. N PSDTT,PSDTRANS,PSDREC,PSDTYPE,PSDLAST,PSDFILL
  1. S PSDTT("POSTED")=$O(^PSD(58.84,"B","OUTPATIENT RX",0)),PSDTT("RTS")=$O(^PSD(58.84,"B","RETURNED TO STOCK",0))
  1. S PSDTRANS=0 F S PSDTRANS=$O(^PSD(58.81,"AOP",PSDRXIN,PSDTRANS)) Q:'PSDTRANS D
  1. . S PSDFILL=$P($G(^PSD(58.81,PSDTRANS,6)),"^",2) Q:PSDFILL
  1. . S PSDREC=$G(^PSD(58.81,PSDTRANS,0)),PSDTYPE=$P(PSDREC,"^",2)
  1. . Q:(PSDTYPE'=PSDTT("POSTED"))&(PSDTYPE'=PSDTT("RTS"))
  1. . S PSDLAST=PSDTYPE
  1. Q:'$G(PSDLAST) 1 ; quit if not posted or not RTS
  1. ; if last trans was RTS then reset post flag in PSDSEL(0) to zero to allow posting
  1. I $P($G(PSDSEL("OR")),"^",3),$G(PSDLAST)=PSDTT("RTS") S $P(PSDSEL("OR"),"^",3)=0 Q 1 ; remove posted flag
  1. Q 0
  1. 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
  1. ; in Outpatient Pharmacy. The code does the following:
  1. ; 1.Check Rx, quit if not a controlled substance.
  1. ; 2.Give the user the option to update the transaction and
  1. ; balance details
  1. ;PSDCS = 1 is controlled subs/0 for not CS
  1. ;PSDRS = 1 they have key, ok to return to stock, 0 - no key
  1. ;Variables:
  1. ;PSDRX = Prescription Number IEN
  1. ;PSDNUM = O^0 = The letter O for original fill and the number0
  1. ; R^# = The letter R for refill and # equal to refill #
  1. ; P^# = The letter P for partial and # equal to partial #
  1. ;PSDSITE = Division
  1. ;PSDQTY = Quantity being returned to stock
  1. ;
  1. ;PSD*3*30 Check for PSDMGR key
  1. S PSDRS=0 I $D(^XUSEC("PSDMGR",DUZ)) S PSDRS=1 ;possess key
  1. 1 ;begin process
  1. I $D(^PSD(58.81,"AOP",PSDRX)) D RTSCHK G RETERR:$G(PSDERR)>0
  1. S PSDOUT=0,RXNUM=$P($G(^PSRX(+PSDRX,0)),"^") ;Prescription Number
  1. S (RPDT,DAT)=$P($G(^PSRX(+PSDRX,2)),"^",2)
  1. S DFN=+$P($G(^PSRX(+PSDRX,0)),"^",2)
  1. S PSDS=$S($G(PSDSITE)["^":$P(PSDSITE,"^",3),1:PSDSITE)
  1. S PSDR=$P($G(^PSRX(+PSDRX,0)),"^",6) I $G(PSDR)'="" S PSDRN=$P($G(^PSDRUG(PSDR,0)),"^")
  1. ;Setup like balance adjustment
  1. S PSDRN=$S($G(PSDRN)="":"Unknown Drug "_PSDR,1:PSDRN)
  1. I $P($G(^PSDRUG(PSDR,2)),"^",3)'["N" S PSDCS=0 Q
  1. S PSDCS=1
  1. I $G(PSDRS)'>0 W !,"Sorry you do not possess the PSDMGR key" G RETERR
  1. ;
  1. POSTED ;check to see if posted
  1. S (JJ,PSDPOST)=0
  1. F S JJ=$O(^PSD(58.81,"AOP",+PSDRX,JJ)) Q:'JJ I $D(^PSD(58.81,JJ,6)) D
  1. .S NODE6=$G(^PSD(58.81,JJ,6))
  1. .I $P(PSDNUM,"^",1)="R",$P(NODE6,"^",2)'="",$P(NODE6,"^",2)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
  1. .I $P(PSDNUM,"^",1)="P",$P(NODE6,"^",4)'="",$P(NODE6,"^",4)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
  1. .I $P(PSDNUM,"^",1)="O",$P(NODE6,"^",4)="",$P(NODE6,"^",2)="" S PSDPOST=1 Q
  1. ;
  1. ;now check to see if CMOP
  1. S X1=0 F S X1=$O(^PSRX(+PSDRX,4,X1)) Q:X1="" S DATA=$G(^PSRX(+PSDRX,4,X1,0)) D
  1. .I $P(PSDNUM,"^",1)="R",$P(DATA,"^",3)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
  1. .I $P(PSDNUM,"^",1)="P",$P(DATA,"^",3)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
  1. .I $P(PSDNUM,"^",1)="O",$P(DATA,"^",3)=$P(PSDNUM,"^",2) S PSDPOST=1 Q
  1. I $G(PSDPOST)'=1 W !!,"Could not find any posting information in the Controlled Substance package,",!,"balance cannot be updated",!
  1. ;
  1. ESIG K X D SIG^XUSESIG I X["^" W !,"No signature code entered, RX not returned to stock." S RETSK=1 Q
  1. I X1="" W !,"An Electronic Signature Code is required to return a Controlled Substance RX to stock.",! G ESIG
  1. 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
  1. I Y=0 S PSDRET=0 D G RETERR
  1. .I '$D(PSDEL) S PSDMSG="RX RETURNED 0 TO STOCK("_PSDQTY_" TO BE DESTROYED)"
  1. .D NOW^%DTC S PSDS=$$PSDS(PSDRX,PSDNUM),PSDT=+%,PSDQTY=0
  1. .I PSDS,$D(^PSD(58.8,+PSDS,1,PSDR,0)) S BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4) D FND1 Q
  1. .W !,"Nothing updated" G RETERR
  1. S:Y'=0 PSDMSG="RX RETURNED TO STOCK"
  1. LOCATION S DIC(0)="QEA",DIC="^PSD(58.8,",DIC("A")="Return Drug to which vault: "
  1. S DIC("S")="I ""MSN""[$P($G(^PSD(58.8,Y,0)),U,2)" D ^DIC K DIC
  1. 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
  1. I X="" W !,"The Vault is required. Please, select a valid Vault or '^' to exit.",$C(7),! G LOCATION
  1. 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
  1. 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
  1. S PSDBAL=$P($G(^PSD(58.8,+PSDS,1,PSDR,0)),"^",4) W !,"Previous Balance: ",$G(PSDBAL)_" New Balance: "_($G(PSDBAL)+PSDQTY)
  1. ;
  1. W !,"Updating balances"
  1. F L +^PSD(58.8,+PSDS,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. D NOW^%DTC S PSDT=+%,BAL=+$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)
  1. S $P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)=$P(^PSD(58.8,+PSDS,1,PSDR,0),"^",4)+PSDQTY
  1. L -^PSD(58.8,+PSDS,1,PSDR,0) W "."
  1. ;
  1. FND1 F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. 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
  1. K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.81,DIC(0)="L",(X,DINUM)=PSDA D ^DIC K DIC,DLAYGO
  1. L -^PSD(58.81,0)
  1. S PSDNUM1=$P($G(PSDNUM),"^",2)
  1. S ^PSD(58.81,PSDA,0)=PSDA_"^3^"_+PSDS_"^"_PSDT_"^"_PSDR_"^"_PSDQTY_"^"_DUZ_"^^^"_BAL
  1. S ^PSD(58.81,PSDA,3)=PSDT_"^"_PSDQTY_"^"_$G(PSDMSG)
  1. S ^PSD(58.81,PSDA,"CS")=1
  1. S ^PSD(58.81,PSDA,6)=PSDRX_"^"_$S($P(PSDNUM,"^")="R":PSDNUM1,1:"")_"^"_DAT_"^"_$S($P(PSDNUM,"^")="P":PSDNUM1,1:"")_"^"_RXNUM
  1. S DIK="^PSD(58.81,",DA=PSDA D IX^DIK K DA,DIC,DIK
  1. DIE I '$D(^PSD(58.8,+PSDS,1,PSDR,4,0)) S ^(0)="^58.800119PA^^"
  1. 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
  1. ;monthly activity
  1. I '$D(^PSD(58.8,+PSDS,1,PSDR,5,0)) S ^(0)="^58.801A^^"
  1. 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
  1. 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
  1. RETERR Q
  1. RTSCHK ;Check to see if already returned to stock.
  1. D RTSMUL
  1. S PSD1=0
  1. S:$D(PSDXXX) PSD1=PSDXXX-.1
  1. K PSD1MUL,PSDMUL,PSDXXX
  1. S PSDERR=0
  1. 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
  1. .S PSDFLL=$P(PSDNUM,"^",2)
  1. .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
  1. .I $D(^PSD(58.81,PSD1,3)),PSDFLL=0,'$D(^PSD(58.81,PSD1,6)) D ERRMSG
  1. Q
  1. 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),"^")
  1. 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."
  1. S PSDERR=1 Q
  1. RTSMUL D RTSMUL^PSDOPT1
  1. Q
  1. PSDS(RXIEN,FLNUM) ; Returns the Vault where the fill was last dispensed from or 0 (none)
  1. ;RXIEN = Prescription Number IEN
  1. ;FLNUM = Fill Number:
  1. ; O^0 = The letter O for original fill and the number 0
  1. ; R^# = The letter R for refill and # equal to refill #
  1. ; P^# = The letter P for partial and # equal to partial #
  1. ;
  1. N PSDS,TRX,NODE0,NODE6 S PSDS=0
  1. S TRX=99999999 F S TRX=$O(^PSD(58.81,"AOP",RXIEN,TRX),-1) Q:'TRX D I PSDS Q
  1. . I $$GET1^DIQ(58.81,TRX,1)="RETURNED TO STOCK" Q ; Not an Outpatient Pharmacy Transaction
  1. . I $$GET1^DIQ(58.81,TRX,34,"I") Q ; Returned To Stock Transaction
  1. . S NODE0=$G(^PSD(58.81,TRX,0)),NODE6=$G(^PSD(58.81,TRX,6))
  1. . I $P(FLNUM,"^")="O",'$P(NODE6,"^",2) S PSDS=+$P(NODE0,"^",3) Q
  1. . I $P(FLNUM,"^")="R",$P(NODE6,"^",2)=$P(FLNUM,"^",2) S PSDS=$P(NODE0,"^",3) Q
  1. . I $P(FLNUM,"^")="P",$P(NODE6,"^",4)=$P(FLNUM,"^",2) S PSDS=$P(NODE0,"^",3) Q
  1. Q PSDS