source: FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDOPT.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.6 KB
Line 
1PSDOPT ;BIR/JPW,LTL,BJW-Outpatient Rx Entry ; 2/5/04 12:15pm
2 ;;3.0; CONTROLLED SUBSTANCES ;**10,11,15,21,30,39,48,62**;13 Feb 97;Build 3
3 ;Reference to ^PSDRUG( supported by DBIA #221
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 PSRX( supported by DBIA #986
7 ;Reference to PSOFUNC supported by DBIA #981
8 ;Line Tag FINAL^PSOLSET supported by DBIA #982
9 ;
10 ;mod.for nois:tua-0498-32173,askp,bc1;ver
11 ;enhancement for Outpat V7 status code of 12,13,14,15 in askp
12 ;
13 ;further modifications related to the deletion of
14 ;refills made in April 1999
15 ;
16 ;PSD*3*39 Kill all variables
17 D PSDKLL^PSDOPT2
18 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
19 I '$D(^XUSEC("PSJ RPHARM",DUZ)) W !!,"Please contact your Pharmacy Coordinator for access",!,"to log Outpatient Prescriptions. PSJ RPHARM security key required.",!! Q
20 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH G END
21 N X,X1 D SIG^XUSESIG I X1="" G END
22 N LN S (PSDOUT,NEW)=0,PSDUZ=DUZ,$P(LN,"-",80)="",Y=DT
23 X ^DD("DD") S RPDT=Y
24ASKD ;ask disp site
25 S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
26 G:$P(PSDSITE,U,5) CHKD
27 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)"
28 S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=$P(PSDSITE,U,4)
29 W ! D ^DIC K DIC G:Y<0 END
30 S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
31CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no stocked drugs for this Pharmacy Vault!!",!! G END
32ASKPH ;ask releasing RPH
33 S DIC="^VA(200,",DIC(0)="QEAM",DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
34 S DIC("A")="Please identify Pharmacist for Outpatient Release: "
35 S:$D(^XUSEC("PSORPH",DUZ)) DIC("B")=$P($G(^VA(200,DUZ,0)),U)
36 W ! D ^DIC K DIC G:Y<1 END S PSDRPH=+Y
37ASKP ;ask rx #
38 K PSDSEL,PSDPOST,PSDREL
39 ;PSD*3*30 (Dave Blocker ) Lock the script node
40 I $G(PSDRX)'="" L -^PSRX(PSDRX)
41 W ! K DIR,NEW,PSDRX,PSDRXIN,RXNUM S PSDOUT=0 S DIR("A")="Enter/Wand PRESCRIPTION number"
42 S DIR("?")="^D HELP^PSODISP",DIR(0)="F^1:35" D ^DIR K DIR
43 G:$D(DTOUT)!($D(DUOUT)) END G:X="" ASKPH
44 S X=$$UP^XLFSTR(X)
45 I X'["-" D S PSDRX=$G(PSDRXIN)
46 .S PSDRX=0 F S PSDRX=$O(^PSRX("B",X,PSDRX)) Q:'PSDRX S PSDRXIN=PSDRX D VER
47 I X'["-",'$G(PSDRX)!('$D(^PSRX(+$G(PSDRX),0))) W !,"INVALID PRESCRIPTION NUMBER" G ASKP
48 ;
49 ;PSD*3*30 - lock the script
50 I X'["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editting this prescription. Please try again later." K PSDRX G ASKP
51 ;
52 ;DAVE B (PSD*3*15) Show previous postings
53 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
54 ;<JD *62
55 ;
56 S PSD(1)=X,DIC="^DIC(4,",DR=99,DA=+$P($G(^XMB(1,1,"XUS")),U,17)
57 K DIQ S DIQ="PSD" D EN^DIQ1 S X=PSD(1) K DIC,DR,DIQ
58 I X["-",$P(X,"-")'=PSD(4,DA,99) K DA,PSD W !?7,$C(7)," INVALID STATION NUMBER !!",! G ASKP
59 K DA,PSD
60 I X["-" S PSDRX=$P(X,"-",2) I (PSDRX'?1N.N.1U) W !?7,$C(7)," INVALID PRESCRIPTION NUMBER" G ASKP
61 I X["-" I '$D(^PSRX(+$G(PSDRX),0))!($G(PSDRX)']"") W !?7,$C(7)," NON-EXISTENT PRESCRIPTION" G ASKP
62 ;
63 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
64 I X["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editting this prescription. Please try again later." K PSDRX G ASKP
65 ;
66 ; (PSD*3*21) Check for transmission status for barcode entry
67 ;
68 G:$D(^PSRX(PSDRX,0)) BC1
69 W !?7,$C(7)," IMPROPER BARCODE FORMAT" G ASKP
70BC1 ;
71 S PSDRXIN=+PSDRX D VER
72 I $G(PSDSTA)=13!(+$P($G(^PSRX(+PSDRX,0)),"^",2)=0) W !?7,$C(7)," PRESCRIPTION HAS BEEN DELETED." G ASKP
73 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
74 .S RX0=$G(^PSRX(+PSDRX,0)),RX2=^PSRX(+PSDRX,2),J=PSDRX S $P(RX0,"^",15)=$G(PSDSTA) D ^PSOFUNC
75 .W !!,$C(7)," Status of ",ST," is not appropriate for selection."
76 K PSDSTA,PSOVR,PSDRXIN
77 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)),"^")
78 N C S Y=DFN,C=$P(^DD(58.81,73,0),U,2) D Y^DIQ S PATN=Y
79 D PID^VADPT6
80 I '$D(^PSD(58.8,+PSDS,1,PSDR,0)) W !!,PSDRN," is not currently stocked in ",PSDSN,".",!!,"** No action taken. **",!! G END
81 I $D(^PSD(58.81,"AOP",PSDRX)) D ^PSDOPT2 I PSDOUT D MSG G END
82 G ^PSDOPT0
83CHK ;displays and checks if ok
84CLLDIR I $D(PSDSEL("OR")) S DIR(0)="S^1:Original;",CNT=1
85 I $D(PSDSEL("RF")) D
86 .S X1=0 F S X1=$O(PSDSEL("RF",X1)) Q:X1="" D
87 ..I $D(PSDRET("RF",X1)),(PSDRET("RF",X1)\1)=$P(PSDSEL("RF",X1),"^") D RTSDTC^PSDOPT2 Q
88 ..I $D(PSDRET("RF",X1)),PSDRET("RF",X1)<$P(PSDSEL("RF",X1),"^") D CLLDIR2 Q
89 ..I '$D(PSDRET("RF",X1)) D CLLDIR2 Q
90 ..Q
91 I $D(PSDSEL("PR")) D
92 .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)_");"
93 I $G(DIR(0))'="" D
94 .K PSDERR D ^DIR I $D(DIRUT) S PSDERR=1 Q
95 .S PSDA=$E(Y(0))
96 Q:$D(PSDERR)
97 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
98 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
99 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
100 W !,"Error somewhere" G ASKP
101PROCESS ;process selection
102 I PSDA'="O" S PSDFLNO=XXX ;fill number
103 I PSDA="O" S NEW=1,(NEW(1),NEW(2))=0 ;Original
104 I PSDA="R" S NEW(1)=XXX,(NEW,NEW(2))=0 ;Refill
105 I PSDA="P" S NEW(2)=XXX,(NEW,NEW(1))=0 ;Partial
106 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
107 .I NUMBER=0,$G(NEW)=1,$G(NEW(1))=0 D CMOPMSG
108 .I NUMBER=$G(NEW(1)),$G(NEW)=0,PSDA'="P",'$D(PSDRET("RF",NUMBER)) D CMOPMSG
109 .;I NUMBER=$G(NEW(2)),$G(NEW(1))=0,$G(NEW)=0 D CMOPMSG ;Partials cannot be CMOP
110 I $G(PSDOUT)=1 G ASKP
111 ;
112 D:PSDA="O" PSDORIG^PSDOPT1 D:PSDA="R" PSDRFL^PSDOPT1 D:PSDA="P" PSDPRTL^PSDOPT1
113 I $G(PSDOUT)=1 G ASKP
114 I $G(PSDPOST)=1,$G(PSDREL)="" W !,"This fill has already been posted." D PSDREL^PSDOPT1 G ASKP
115 I $G(PSDREL)'="",$G(PSDPOST)'>0 W !,"This fill has already been released."
116 I $G(PSDREL)'="",$G(PSDPOST)>0 W !,"This fill has already been posted & released, no further action required." G ASKP
117 D DISPLAY G:PSDOUT END
118 K DA,DIR,DIRUT S DIR(0)="YA",DIR("B")="YES",DIR("A")="Is this OK? "
119 S DIR("?",1)="Answer 'YES' to log this RX transaction in your CS vault,",DIR("?")="answer 'NO' to reselect a prescription, or '^' to quit."
120 D ^DIR K DIR I Y<1 D MSG G:$D(DIRUT) END G:Y<1 ASKP
121 D ^PSDOPT1 G ASKP
122END 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
123 I $G(PSDRX)'="" L -^PSRX(PSDRX)
124 K PATN,PHARM,PHARMN,PRF,PSDA,PSDATE,PSDOUT,PSDR,PSDRN,PSDRPH,PSDRX,PSDS,PSDSN,PSDT,PSDUZ,PSOCSUB,QTY,RF,RPDT,RXNUM,X,Y
125 D KVAR^VADPT K VA("PID"),VA("BID")
126 Q
127CLLDIR2 S CNT=$G(CNT)+1,DIR(0)=$S($G(CNT)=1:"S^1:Refill #"_X1,1:DIR(0)_CNT_":Refill #"_X1)_";"
128 Q
129DISPLAY ;disp data
130 W !!,?20,"View Controlled Substances Rx # ",RXNUM,!,?28,RPDT,!,LN,!!
131 W "Location: ",?10,PSDSN,?55
132 S PSDRN(1)=$S(NEW:"Original",$G(NEW(1)):"Refill #"_NEW(1),1:"Partial #"_$G(NEW(2))) W PSDRN(1)
133 W !,"Drug: ",?10,PSDRN,?55,"Quantity: ",QTY
134 ;
135 ;DAVE B (PSD*3*15) check for Non-numeric quantity
136 I QTY'?.N W !,"The Quantity is not strictly numeric. This will cause the new balance to be",!,"calculated incorrectly.",!
137 W !,"Patient: ",?10,PATN_" ("_VA("BID")_")",?55,PSDRN(1)," Date: ",?65,$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3),!
138 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
139 W !!,?15,"Old Balance: ",BAL,?40,"New Balance: ",BAL-QTY,!!
140 Q
141MSG W $C(7),!!,"No action taken. This transaction has not been recorded.",!!
142 Q
143VER ;Current Outpatient Version, and Rx status added 6/17/98
144 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)
145 I $G(PSDRXIN) S PSDSTA=$S(PSOVR:$P($G(^PSRX(PSDRXIN,"STA")),"^"),1:$P($G(^PSRX(PSDRXIN,0)),"^",15))
146 Q
147CHKRF ;Dave B (PSD*3*30) if its deleted, show status.
148 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.")
149 ;< JD*62
150 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 "="
151 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
152 .I $G(X)'="" S ACTIVITY=$$EXTERNAL^DILFD(52.3,.02,,X)
153 .S DELDUZ=$$EXTERNAL^DILFD(52.3,.03,,$P(DATA,"^",3)) S DELDUZ=$S($G(DELDUZ)="":"Unknown ("_$P(DATA,"^",3)_")",1:DELDUZ)
154 .K DELREAS S DELREAS=$P(DATA,"^",5)
155 .W !,DATE,?22,DELDUZ,?45,ACTIVITY I $G(DELREAS)'="" W !,"Comment: ",$G(DELREAS)
156 I $G(PSDSTA)'=12 S PSDNEXT=1 Q
157ASK12 R !,"Do you wish to continue? NO // ",AN:DTIME S:AN="" AN="N"
158 I "YyNn"'[AN W !,"Answer 'N'o, and you will prompted for another prescription." G ASK12
159 I "nN"[AN S PSDNEXT=1 Q
160 K PSDNEXT
161 Q
162CMOPMSG W !,?10,"This is a CMOP fill and has been transmitted, dispensed or ",!?10,"retransmitted.",! S PSDOUT=1 Q
163KLLALL ;Kill all
Note: See TracBrowser for help on using the repository browser.