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

PSDOPT2.m

Go to the documentation of this file.
  1. PSDOPT2 ;BIR/JPW,LTL - Outpatient Rx Entry (cont. from PSDOPT) ;9 Jan 95
  1. ;;3.0;CONTROLLED SUBSTANCES ;**30,39,48,79**;13 Feb 97;Build 20
  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 PSRX( supported by DBIA #986
  1. ;
  1. ;lists posted cs rxs
  1. 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
  1. W !,!!,"Previously posted transactions for Rx #",RXNUM
  1. I $G(PSDRET)=1 W !,"(RTS) - denotes a Returned to Stock Transaction." S PSDRET=0
  1. W !!,"Date Posted:",?22,"Pharmacist:",?54,"Type:",?70,"Quantity:"
  1. TRANS S PSDJJ=$O(^PSD(58.81,"AOP",PSDRX,PSDJJ)) G Q:'PSDJJ I '$D(^PSD(58.81,PSDJJ,0)) G TRANS
  1. S NODE=^PSD(58.81,PSDJJ,0),NODE6=^PSD(58.81,PSDJJ,6),NODE3=$G(^PSD(58.81,PSDJJ,3))
  1. S PHARM=+$P(NODE,"^",7),PHARMN="" I PHARM S PHARMN=$P($G(^VA(200,PHARM,0)),"^")
  1. S PSDATE=+$P(NODE,"^",4) I PSDATE S Y=PSDATE X ^DD("DD") S PSDATE=Y
  1. S VAULT=+$P(NODE,"^",3),VAULT=$P($G(^PSD(58.8,VAULT,0)),"^")
  1. W:VAULT'=PSDSN !,"Dispensing Site: ",VAULT
  1. 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")
  1. RTS ;PSD*3*39 (6JUL02) - Check for returned to stock
  1. S (PSDDATE3,PSDDATE4)=0
  1. S PSDTYPE=$S($P($G(NODE6),"^",2)'="":"RF",$P($G(NODE6),"^",4)'="":"PR",1:"OR")
  1. S PSDTYPE(1)=$S(PSDTYPE="RF":"Refill",PSDTYPE="PR":"Partial",1:"Original")
  1. S PSDRETN=$S(PSDTYPE="RF":$P(NODE6,"^",2),PSDTYPE="PR":$P(NODE6,"^",4),1:0) ;fill #
  1. S PSDDATE3=$P($G(NODE3),"^") S:$G(PSDDATE3)'="" PSDRET(PSDTYPE,PSDRETN)=PSDDATE3,Y=PSDDATE3 X ^DD("DD") S PSDDATE3(1)=Y
  1. I $G(NODE3)'="" W " (RTS)"
  1. I $G(PSDDATE3)="" G QTY
  1. I $G(PSDTYPE)="OR",$P($G(^PSRX(PSDRX,2)),"^",15)="" K PSDRET("OR",PSDRETN) G QTY
  1. 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
  1. 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
  1. QTY W ?70,$J($P(NODE,U,6),6)
  1. I $P($G(PSDDATE3),".")=$G(PSDDATE4) S PSDRTSE(PSDTYPE,PSDRETN)=""
  1. ;
  1. ;
  1. POST ;Check to see if fill has been released/posted
  1. S PSDRX(PSDTYPE,PSDRETN)="^"_$P($G(NODE),"^",6)_"^1"
  1. I $G(NODE3),'$$RXRLDT^PSOBPSUT(PSDRX,PSDRETN) S $P(PSDRX(PSDTYPE,PSDRETN),"^",3)=""
  1. G TRANS
  1. Q W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="Press <RET> to continue " D ^DIR I 'Y S PSDOUT=1
  1. Q
  1. PSDRTS ;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)
  1. ;Fill data matches RTS date
  1. 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))
  1. ASK 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)
  1. I "YyNn"'[AN D G ASK
  1. .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."
  1. .W !,"Please confirm this.",!
  1. I "nN"[AN W !,$G(PSDTYPE(1))_" will remain marked as returned to stock and unavailable.",! G TRANS
  1. W !,"ok, we'll bypass the returned to stock transaction." K PSDRET(PSDTYPE,PSDRETN) G TRANS
  1. Q
  1. RTSDTC ;; PSD*3*48 ADDED LOGIC FOR WHEN AN RTS IS REISSUED ON THE SAMEDAY.
  1. N AN
  1. I (PSDRET("RF",X1)\1)'=DT D CLLDIR2^PSDOPT Q
  1. 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"
  1. W !!,"Was the fill re-issued AFTER being returned to stock? YES// "
  1. R AN:DTIME Q:AN["^"
  1. S:AN="" AN="Y" S AN=$E(AN)
  1. I AN="Y"!(AN="y") D CLLDIR2^PSDOPT
  1. Q
  1. PSDKLL ;
  1. K PSD,PSDA,PSDATE,PSDBAL,PSDCS,PSDDATE3,PSDDATE4,PSDERR,PSDFILL,PSDFLNO,PSDHOLDX,PSDJJ,PSDLBL,PSDLBLP,PSDNEXT,PSDNUM
  1. K PSDNUM1,PSDOIN,PSDOUT,PSDPOST,PSDPR1,PSDQTY,PSDR,PSDREL,PSDRET,PSDRETN
  1. K PSDRF1,PSDRN,PSDRPH,PSDRS,PSDRTS,PSDRTSE,PSDRX,PSDRXFD
  1. K PSDRXIN,PSDS,PSDSEL,PSDSITE,PSDSN,PSDSTA,PSDSUPN,PSDT,PSDTYPE,PSDUZ
  1. K PSDXXX,PSOCSUB,PSOVR
  1. K QTY,RETSK,RF,RPDT,RX0,RX2,RXNUM
  1. Q