source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORESK.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1PSORESK ;BIR/SAB-return to stock ;10/24/06 4:22pm
2 ;;7.0;OUTPATIENT PHARMACY;**15,9,27,40,47,55,85,130,185,184,196,148,201,259,261**;DEC 1997;Build 9
3 ;
4 ;REF/IA
5 ;^PSDRUG/221
6 ;^PS(59.7/694
7 ;L, UL, PSOL, and PSOUL^PSSLOCK/2789
8 ;^PS(55/2228
9 ;PSDRTS^PSDOPT0/3064
10 ;
11 ;*259 - if refill was Not deleted, then stop RTS from continuing
12 ;
13AC I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W !!,"Outpatient Pharmacy Site Parameters are required!" Q
14 S RESK=1 K PSODEF,^UTILITY($J,"PSOPCE") S PSOPCECT=1
15BC K PSOWHERE,PSODEFLG,PSOINVTX,XTYPE W !! S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HP^PSORESK1",DIR(0)="FO" D ^DIR K DIR I $D(DIRUT) K PSODEF G EX
16 I X'["-" D BCI W:'$G(RXP) !,"INVALID Rx" G:'$G(RXP) BC G BC1
17 I X["-" D I $P(X,"-")'=$G(PSORESST) W !,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! K PSORESST G BC
18 .K PSORESST S PSORESSX=$G(X) K PSORESAR S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DIQ="PSORESAR",DR="99" D EN^DIQ1 S PSORESST=$G(PSORESAR(4,DA,99,"I")) K PSORESAR,DIQ,DA,DR S X=$G(PSORESSX) K PSORESSX
19 I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !,$C(7),$C(7),$C(7)," NON-EXISTENT Rx" G BC
20 G:$D(^PSRX(RXP,0)) BC1 W !,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC
21BC1 ;
22 S PSORRDFN=+$P($G(^PSRX(RXP,0)),"^",2)
23 D ICN^PSODPT(PSORRDFN)
24 S PSOPLCK=$$L^PSSLOCK(PSORRDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G BC
25 K PSOPLCK D PSOL^PSSLOCK(RXP) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG D UL^PSSLOCK(+$G(PSORRDFN)) G BC
26 S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD
27 I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 D UL G BC
28 S COPAYFLG=1,QDRUG=$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF
29 S Y="O" I $O(^PSRX(RXP,"P",0)) D I $D(DUOUT)!($D(DTOUT)) D UL G BC
30 .S DIR(0)="SA^O:ORIGINAL;P:PARTIAL",DIR("B")="ORIGINAL",DIR("A",1)="",DIR("A",2)="There are Partials for this Rx.",DIR("A")="Which are you Returning To Stock? "
31 .S DIR("?")=" Press return for Original. Enter 'P' for Partial" D ^DIR K DIR
32 S XTYPE=$S(Y="O":"O",1:"P") G:Y="P" PAR
33 I $P($G(^PSRX(RXP,2)),"^",15) D G BC
34 .W !,$C(7),$C(7),"Original fill for Rx # "_$P(^PSRX(RXP,0),"^")_" was Returned to Stock." D UL
35 I '$P($G(^PSRX(RXP,2)),"^",13) W !,$C(7),$C(7),"Rx # "_$P(^PSRX(RXP,0),"^")_" was NOT released !" D UL G BC
36 S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13),PSOWHERE=$S($D(^PSRX("AR",+$G(PSOLOCRL),RXP,0)):1,1:0)
37 W ! S DIR("B")="YES",DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$P(^PSRX(RXP,0),"^")
38 S DIR("A",2)="for "_$P(^DPT($P(^PSRX(RXP,0),"^",2),0),"^")_" ("_$E($P(^(0),"^",9),6,9)_")",DIR("A")="Drug: "_$P(^PSDRUG($P(^PSRX(RXP,0),"^",6),0),"^")
39 I $G(PSOWHERE) S DIR("A",3)=" ",DIR("A",4)=" *** This prescription was filled at the CMOP *** ",DIR("A",5)=" "
40 S DIR(0)="YO" D ^DIR K DIR I Y=0!($D(DIRUT)) D UL G BC
41 ;ORI
42 D D UL,EX S (RESK,PSOPCECT)=1 G BC
43 .;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
44 .I $T(PSDRTS^PSDOPT0)]"" D PSDRTS^PSDOPT0(RXP,"O^"_0,$P(^PSRX(RXP,2),"^",9),$P(^PSRX(RXP,0),"^",7)) D MSG K PSDS
45 .Q:$G(RETSK)
46 .K PSOINVTX,PSODEFLG I $G(PSOWHERE),$G(^PSDRUG(QDRUG,660.1)) D INVT^PSORXDL I $G(PSODEFLG) W !!?5,"Prescription Not Returned to Stock!",! Q
47 .I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 Q:'$G(COPAYFLG)
48 .;Ask comments until answered, do not allow exiting.
49 .F D I '$D(DIRUT) Q
50 ..K DIR,DUOUT,DTOUT,DIRUT,X,Y
51 ..S DIR(0)="F0^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters."
52 ..S DIR("B")=$S($D(PSODEF):PSODEF,1:"Per Pharmacy Request")
53 ..D ^DIR I $D(DIRUT) W !?5,"Comments are required, 10-75 characters.",! Q
54 ..S (PSODEF,COM)=$G(Y) K DIR,X,Y
55 ..Q
56 .I $G(^PSDRUG(QDRUG,660.1)) D
57 ..I $G(PSOWHERE),'$G(PSOINVTX) Q
58 ..S ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+QTY
59 .I $G(PSOWHERE) K ^PSRX("AR",+$G(PSOLOCRL),RXP,0)
60 .D NOW^%DTC S DA=RXP,DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE,DR,DA Q:$D(Y)
61 .D ACT^PSORESK1 S DA=$O(^PS(52.5,"B",RXP,0)) I DA S DIK="^PS(52.5," D ^DIK
62 .D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
63 .D EN^PSOHLSN1(RXP,"ZD") W !,"Rx # "_$P(^PSRX(RXP,0),"^")_" Returned to Stock.",!
64 .Q
65 ;
66REF I $O(^PSRX(RXP,1,0)),$O(^PSRX(RXP,"P",0)) D I $D(DTOUT)!($D(DUOUT)) D UL G BC
67 .S DIR(0)="SA^R:REFILL;P:PARTIAL",DIR("B")="REFILL",DIR("A",1)="",DIR("A",2)="There are Refills and Partials for this Rx.",DIR("A")="Which are you Returning To Stock? "
68 .S DIR("?")=" Press return for Refill. Enter 'P' for Partial" D ^DIR K DIR
69 I $O(^PSRX(RXP,1,0)),$O(^PSRX(RXP,"P",0)) S XTYPE=$S(Y="R":1,1:"P")
70PAR S:$G(XTYPE)']"" XTYPE=1 S TYPE=0 F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY S TYPE=YY
71 I 'TYPE D UL,EX S (RESK,PSOPCECT)=1 G BC
72 I $P($G(^PSRX(RXP,XTYPE,TYPE,0)),"^",16) W $C(7),!!,"Last Fill Already Returned to Stock !",! D UL,EX S (RESK,PSOPCECT)=1 G BC
73 I '$P(^PSRX(RXP,XTYPE,TYPE,0),"^",$S(XTYPE:18,1:19)) W !!,$C(7),$C(7),$S(XTYPE:"Refill",1:"PARTIAL")_" #"_TYPE_" was NOT released !",! D UL G BC
74 W ! K DIR,DUOUT,DTOUT
75 K PSOLOCRL,PSOWHERE I $G(XTYPE) S PSOLOCRL=$P($G(^PSRX(RXP,XTYPE,+$G(TYPE),0)),"^",18),PSOWHERE=$S($D(^PSRX("AR",+$G(PSOLOCRL),RXP,+$G(TYPE))):1,1:0)
76 W ! S DIR("B")="YES",DIR("A",1)="Are you sure you want to RETURN TO STOCK Rx # "_$P(^PSRX(RXP,0),"^")_$S(XTYPE:" Refill ",1:" Partial ")_"# "_TYPE,DIR(0)="Y"
77 S DIR("A",2)="for "_$P(^DPT($P(^PSRX(RXP,0),"^",2),0),"^")_" ("_$E($P(^(0),"^",9),6,9)_")",DIR("A")="Drug: "_$P(^PSDRUG($P(^PSRX(RXP,0),"^",6),0),"^")
78 I $G(PSOWHERE) S DIR("A",3)=" ",DIR("A",4)=" *** This prescription was filled at the CMOP *** ",DIR("A",5)=" "
79 D ^DIR K DIR I 'Y!($D(DUOUT))!($D(DTOUT)) D UL G BC
80 I $T(PSDRTS^PSDOPT0)]"" D
81 .;VMP OIFO BAY PINES;PSO*7.0*196;KILL PSDS
82 .I XTYPE D PSDRTS^PSDOPT0(RXP,"R^"_TYPE,$P(^PSRX(RXP,1,TYPE,0),"^",9),$P(^(0),"^",4)) D MSG K PSDS Q
83 .D PSDRTS^PSDOPT0(RXP,"P^"_TYPE,$P(^PSRX(RXP,"P",TYPE,0),"^",9),$P(^(0),"^",4)) D MSG K PSDS
84 I $G(RETSK) D UL,EX G BC
85 K PSOINVTX,PSODEFLG I $G(PSOWHERE),$G(^PSDRUG(QDRUG,660.1)) D INVT^PSORXDL I $G(PSODEFLG) W !!?5,"Prescription Not Returned to Stock!",! D UL G BC
86 I XTYPE I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2)) N PSOPFS S:$P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) D UL G BC
87 ;Ask comments until answered, do not allow exiting.
88 F D I '$D(DIRUT) Q
89 .K DIR,DIRUT,DTOUT,DUOUT,X,Y
90 .S DIR(0)="F0^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters."
91 .S DIR("B")=$S($D(PSODEF):PSODEF,1:"Per Pharmacy Request")
92 .D ^DIR K DIR I $D(DIRUT) W !?5,"Comments are required, 10-75 characters.",! Q
93 .Q
94 S (PSODEF,COM)=$G(Y) K X,Y
95 D NOW^%DTC S QTY=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",4) I $G(^PSDRUG(QDRUG,660.1)) D
96 .I $G(PSOWHERE),'$G(PSOINVTX) Q
97 .S ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)+$G(QTY)
98 I $G(PSOWHERE) K ^PSRX("AR",+$G(PSOLOCRL),RXP,$G(TYPE))
99 I XTYPE D REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
100 ;
101 ;save release dates in case can't perform the delete of .01 *259
102 S:XTYPE SVRELDT=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",18)
103 S:'XTYPE SVRELDT=$P(^PSRX(RXP,XTYPE,TYPE,0),"^",19)
104 ;
105 ;del rel date 1st and then attempt to del .01 field
106 S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_","_$S(XTYPE:1,1:"""P""")_",",DR=$S(XTYPE:"17////@",1:"8////@")_";.01///@"
107 W ! D ^DIE
108 ;
109 ;if node still exists then fileman could not delete .01 *259
110 I $D(^PSRX(RXP,XTYPE,TYPE,0)) D G BC
111 . W " - Not Returned!"
112 . S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_","_$S(XTYPE:1,1:"""P""")_","
113 . S DR=$S(XTYPE:"17////",1:"8////")_SVRELDT ;put back saved rel dte
114 . D ^DIE,UL
115 ;
116 ;fall thru and perform RTS for refills/partials
117 D:XTYPE'="P" NPF D ACT^PSORESK1
118 W !!,"Rx # "_$P(^PSRX(RXP,0),"^")_$S(XTYPE:" REFILL",1:" PARTIAL")_" #"_TYPE_" Returned to Stock" S DA=$O(^PS(52.5,"B",RXP,0)) I DA S DIK="^PS(52.5," D ^DIK
119 K PSODISPP S:'XTYPE PSODISPP=1 D:XTYPE EN^PSOHDR("PRES",RXP) D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
120 D UL G BC
121EX ;
122 K DA,DR,DIE,X,X1,X2,Y,RXP,REC,DIR,XDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,I,%,DIRUT,COPAYFLG,PSOINVTX,RESK,PSOPCECT,COM,PSOWHERE,PSOLOCRL,PSODEFLG,PSORRDFN,PSOMSG,PSOPLCK,PSDCS,PSDRS,RETSK
123 K DIC,DIK,PSOPFS
124 Q
125MSG I $G(PSDCS),'$G(PSDRS) W !!,"The PSDMGR key is required to return a CONTROLLED SUBSTANCE Rx to stock and",!,"update corresponding vault balances." S RETSK=1
126 Q
127BCI S RXP=0
128RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP
129 Q
130UL ;
131 I $G(RXP) D PSOUL^PSSLOCK(RXP)
132 D UL^PSSLOCK(+$G(PSORRDFN))
133 Q
134NPF N PSOY I $G(TYPE)-1>0,+$P(^PSRX(RXP,1,TYPE-1,0),"^") D
135 .S X1=+$P(^PSRX(RXP,1,$G(TYPE)-1,0),"^"),X2=$P(^PSRX(RXP,0),"^",8)-10\1
136 .D C^%DTC S PSOY=X,X1=$P(^PSRX(RXP,2),"^",2),X2=TYPE*$P(^PSRX(RXP,0),"^",8)-10\1
137 .D C^%DTC S X=$S(PSOY<X:X,1:PSOY)
138 I $G(TYPE)-1<1 D
139 .S X1=$P(^PSRX(RXP,2),"^",2),X2=$P(^PSRX(RXP,0),"^",8)-10\1
140 .D C^%DTC S:$P(^PSRX(RXP,3),"^",8) X=""
141 I $G(X) S DA=RXP,DIE=52,DR="102///"_X D ^DIE K DIE
142 Q
Note: See TracBrowser for help on using the repository browser.