PSDOPT ;BIR/JPW,LTL,BJW - Outpatient Rx Entry ;Feb 2, 2004@12:15
;;3.0;CONTROLLED SUBSTANCES;**10,11,15,21,30,39,48,62,69,71,79,84,90**;13 Feb 97;Build 4
;Reference to ^PSDRUG( supported by DBIA #221
;References to ^PSD(58.8 are covered by DBIA #2711
;References to file 58.81 are covered by DBIA #2808
;Reference to PSRX( supported by DBIA #986
;Reference to PSOFUNC supported by DBIA #981
;Line Tag FINAL^PSOLSET supported by DBIA #982
;
;mod.for nois:tua-0498-32173,askp,bc1;ver
;enhancement for Outpat V7 status code of 12,13,14,15 in askp
;
;further modifications related to the deletion of
;refills made in April 1999
;
;PSD*3*39 Kill all variables
D PSDKLL^PSDOPT2
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSJ RPHARM",DUZ)),'$D(^XUSEC("PSD TECH ADV",DUZ)) W !!,"Please contact your Pharmacy Coordinator for access",!,"to log Outpatient Prescriptions. Either the PSJ RPHARM",!,"or PSD TECH ADV security key required.",!! Q
I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH G END
N X,X1 D SIG^XUSESIG I X1="" G END
N LN S (PSDOUT,NEW)=0,PSDUZ=DUZ,$P(LN,"-",80)="",Y=DT
X ^DD("DD") S RPDT=Y
ASKD ;ask disp site
S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
G:$P(PSDSITE,U,5) CHKD
K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0),$S('$D(^(""I"")):1,+^(""I"")>DT:1,'^(""I""):1,1:0)"
S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=$P(PSDSITE,U,4)
W ! D ^DIC K DIC G:Y<0 END
S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no stocked drugs for this Pharmacy Vault!!",!! G END
ASKPH ;ask releasing RPH
S DIC="^VA(200,",DIC(0)="QEAM",DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
S DIC("A")="Please identify Pharmacist for Outpatient Release: "
S:$D(^XUSEC("PSORPH",DUZ)) DIC("B")=$P($G(^VA(200,DUZ,0)),U)
W ! D ^DIC K DIC G:Y<1 END S PSDRPH=+Y
ASKP ;ask rx #
K PSDSEL,PSDPOST,PSDREL
;PSD*3*30 (Dave Blocker ) Lock the script node
I $G(PSDRX)'="" L -^PSRX(PSDRX)
W ! K DIR,NEW,PSDRX,PSDRXIN,RXNUM S PSDOUT=0 S DIR("A")="Enter/Wand PRESCRIPTION number"
S DIR("?")="^D HELP^PSODISP",DIR(0)="F^1:35" D ^DIR K DIR
G:$D(DTOUT)!($D(DUOUT)) END G:X="" ASKPH
S X=$$UP^XLFSTR(X)
I X'["-" D S PSDRX=$G(PSDRXIN)
.S PSDRX=0 F S PSDRX=$O(^PSRX("B",X,PSDRX)) Q:'PSDRX S PSDRXIN=PSDRX D VER
I X'["-",'$G(PSDRX)!('$D(^PSRX(+$G(PSDRX),0))) W !,"INVALID PRESCRIPTION NUMBER" G ASKP
;
;PSD*3*30 - lock the script
I X'["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editing this prescription. Please try again later." K PSDRX G ASKP
;
;DAVE B (PSD*3*15) Show previous postings
I X'["-" I $G(PSOVR)=1,$G(PSDSTA)=12!($G(PSDSTA)=13)!($G(PSDSTA)=14)!($G(PSDSTA)=15)!($G(PSDSTA)=11) S PSDXXX=X D CHKRF I $G(PSDNEXT)=1 G ASKP
;<JD *62
;
S PSD(1)=X,DIC="^DIC(4,",DR=99,DA=+$P($G(^XMB(1,1,"XUS")),U,17)
K DIQ S DIQ="PSD" D EN^DIQ1 S X=PSD(1) K DIC,DR,DIQ
I X["-",$P(X,"-")'=PSD(4,DA,99) K DA,PSD W !?7,$C(7)," INVALID STATION NUMBER !!",! G ASKP
K DA,PSD
I X["-" S PSDRX=$P(X,"-",2) I (PSDRX'?1N.N.1U) W !?7,$C(7)," INVALID PRESCRIPTION NUMBER" G ASKP
I X["-" I '$D(^PSRX(+$G(PSDRX),0))!($G(PSDRX)']"") W !?7,$C(7)," NON-EXISTENT PRESCRIPTION" G ASKP
;
I X["-",$D(^PSRX(PSDRX,0)) S PSDRXIN=+PSDRX D VER I PSOVR=1,$G(PSDSTA)=12!($G(PSDSTA)=13)!($G(PSDSTA)=14)!($G(PSDSTA)=15) D CHKRF I $G(PSDNEXT)=1 G ASKP
I X["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editing this prescription. Please try again later." K PSDRX G ASKP
;
; (PSD*3*21) Check for transmission status for barcode entry
;
G:$D(^PSRX(PSDRX,0)) BC1
W !?7,$C(7)," IMPROPER BARCODE FORMAT" G ASKP
BC1 ;
S PSDRXIN=+PSDRX D VER
I $G(PSDSTA)=13!(+$P($G(^PSRX(+PSDRX,0)),"^",2)=0) W !?7,$C(7)," PRESCRIPTION HAS BEEN DELETED." G ASKP
I $G(PSDSTA),$S($G(PSDSTA)=2:0,$G(PSDSTA)=5:0,$G(PSDSTA)=11:0,$G(PSDSTA)=12:0,$G(PSDSTA)=14:0,$G(PSDSTA)=15:0,1:1) D K J,RX0,RX2,ST,ST0 G ASKP
.S RX0=$G(^PSRX(+PSDRX,0)),RX2=^PSRX(+PSDRX,2),J=PSDRX S $P(RX0,"^",15)=$G(PSDSTA) D ^PSOFUNC
.W !!,$C(7)," Status of ",ST," is not appropriate for selection."
K PSDSTA,PSOVR,PSDRXIN
S RXNUM=$P($G(^PSRX(+PSDRX,0)),U),PSDR=+$P($G(^(0)),U,6),DFN=+$P($G(^(0)),U,2),QTY=$P($G(^(0)),U,7),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^")
N C S Y=DFN,C=$P(^DD(58.81,73,0),U,2) D Y^DIQ S PATN=Y
D PID^VADPT6
I '$D(^PSD(58.8,+PSDS,1,PSDR,0)) W !!,PSDRN," is not currently stocked in ",PSDSN,".",!!,"** No action taken. **",!! G END
I $D(^PSD(58.81,"AOP",PSDRX)) D ^PSDOPT2 I PSDOUT D MSG G END
G ^PSDOPT0
CHK ;displays and checks if ok
CLLDIR I $D(PSDSEL("OR")) S DIR(0)="S^1:Original;",CNT=1
I $D(PSDSEL("RF")) D
.S X1=0 F S X1=$O(PSDSEL("RF",X1)) Q:X1="" D
..I $D(PSDRET("RF",X1)),(PSDRET("RF",X1)\1)=$P(PSDSEL("RF",X1),"^") D RTSDTC^PSDOPT2 Q
..I $D(PSDRET("RF",X1)),PSDRET("RF",X1)<$P(PSDSEL("RF",X1),"^") D CLLDIR2 Q
..I '$D(PSDRET("RF",X1)) D CLLDIR2 Q
..Q
I $D(PSDSEL("PR")) D
.S X1=0 F S X1=$O(PSDSEL("PR",X1)) Q:X1="" I '$D(PSDRET("PR",X1)) S CNT=$G(CNT)+1,DIR(0)=$S($G(CNT)=1:"S^1:Partial #"_X1,1:DIR(0)_CNT_":Partial #"_X1)_" ("_$P(PSDSEL("PR",X1),"^",2)_");"
I $G(DIR(0))'="" D
.K PSDERR D ^DIR I $D(DIRUT) S PSDERR=1 Q
.S PSDA=$E(Y(0))
Q:$D(PSDERR)
Q:'$D(Y(0)) I PSDA="O" S DAT=$P($G(^PSRX(PSDRX,2)),U,2),PSDPOST=$P(PSDSEL("OR"),"^",3),PSDREL=$P(PSDSEL("OR"),"^",4) G PROCESS
I PSDA="R" S XX=$P(Y(0),"#",2),XXX=$P(XX," ",1),DAT=$P($G(PSDSEL("RF",XXX)),"^",1),QTY=$P(PSDSEL("RF",XXX),U,2),PSDPOST=$P(PSDSEL("RF",XXX),U,3),PSDREL=$P(PSDSEL("RF",XXX),U,4) G PROCESS
I PSDA="P" S XX=$P(Y(0),"#",2),XXX=$P(XX," ",1),DAT=$P($G(PSDSEL("PR",XXX)),"^",1),QTY=$P(PSDSEL("PR",XXX),U,2),PSDPOST=$P(PSDSEL("PR",XXX),U,3),PSDREL=$P(PSDSEL("PR",XXX),U,4) G PROCESS
W !,"Error somewhere" G ASKP
PROCESS ;process selection
I PSDA'="O" S PSDFLNO=XXX ;fill number
I PSDA="O" S NEW=1,(NEW(1),NEW(2))=0 ;Original
I PSDA="R" S NEW(1)=XXX,(NEW,NEW(2))=0 ;Refill
I PSDA="P" S NEW(2)=XXX,(NEW,NEW(1))=0 ;Partial
; p90 Stop processing if med returned to stock and label not reprinted for original fill.
I PSDA="O",$P($G(^PSRX(PSDRX,2)),U,15),'$P($G(^PSRX(PSDRX,2)),U,14) W !!,"Label not reprinted for this Rx that was returned to stock." G ASKP
S X=0 F S X=$O(^PSRX(PSDRX,4,X)) Q:X'>0 S STATUS=$P($G(^PSRX(PSDRX,4,X,0)),"^",4),NUMBER=$P($G(^PSRX(PSDRX,4,X,0)),"^",3) I $G(STATUS)'=3 D
.I NUMBER=0,$G(NEW)=1,$G(NEW(1))=0 D CMOPMSG
.I NUMBER=$G(NEW(1)),$G(NEW)=0,PSDA'="P",'$D(PSDRET("RF",NUMBER)) D CMOPMSG
I $G(PSDOUT)=1 G ASKP
;
D:PSDA="O" PSDORIG^PSDOPT1 D:PSDA="R" PSDRFL^PSDOPT1 D:PSDA="P" PSDPRTL^PSDOPT1
I $G(PSDOUT)=1 G ASKP
N PSDREPR S PSDREPR=0 S:($G(PSDA)="O")&($$PSDREPR^PSDOPT0($G(PSDRX))) PSDREPR=1 ; p90 Original RX was returned to stock and a label was reprinted.
I $G(PSDPOST)=1,$G(PSDREL)="",'PSDREPR W !,"This fill has already been posted.",$C(7) G ASKP
I $G(PSDREL)'="",$G(PSDPOST)'>0,'PSDREPR W !,"This fill has already been released.",$C(7)
I $G(PSDREL)'="",$G(PSDPOST)>0,'PSDREPR W !,"This fill has already been posted & released, no further action required.",$C(7) G ASKP
D DISPLAY G:PSDOUT END
I $G(PSDQUIT) K PSDQUIT G ASKP ;RTW
K DA,DIR,DIRUT S DIR(0)="YA",DIR("B")="YES",DIR("A")="Is this OK? "
S DIR("?",1)="Answer 'YES' to log this RX transaction in your CS vault,",DIR("?")="answer 'NO' to reselect a prescription, or '^' to quit."
D ^DIR K DIR I Y<1 D MSG G:$D(DIRUT) END G:Y<1 ASKP
D ^PSDOPT1 G ASKP
END K %,%H,%I,BAL,C,CNT,DA,DAT,DD,DFN,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,JJ,LN,NEW,NODE,NODE6 D FINAL^PSOLSET
I $G(PSDRX)'="" L -^PSRX(PSDRX)
K PATN,PHARM,PHARMN,PRF,PSDA,PSDATE,PSDOUT,PSDQUIT,PSDR,PSDRN,PSDRPH,PSDRX,PSDS,PSDSN,PSDT,PSDUZ,PSOCSUB,QTY,RF,RPDT,RXNUM,X,Y
D KVAR^VADPT K VA("PID"),VA("BID")
Q
CHKEY ;check if user has access
I '$D(^XUSEC("PSJ RPHARM",DUZ)) D S PSDOUT=1
.W !!?12,"** You have no access to release this prescription."
.W !?15,"The PSJ RPHARM security key is required. **",!
Q
CLLDIR2 S CNT=$G(CNT)+1,DIR(0)=$S($G(CNT)=1:"S^1:Refill #"_X1,1:DIR(0)_CNT_":Refill #"_X1)_";"
Q
DISPLAY ;disp data
W !!,?20,"View Controlled Substances Rx # ",RXNUM,!,?28,RPDT,!,LN,!!
W "Location: ",?10,PSDSN,?55
S PSDRN(1)=$S(NEW:"Original",$G(NEW(1)):"Refill #"_NEW(1),1:"Partial #"_$G(NEW(2))) W PSDRN(1)
W !,"Drug: ",?10,PSDRN,?55,"Quantity: ",QTY
;
;DAVE B (PSD*3*15) check for Non-numeric quantity
I QTY'?.N W !,"The Quantity is not strictly numeric. This will cause the new balance to be",!,"calculated incorrectly.",!
W !,"Patient: ",?10,PATN_" ("_VA("BID")_")",?55,PSDRN(1)," Date: ",?65,$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3),!
S BAL=+$P($G(^PSD(58.8,+PSDS,1,PSDR,0)),"^",4) I QTY>BAL W !!,?5,"Your balance is ",BAL,".",!,?5,"You may not dispense lower than your balance.",!! D MSG S PSDOUT=1 Q
S PSDON=$P(PSDSITE,U,3) ;RTW BEGIN NSR20171101
I $D(^PSD(58.8,"BC",1,PSDON)) D ;RTW BALANCE DISCREPANCY CHECK ON OR OFF
. N PSDOUT
. D ^PSDNBAL
. I PSDOUT=1 S PSDQUIT=PSDOUT G MSG Q
Q:$D(PSDQUIT) ;RTW END NSR20171101
W !!,?15,"Old Balance: ",BAL,?40,"New Balance: ",BAL-QTY,!!
Q
MSG W $C(7),!!,"No action taken. This transaction has not been recorded.",!!
Q
VER ;Current Outpatient Version, and Rx status added 6/17/98
K PSDSTA S PSDHOLDX=$G(X) S PSOVR=$$VERSION^XPDUTL("PSO") S X=$G(PSDHOLDX) K PSDHOLDX S PSOVR=$S($G(PSOVR)>6:1,1:0)
I $G(PSDRXIN) S PSDSTA=$S(PSOVR:$P($G(^PSRX(PSDRXIN,"STA")),"^"),1:$P($G(^PSRX(PSDRXIN,0)),"^",15))
Q
CHKRF ;Dave B (PSD*3*30) if its deleted, show status.
W !,"This RX has a status of '"_$S(PSDSTA=11:"EXPIRED",PSDSTA=12:"DISCONTINUED",PSDSTA=13:"DELETED",PSDSTA=14:"DISCONTINUED BY PROVIDER",PSDSTA=15:"DISCONTINUED (EDIT)",1:"Unknown Procedure")_$S(PSDSTA=12:"'.",1:"', no action can be taken.")
;< JD*62
I $O(^PSRX(PSDRX,"A",0))>0 W !!,"Below is a list of actions taken on the prescription.",!!,"DATE/TIME",?22,"PERSON",?45,"ACTIVITY",! F X=1:1:53 W "=" F X=1:1:(IOM-1) W "="
S X3=0 F S X3=$O(^PSRX(PSDRX,"A",X3)) Q:X3="" S DATA=$G(^PSRX(PSDRX,"A",X3,0)),Y=$P(DATA,"^",1) X ^DD("DD") S DATE=Y,X=$P(DATA,"^",2) D
.I $G(X)'="" S ACTIVITY=$$EXTERNAL^DILFD(52.3,.02,,X)
.S DELDUZ=$$EXTERNAL^DILFD(52.3,.03,,$P(DATA,"^",3)) S DELDUZ=$S($G(DELDUZ)="":"Unknown ("_$P(DATA,"^",3)_")",1:DELDUZ)
.K DELREAS S DELREAS=$P(DATA,"^",5)
.W !,DATE,?22,DELDUZ,?45,ACTIVITY I $G(DELREAS)'="" W !,"Comment: ",$G(DELREAS)
I $G(PSDSTA)'=12 S PSDNEXT=1 Q
ASK12 R !,"Do you wish to continue? NO // ",AN:DTIME S:AN="" AN="N"
I "YyNn"'[AN W !,"Answer 'N'o, and you will prompted for another prescription." G ASK12
I "nN"[AN S PSDNEXT=1 Q
K PSDNEXT
Q
CMOPMSG W !,?10,"This is a CMOP fill and has been transmitted, dispensed or ",!?10,"retransmitted.",! S PSDOUT=1 Q
KLLALL ;Kill all
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDOPT 10896 printed Oct 16, 2024@17:48:07 Page 2
PSDOPT ;BIR/JPW,LTL,BJW - Outpatient Rx Entry ;Feb 2, 2004@12:15
+1 ;;3.0;CONTROLLED SUBSTANCES;**10,11,15,21,30,39,48,62,69,71,79,84,90**;13 Feb 97;Build 4
+2 ;Reference to ^PSDRUG( supported by DBIA #221
+3 ;References to ^PSD(58.8 are covered by DBIA #2711
+4 ;References to file 58.81 are covered by DBIA #2808
+5 ;Reference to PSRX( supported by DBIA #986
+6 ;Reference to PSOFUNC supported by DBIA #981
+7 ;Line Tag FINAL^PSOLSET supported by DBIA #982
+8 ;
+9 ;mod.for nois:tua-0498-32173,askp,bc1;ver
+10 ;enhancement for Outpat V7 status code of 12,13,14,15 in askp
+11 ;
+12 ;further modifications related to the deletion of
+13 ;refills made in April 1999
+14 ;
+15 ;PSD*3*39 Kill all variables
+16 DO PSDKLL^PSDOPT2
+17 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+18 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
IF '$DATA(^XUSEC("PSD TECH ADV",DUZ))
WRITE !!,"Please contact your Pharmacy Coordinator for access",!,"to log Outpatient Prescriptions. Either the PSJ RPHARM",!,"or PSD TECH ADV security key required.",!!
QUIT
+19 IF $PIECE($GET(^VA(200,DUZ,20)),U,4)']""
NEW XQH
SET XQH="PSD ESIG"
DO EN^XQH
GOTO END
+20 NEW X,X1
DO SIG^XUSESIG
IF X1=""
GOTO END
+21 NEW LN
SET (PSDOUT,NEW)=0
SET PSDUZ=DUZ
SET $PIECE(LN,"-",80)=""
SET Y=DT
+22 XECUTE ^DD("DD")
SET RPDT=Y
ASKD ;ask disp site
+1 SET PSDS=$PIECE(PSDSITE,U,3)
SET PSDSN=$PIECE(PSDSITE,U,4)
+2 if $PIECE(PSDSITE,U,5)
GOTO CHKD
+3 KILL DIC,DA
SET DIC=58.8
SET DIC(0)="QEAZ"
SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0),$S('$D(^(""I"")):1,+^(""I"")>DT:1,'^(""I""):1,1:0)"
+4 SET DIC("A")="Select Primary Dispensing Site: "
SET DIC("B")=$PIECE(PSDSITE,U,4)
+5 WRITE !
DO ^DIC
KILL DIC
if Y<0
GOTO END
+6 SET PSDS=+Y
SET PSDSN=$PIECE(Y,"^",2)
SET $PIECE(PSDSITE,U,3)=+Y
SET $PIECE(PSDSITE,U,4)=PSDSN
CHKD IF '$ORDER(^PSD(58.8,PSDS,1,0))
WRITE !!,"There are no stocked drugs for this Pharmacy Vault!!",!!
GOTO END
ASKPH ;ask releasing RPH
+1 SET DIC="^VA(200,"
SET DIC(0)="QEAM"
SET DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
+2 SET DIC("A")="Please identify Pharmacist for Outpatient Release: "
+3 if $DATA(^XUSEC("PSORPH",DUZ))
SET DIC("B")=$PIECE($GET(^VA(200,DUZ,0)),U)
+4 WRITE !
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET PSDRPH=+Y
ASKP ;ask rx #
+1 KILL PSDSEL,PSDPOST,PSDREL
+2 ;PSD*3*30 (Dave Blocker ) Lock the script node
+3 IF $GET(PSDRX)'=""
LOCK -^PSRX(PSDRX)
+4 WRITE !
KILL DIR,NEW,PSDRX,PSDRXIN,RXNUM
SET PSDOUT=0
SET DIR("A")="Enter/Wand PRESCRIPTION number"
+5 SET DIR("?")="^D HELP^PSODISP"
SET DIR(0)="F^1:35"
DO ^DIR
KILL DIR
+6 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO END
if X=""
GOTO ASKPH
+7 SET X=$$UP^XLFSTR(X)
+8 IF X'["-"
Begin DoDot:1
+9 SET PSDRX=0
FOR
SET PSDRX=$ORDER(^PSRX("B",X,PSDRX))
if 'PSDRX
QUIT
SET PSDRXIN=PSDRX
DO VER
End DoDot:1
SET PSDRX=$GET(PSDRXIN)
+10 IF X'["-"
IF '$GET(PSDRX)!('$DATA(^PSRX(+$GET(PSDRX),0)))
WRITE !,"INVALID PRESCRIPTION NUMBER"
GOTO ASKP
+11 ;
+12 ;PSD*3*30 - lock the script
+13 IF X'["-"
LOCK +^PSRX(PSDRX):5
IF '$TEST
WRITE !!,"Sorry, someone else is editing this prescription. Please try again later."
KILL PSDRX
GOTO ASKP
+14 ;
+15 ;DAVE B (PSD*3*15) Show previous postings
+16 IF X'["-"
IF $GET(PSOVR)=1
IF $GET(PSDSTA)=12!($GET(PSDSTA)=13)!($GET(PSDSTA)=14)!($GET(PSDSTA)=15)!($GET(PSDSTA)=11)
SET PSDXXX=X
DO CHKRF
IF $GET(PSDNEXT)=1
GOTO ASKP
+17 ;<JD *62
+18 ;
+19 SET PSD(1)=X
SET DIC="^DIC(4,"
SET DR=99
SET DA=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
+20 KILL DIQ
SET DIQ="PSD"
DO EN^DIQ1
SET X=PSD(1)
KILL DIC,DR,DIQ
+21 IF X["-"
IF $PIECE(X,"-")'=PSD(4,DA,99)
KILL DA,PSD
WRITE !?7,$CHAR(7)," INVALID STATION NUMBER !!",!
GOTO ASKP
+22 KILL DA,PSD
+23 IF X["-"
SET PSDRX=$PIECE(X,"-",2)
IF (PSDRX'?1N.N.1U)
WRITE !?7,$CHAR(7)," INVALID PRESCRIPTION NUMBER"
GOTO ASKP
+24 IF X["-"
IF '$DATA(^PSRX(+$GET(PSDRX),0))!($GET(PSDRX)']"")
WRITE !?7,$CHAR(7)," NON-EXISTENT PRESCRIPTION"
GOTO ASKP
+25 ;
+26 IF X["-"
IF $DATA(^PSRX(PSDRX,0))
SET PSDRXIN=+PSDRX
DO VER
IF PSOVR=1
IF $GET(PSDSTA)=12!($GET(PSDSTA)=13)!($GET(PSDSTA)=14)!($GET(PSDSTA)=15)
DO CHKRF
IF $GET(PSDNEXT)=1
GOTO ASKP
+27 IF X["-"
LOCK +^PSRX(PSDRX):5
IF '$TEST
WRITE !!,"Sorry, someone else is editing this prescription. Please try again later."
KILL PSDRX
GOTO ASKP
+28 ;
+29 ; (PSD*3*21) Check for transmission status for barcode entry
+30 ;
+31 if $DATA(^PSRX(PSDRX,0))
GOTO BC1
+32 WRITE !?7,$CHAR(7)," IMPROPER BARCODE FORMAT"
GOTO ASKP
BC1 ;
+1 SET PSDRXIN=+PSDRX
DO VER
+2 IF $GET(PSDSTA)=13!(+$PIECE($GET(^PSRX(+PSDRX,0)),"^",2)=0)
WRITE !?7,$CHAR(7)," PRESCRIPTION HAS BEEN DELETED."
GOTO ASKP
+3 IF $GET(PSDSTA)
IF $SELECT($GET(PSDSTA)=2:0,$GET(PSDSTA)=5:0,$GET(PSDSTA)=11:0,$GET(PSDSTA)=12:0,$GET(PSDSTA)=14:0,$GET(PSDSTA)=15:0,1:1)
Begin DoDot:1
+4 SET RX0=$GET(^PSRX(+PSDRX,0))
SET RX2=^PSRX(+PSDRX,2)
SET J=PSDRX
SET $PIECE(RX0,"^",15)=$GET(PSDSTA)
DO ^PSOFUNC
+5 WRITE !!,$CHAR(7)," Status of ",ST," is not appropriate for selection."
End DoDot:1
KILL J,RX0,RX2,ST,ST0
GOTO ASKP
+6 KILL PSDSTA,PSOVR,PSDRXIN
+7 SET RXNUM=$PIECE($GET(^PSRX(+PSDRX,0)),U)
SET PSDR=+$PIECE($GET(^(0)),U,6)
SET DFN=+$PIECE($GET(^(0)),U,2)
SET QTY=$PIECE($GET(^(0)),U,7)
SET PSDRN=$PIECE($GET(^PSDRUG(PSDR,0)),"^")
+8 NEW C
SET Y=DFN
SET C=$PIECE(^DD(58.81,73,0),U,2)
DO Y^DIQ
SET PATN=Y
+9 DO PID^VADPT6
+10 IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,0))
WRITE !!,PSDRN," is not currently stocked in ",PSDSN,".",!!,"** No action taken. **",!!
GOTO END
+11 IF $DATA(^PSD(58.81,"AOP",PSDRX))
DO ^PSDOPT2
IF PSDOUT
DO MSG
GOTO END
+12 GOTO ^PSDOPT0
CHK ;displays and checks if ok
CLLDIR IF $DATA(PSDSEL("OR"))
SET DIR(0)="S^1:Original;"
SET CNT=1
+1 IF $DATA(PSDSEL("RF"))
Begin DoDot:1
+2 SET X1=0
FOR
SET X1=$ORDER(PSDSEL("RF",X1))
if X1=""
QUIT
Begin DoDot:2
+3 IF $DATA(PSDRET("RF",X1))
IF (PSDRET("RF",X1)\1)=$PIECE(PSDSEL("RF",X1),"^")
DO RTSDTC^PSDOPT2
QUIT
+4 IF $DATA(PSDRET("RF",X1))
IF PSDRET("RF",X1)<$PIECE(PSDSEL("RF",X1),"^")
DO CLLDIR2
QUIT
+5 IF '$DATA(PSDRET("RF",X1))
DO CLLDIR2
QUIT
+6 QUIT
End DoDot:2
End DoDot:1
+7 IF $DATA(PSDSEL("PR"))
Begin DoDot:1
+8 SET X1=0
FOR
SET X1=$ORDER(PSDSEL("PR",X1))
if X1=""
QUIT
IF '$DATA(PSDRET("PR",X1))
SET CNT=$GET(CNT)+1
SET DIR(0)=$SELECT($GET(CNT)=1:"S^1:Partial #"_X1,1:DIR(0)_CNT_":Partial #"_X1)_" ("_$PIECE(PSDSEL("PR",X1),"^",2)_");"
End DoDot:1
+9 IF $GET(DIR(0))'=""
Begin DoDot:1
+10 KILL PSDERR
DO ^DIR
IF $DATA(DIRUT)
SET PSDERR=1
QUIT
+11 SET PSDA=$EXTRACT(Y(0))
End DoDot:1
+12 if $DATA(PSDERR)
QUIT
+13 if '$DATA(Y(0))
QUIT
IF PSDA="O"
SET DAT=$PIECE($GET(^PSRX(PSDRX,2)),U,2)
SET PSDPOST=$PIECE(PSDSEL("OR"),"^",3)
SET PSDREL=$PIECE(PSDSEL("OR"),"^",4)
GOTO PROCESS
+14 IF PSDA="R"
SET XX=$PIECE(Y(0),"#",2)
SET XXX=$PIECE(XX," ",1)
SET DAT=$PIECE($GET(PSDSEL("RF",XXX)),"^",1)
SET QTY=$PIECE(PSDSEL("RF",XXX),U,2)
SET PSDPOST=$PIECE(PSDSEL("RF",XXX),U,3)
SET PSDREL=$PIECE(PSDSEL("RF",XXX),U,4)
GOTO PROCESS
+15 IF PSDA="P"
SET XX=$PIECE(Y(0),"#",2)
SET XXX=$PIECE(XX," ",1)
SET DAT=$PIECE($GET(PSDSEL("PR",XXX)),"^",1)
SET QTY=$PIECE(PSDSEL("PR",XXX),U,2)
SET PSDPOST=$PIECE(PSDSEL("PR",XXX),U,3)
SET PSDREL=$PIECE(PSDSEL("PR",XXX),U,4)
GOTO PROCESS
+16 WRITE !,"Error somewhere"
GOTO ASKP
PROCESS ;process selection
+1 ;fill number
IF PSDA'="O"
SET PSDFLNO=XXX
+2 ;Original
IF PSDA="O"
SET NEW=1
SET (NEW(1),NEW(2))=0
+3 ;Refill
IF PSDA="R"
SET NEW(1)=XXX
SET (NEW,NEW(2))=0
+4 ;Partial
IF PSDA="P"
SET NEW(2)=XXX
SET (NEW,NEW(1))=0
+5 ; p90 Stop processing if med returned to stock and label not reprinted for original fill.
+6 IF PSDA="O"
IF $PIECE($GET(^PSRX(PSDRX,2)),U,15)
IF '$PIECE($GET(^PSRX(PSDRX,2)),U,14)
WRITE !!,"Label not reprinted for this Rx that was returned to stock."
GOTO ASKP
+7 SET X=0
FOR
SET X=$ORDER(^PSRX(PSDRX,4,X))
if X'>0
QUIT
SET STATUS=$PIECE($GET(^PSRX(PSDRX,4,X,0)),"^",4)
SET NUMBER=$PIECE($GET(^PSRX(PSDRX,4,X,0)),"^",3)
IF $GET(STATUS)'=3
Begin DoDot:1
+8 IF NUMBER=0
IF $GET(NEW)=1
IF $GET(NEW(1))=0
DO CMOPMSG
+9 IF NUMBER=$GET(NEW(1))
IF $GET(NEW)=0
IF PSDA'="P"
IF '$DATA(PSDRET("RF",NUMBER))
DO CMOPMSG
End DoDot:1
+10 IF $GET(PSDOUT)=1
GOTO ASKP
+11 ;
+12 if PSDA="O"
DO PSDORIG^PSDOPT1
if PSDA="R"
DO PSDRFL^PSDOPT1
if PSDA="P"
DO PSDPRTL^PSDOPT1
+13 IF $GET(PSDOUT)=1
GOTO ASKP
+14 ; p90 Original RX was returned to stock and a label was reprinted.
NEW PSDREPR
SET PSDREPR=0
if ($GET(PSDA)="O")&($$PSDREPR^PSDOPT0($GET(PSDRX)))
SET PSDREPR=1
+15 IF $GET(PSDPOST)=1
IF $GET(PSDREL)=""
IF 'PSDREPR
WRITE !,"This fill has already been posted.",$CHAR(7)
GOTO ASKP
+16 IF $GET(PSDREL)'=""
IF $GET(PSDPOST)'>0
IF 'PSDREPR
WRITE !,"This fill has already been released.",$CHAR(7)
+17 IF $GET(PSDREL)'=""
IF $GET(PSDPOST)>0
IF 'PSDREPR
WRITE !,"This fill has already been posted & released, no further action required.",$CHAR(7)
GOTO ASKP
+18 DO DISPLAY
if PSDOUT
GOTO END
+19 ;RTW
IF $GET(PSDQUIT)
KILL PSDQUIT
GOTO ASKP
+20 KILL DA,DIR,DIRUT
SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A")="Is this OK? "
+21 SET DIR("?",1)="Answer 'YES' to log this RX transaction in your CS vault,"
SET DIR("?")="answer 'NO' to reselect a prescription, or '^' to quit."
+22 DO ^DIR
KILL DIR
IF Y<1
DO MSG
if $DATA(DIRUT)
GOTO END
if Y<1
GOTO ASKP
+23 DO ^PSDOPT1
GOTO ASKP
END KILL %,%H,%I,BAL,C,CNT,DA,DAT,DD,DFN,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,JJ,LN,NEW,NODE,NODE6
DO FINAL^PSOLSET
+1 IF $GET(PSDRX)'=""
LOCK -^PSRX(PSDRX)
+2 KILL PATN,PHARM,PHARMN,PRF,PSDA,PSDATE,PSDOUT,PSDQUIT,PSDR,PSDRN,PSDRPH,PSDRX,PSDS,PSDSN,PSDT,PSDUZ,PSOCSUB,QTY,RF,RPDT,RXNUM,X,Y
+3 DO KVAR^VADPT
KILL VA("PID"),VA("BID")
+4 QUIT
CHKEY ;check if user has access
+1 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
Begin DoDot:1
+2 WRITE !!?12,"** You have no access to release this prescription."
+3 WRITE !?15,"The PSJ RPHARM security key is required. **",!
End DoDot:1
SET PSDOUT=1
+4 QUIT
CLLDIR2 SET CNT=$GET(CNT)+1
SET DIR(0)=$SELECT($GET(CNT)=1:"S^1:Refill #"_X1,1:DIR(0)_CNT_":Refill #"_X1)_";"
+1 QUIT
DISPLAY ;disp data
+1 WRITE !!,?20,"View Controlled Substances Rx # ",RXNUM,!,?28,RPDT,!,LN,!!
+2 WRITE "Location: ",?10,PSDSN,?55
+3 SET PSDRN(1)=$SELECT(NEW:"Original",$GET(NEW(1)):"Refill #"_NEW(1),1:"Partial #"_$GET(NEW(2)))
WRITE PSDRN(1)
+4 WRITE !,"Drug: ",?10,PSDRN,?55,"Quantity: ",QTY
+5 ;
+6 ;DAVE B (PSD*3*15) check for Non-numeric quantity
+7 IF QTY'?.N
WRITE !,"The Quantity is not strictly numeric. This will cause the new balance to be",!,"calculated incorrectly.",!
+8 WRITE !,"Patient: ",?10,PATN_" ("_VA("BID")_")",?55,PSDRN(1)," Date: ",?65,$EXTRACT(DAT,4,5)_"/"_$EXTRACT(DAT,6,7)_"/"_$EXTRACT(DAT,2,3),!
+9 SET BAL=+$PIECE($GET(^PSD(58.8,+PSDS,1,PSDR,0)),"^",4)
IF QTY>BAL
WRITE !!,?5,"Your balance is ",BAL,".",!,?5,"You may not dispense lower than your balance.",!!
DO MSG
SET PSDOUT=1
QUIT
+10 ;RTW BEGIN NSR20171101
SET PSDON=$PIECE(PSDSITE,U,3)
+11 ;RTW BALANCE DISCREPANCY CHECK ON OR OFF
IF $DATA(^PSD(58.8,"BC",1,PSDON))
Begin DoDot:1
+12 NEW PSDOUT
+13 DO ^PSDNBAL
+14 IF PSDOUT=1
SET PSDQUIT=PSDOUT
GOTO MSG
QUIT
End DoDot:1
+15 ;RTW END NSR20171101
if $DATA(PSDQUIT)
QUIT
+16 WRITE !!,?15,"Old Balance: ",BAL,?40,"New Balance: ",BAL-QTY,!!
+17 QUIT
MSG WRITE $CHAR(7),!!,"No action taken. This transaction has not been recorded.",!!
+1 QUIT
VER ;Current Outpatient Version, and Rx status added 6/17/98
+1 KILL PSDSTA
SET PSDHOLDX=$GET(X)
SET PSOVR=$$VERSION^XPDUTL("PSO")
SET X=$GET(PSDHOLDX)
KILL PSDHOLDX
SET PSOVR=$SELECT($GET(PSOVR)>6:1,1:0)
+2 IF $GET(PSDRXIN)
SET PSDSTA=$SELECT(PSOVR:$PIECE($GET(^PSRX(PSDRXIN,"STA")),"^"),1:$PIECE($GET(^PSRX(PSDRXIN,0)),"^",15))
+3 QUIT
CHKRF ;Dave B (PSD*3*30) if its deleted, show status.
+1 WRITE !,"This RX has a status of '"_$SELECT(PSDSTA=11:"EXPIRED",PSDSTA=12:"DISCONTINUED",PSDSTA=13:"DELETED",PSDSTA=14:"DISCONTINUED BY PROVIDER",PSDSTA=15:"DISCONTINUED (EDIT)",1:"Unknown Procedure")_$SELECT(PSDSTA=12:"'.",1:"', no action can
be taken.")
+2 ;< JD*62
+3 IF $ORDER(^PSRX(PSDRX,"A",0))>0
WRITE !!,"Below is a list of actions taken on the prescription.",!!,"DATE/TIME",?22,"PERSON",?45,"ACTIVITY",!
FOR X=1:1:53
WRITE "="
FOR X=1:1:(IOM-1)
WRITE "="
+4 SET X3=0
FOR
SET X3=$ORDER(^PSRX(PSDRX,"A",X3))
if X3=""
QUIT
SET DATA=$GET(^PSRX(PSDRX,"A",X3,0))
SET Y=$PIECE(DATA,"^",1)
XECUTE ^DD("DD")
SET DATE=Y
SET X=$PIECE(DATA,"^",2)
Begin DoDot:1
+5 IF $GET(X)'=""
SET ACTIVITY=$$EXTERNAL^DILFD(52.3,.02,,X)
+6 SET DELDUZ=$$EXTERNAL^DILFD(52.3,.03,,$PIECE(DATA,"^",3))
SET DELDUZ=$SELECT($GET(DELDUZ)="":"Unknown ("_$PIECE(DATA,"^",3)_")",1:DELDUZ)
+7 KILL DELREAS
SET DELREAS=$PIECE(DATA,"^",5)
+8 WRITE !,DATE,?22,DELDUZ,?45,ACTIVITY
IF $GET(DELREAS)'=""
WRITE !,"Comment: ",$GET(DELREAS)
End DoDot:1
+9 IF $GET(PSDSTA)'=12
SET PSDNEXT=1
QUIT
ASK12 READ !,"Do you wish to continue? NO // ",AN:DTIME
if AN=""
SET AN="N"
+1 IF "YyNn"'[AN
WRITE !,"Answer 'N'o, and you will prompted for another prescription."
GOTO ASK12
+2 IF "nN"[AN
SET PSDNEXT=1
QUIT
+3 KILL PSDNEXT
+4 QUIT
CMOPMSG WRITE !,?10,"This is a CMOP fill and has been transmitted, dispensed or ",!?10,"retransmitted.",!
SET PSDOUT=1
QUIT
KLLALL ;Kill all
