source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDOPT2.m@ 990

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

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1PSDOPT2 ;BIR/JPW,LTL-Outpatient Rx Entry (cont. from PSDOPT); 9 Jan 95
2 ;;3.0; CONTROLLED SUBSTANCES ;**30,39,48**;13 Feb 97
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 ;
7 ;lists posted cs rxs
8 S (PSDJJ,PSDRET,X)=0 F S X=$O(^PSD(58.81,"AOP",PSDRX,X)) Q:X'>0 I $D(^PSD(58.81,X,3)),$P(^PSD(58.81,X,3),"^")'="" S PSDRET=1
9 W !,!!,"Previously posted transactions for Rx #",RXNUM
10 I $G(PSDRET)=1 W !,"(RTS) - denotes a Returned to Stock Transaction." S PSDRET=0
11 W !!,"Date Posted:",?22,"Pharmacist:",?54,"Type:",?70,"Quantity:"
12TRANS S PSDJJ=$O(^PSD(58.81,"AOP",PSDRX,PSDJJ)) G Q:'PSDJJ I '$D(^PSD(58.81,PSDJJ,0)) G TRANS
13 S NODE=^PSD(58.81,PSDJJ,0),NODE6=^PSD(58.81,PSDJJ,6),NODE3=$G(^PSD(58.81,PSDJJ,3))
14 S PHARM=+$P(NODE,"^",7),PHARMN="" I PHARM S PHARMN=$P($G(^VA(200,PHARM,0)),"^")
15 S PSDATE=+$P(NODE,"^",4) I PSDATE S Y=PSDATE X ^DD("DD") S PSDATE=Y
16 S VAULT=+$P(NODE,"^",3),VAULT=$P($G(^PSD(58.8,VAULT,0)),"^")
17 W:VAULT'=PSDSN !,"Dispensing Site: ",VAULT
18 W !,PSDATE,?22,PHARMN,?54,$S($P(NODE6,U,2):"Refill #"_$P(NODE6,U,2),$P(NODE6,U,4):"Partial #"_$P(NODE6,U,4),1:"Original")
19RTS ;PSD*3*39 (6JUL02) - Check for returned to stock
20 S (PSDDATE3,PSDDATE4)=0
21 S PSDTYPE=$S($P($G(NODE6),"^",2)'="":"RF",$P($G(NODE6),"^",4)'="":"PR",1:"OR")
22 S PSDTYPE(1)=$S(PSDTYPE="RF":"Refill",PSDTYPE="PR":"Partial",1:"Original")
23 S PSDRETN=$S(PSDTYPE="RF":$P(NODE6,"^",2),PSDTYPE="PR":$P(NODE6,"^",4),1:0) ;fill #
24 S PSDDATE3=$P($G(NODE3),"^") S:$G(PSDDATE3)'="" PSDRET(PSDTYPE,PSDRETN)=PSDDATE3,Y=PSDDATE3 X ^DD("DD") S PSDDATE3(1)=Y
25 I $G(NODE3)'="" W " (RTS)"
26 I $G(PSDDATE3)="" G QTY
27 I $G(PSDTYPE)="OR",$P($G(^PSRX(PSDRX,2)),"^",15)="" K PSDRET("OR",PSDRETN) G QTY
28 I $G(PSDTYPE)="RF",$D(^PSRX(PSDRX,1,PSDRETN,0)) S PSDDATE4=$P(^PSRX(PSDRX,1,PSDRETN,0),"^") I PSDDATE4>PSDDATE3 K PSDRET("RF",PSDRETN) G QTY
29 I $G(PSDTYPE)="PR",$D(^PSRX(PSDRX,"P",PSDRETN,0)) S PSDDATE4=$P(^PSRX(PSDRX,"P",PSDRETN,0),"^") I PSDDATE4>PSDDATE3 K PSDRET("PR",PSDRETN) G QTY
30QTY W ?70,$J($P(NODE,U,6),6)
31 I $P($G(PSDDATE3),".")=$G(PSDDATE4) S PSDRTSE(PSDTYPE,PSDRETN)=""
32 ;
33 ;
34POST ;Check to see if fill has been released/posted
35 S PSDRX(PSDTYPE,PSDRETN)="^"_$P($G(NODE),"^",6)_"^1"
36 ;; PSD*3*48 RJS ; CHECK TO SEE IF RELEASED.
37 I $G(NODE3),$G(^PSRX(PSDRX,1,PSDRETN,0)),$P(^PSRX(PSDRX,1,PSDRETN,0),"^",18)="" S $P(PSDRX(PSDTYPE,PSDRETN),"^",3)=""
38 G TRANS
39Q W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="Press <RET> to continue " D ^DIR I 'Y S PSDOUT=1
40 Q
41PSDRTS ;PSD*3.0*39 ; The next 10 lines are original code commented out for patch PSD*3*45 (this subroutine was duplicated then modified for testing)
42 ;Fill data matches RTS date
43 W !,?10,PSDTYPE(1)_$S($G(PSDTYPE)="OR":"",1:(" #"_PSDRETN))_" was returned to stock on "_$G(PSDDATE3(1)),!?10,"The prescription shows it re-issued on"_$G(PSDDATE4(1))
44ASK W !!,"Was the fill re-issued AFTER being returned to stock? YES// " R AN:DTIME G Q:AN["^" S:AN="" AN="Y" S AN=$E(AN)
45 I "YyNn"'[AN D G ASK
46 .W !!,"The issue date of the fill is the same day as the return to stock date.",!,"The program believes the fill has been re-issued since being returned to stock."
47 .W !,"Please confirm this.",!
48 I "nN"[AN W !,$G(PSDTYPE(1))_" will remain marked as returned to stock and unavailable.",! G TRANS
49 W !,"ok, we'll bypass the returned to stock transaction." K PSDRET(PSDTYPE,PSDRETN) G TRANS
50 Q
51RTSDTC ;; PSD*3*48 ADDED LOGIC FOR WHEN AN RTS IS REISSUED ON THE SAMEDAY.
52 N AN
53 I (PSDRET("RF",X1)\1)'=DT D CLLDIR2^PSDOPT Q
54 W !,?10,PSDTYPE(1)_$S($G(PSDTYPE)="OR":"",1:(" #"_PSDRETN))_" was returned to stock on "_$G(PSDDATE3(1)),!?10,"The prescription shows it re-issued today"
55 W !!,"Was the fill re-issued AFTER being returned to stock? YES// "
56 R AN:DTIME Q:AN["^"
57 S:AN="" AN="Y" S AN=$E(AN)
58 I AN="Y"!(AN="y") D CLLDIR2^PSDOPT
59 Q
60PSDKLL ;
61 K PSD,PSDA,PSDATE,PSDBAL,PSDCS,PSDDATE3,PSDDATE4,PSDERR,PSDFILL,PSDFLNO,PSDHOLDX,PSDJJ,PSDLBL,PSDLBLP,PSDNEXT,PSDNUM
62 K PSDNUM1,PSDOIN,PSDOUT,PSDPOST,PSDPR1,PSDQTY,PSDR,PSDREL,PSDRET,PSDRETN
63 K PSDRF1,PSDRN,PSDRPH,PSDRS,PSDRTS,PSDRTSE,PSDRX,PSDRXFD
64 K PSDRXIN,PSDS,PSDSEL,PSDSITE,PSDSN,PSDSTA,PSDSUPN,PSDT,PSDTYPE,PSDUZ
65 K PSDXXX,PSOCSUB,PSOVR
66 K QTY,RETSK,RF,RPDT,RX0,RX2,RXNUM
67 Q
Note: See TracBrowser for help on using the repository browser.