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

PSDOPT.m

Go to the documentation of this file.
  1. 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
  1. ;Reference to ^PSDRUG( supported by DBIA #221
  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. ;Reference to PSOFUNC supported by DBIA #981
  1. ;Line Tag FINAL^PSOLSET supported by DBIA #982
  1. ;
  1. ;mod.for nois:tua-0498-32173,askp,bc1;ver
  1. ;enhancement for Outpat V7 status code of 12,13,14,15 in askp
  1. ;
  1. ;further modifications related to the deletion of
  1. ;refills made in April 1999
  1. ;
  1. ;PSD*3*39 Kill all variables
  1. D PSDKLL^PSDOPT2
  1. I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
  1. 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
  1. I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH G END
  1. N X,X1 D SIG^XUSESIG I X1="" G END
  1. N LN S (PSDOUT,NEW)=0,PSDUZ=DUZ,$P(LN,"-",80)="",Y=DT
  1. X ^DD("DD") S RPDT=Y
  1. ASKD ;ask disp site
  1. S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
  1. G:$P(PSDSITE,U,5) CHKD
  1. 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)"
  1. S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=$P(PSDSITE,U,4)
  1. W ! D ^DIC K DIC G:Y<0 END
  1. S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
  1. CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no stocked drugs for this Pharmacy Vault!!",!! G END
  1. ASKPH ;ask releasing RPH
  1. S DIC="^VA(200,",DIC(0)="QEAM",DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
  1. S DIC("A")="Please identify Pharmacist for Outpatient Release: "
  1. S:$D(^XUSEC("PSORPH",DUZ)) DIC("B")=$P($G(^VA(200,DUZ,0)),U)
  1. W ! D ^DIC K DIC G:Y<1 END S PSDRPH=+Y
  1. ASKP ;ask rx #
  1. K PSDSEL,PSDPOST,PSDREL
  1. ;PSD*3*30 (Dave Blocker ) Lock the script node
  1. I $G(PSDRX)'="" L -^PSRX(PSDRX)
  1. W ! K DIR,NEW,PSDRX,PSDRXIN,RXNUM S PSDOUT=0 S DIR("A")="Enter/Wand PRESCRIPTION number"
  1. S DIR("?")="^D HELP^PSODISP",DIR(0)="F^1:35" D ^DIR K DIR
  1. G:$D(DTOUT)!($D(DUOUT)) END G:X="" ASKPH
  1. S X=$$UP^XLFSTR(X)
  1. I X'["-" D S PSDRX=$G(PSDRXIN)
  1. .S PSDRX=0 F S PSDRX=$O(^PSRX("B",X,PSDRX)) Q:'PSDRX S PSDRXIN=PSDRX D VER
  1. I X'["-",'$G(PSDRX)!('$D(^PSRX(+$G(PSDRX),0))) W !,"INVALID PRESCRIPTION NUMBER" G ASKP
  1. ;
  1. ;PSD*3*30 - lock the script
  1. I X'["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editing this prescription. Please try again later." K PSDRX G ASKP
  1. ;
  1. ;DAVE B (PSD*3*15) Show previous postings
  1. 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
  1. ;<JD *62
  1. ;
  1. S PSD(1)=X,DIC="^DIC(4,",DR=99,DA=+$P($G(^XMB(1,1,"XUS")),U,17)
  1. K DIQ S DIQ="PSD" D EN^DIQ1 S X=PSD(1) K DIC,DR,DIQ
  1. I X["-",$P(X,"-")'=PSD(4,DA,99) K DA,PSD W !?7,$C(7)," INVALID STATION NUMBER !!",! G ASKP
  1. K DA,PSD
  1. I X["-" S PSDRX=$P(X,"-",2) I (PSDRX'?1N.N.1U) W !?7,$C(7)," INVALID PRESCRIPTION NUMBER" G ASKP
  1. I X["-" I '$D(^PSRX(+$G(PSDRX),0))!($G(PSDRX)']"") W !?7,$C(7)," NON-EXISTENT PRESCRIPTION" G ASKP
  1. ;
  1. 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
  1. I X["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editing this prescription. Please try again later." K PSDRX G ASKP
  1. ;
  1. ; (PSD*3*21) Check for transmission status for barcode entry
  1. ;
  1. G:$D(^PSRX(PSDRX,0)) BC1
  1. W !?7,$C(7)," IMPROPER BARCODE FORMAT" G ASKP
  1. BC1 ;
  1. S PSDRXIN=+PSDRX D VER
  1. I $G(PSDSTA)=13!(+$P($G(^PSRX(+PSDRX,0)),"^",2)=0) W !?7,$C(7)," PRESCRIPTION HAS BEEN DELETED." G ASKP
  1. 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
  1. .S RX0=$G(^PSRX(+PSDRX,0)),RX2=^PSRX(+PSDRX,2),J=PSDRX S $P(RX0,"^",15)=$G(PSDSTA) D ^PSOFUNC
  1. .W !!,$C(7)," Status of ",ST," is not appropriate for selection."
  1. K PSDSTA,PSOVR,PSDRXIN
  1. 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)),"^")
  1. N C S Y=DFN,C=$P(^DD(58.81,73,0),U,2) D Y^DIQ S PATN=Y
  1. D PID^VADPT6
  1. I '$D(^PSD(58.8,+PSDS,1,PSDR,0)) W !!,PSDRN," is not currently stocked in ",PSDSN,".",!!,"** No action taken. **",!! G END
  1. I $D(^PSD(58.81,"AOP",PSDRX)) D ^PSDOPT2 I PSDOUT D MSG G END
  1. G ^PSDOPT0
  1. CHK ;displays and checks if ok
  1. CLLDIR I $D(PSDSEL("OR")) S DIR(0)="S^1:Original;",CNT=1
  1. I $D(PSDSEL("RF")) D
  1. .S X1=0 F S X1=$O(PSDSEL("RF",X1)) Q:X1="" D
  1. ..I $D(PSDRET("RF",X1)),(PSDRET("RF",X1)\1)=$P(PSDSEL("RF",X1),"^") D RTSDTC^PSDOPT2 Q
  1. ..I $D(PSDRET("RF",X1)),PSDRET("RF",X1)<$P(PSDSEL("RF",X1),"^") D CLLDIR2 Q
  1. ..I '$D(PSDRET("RF",X1)) D CLLDIR2 Q
  1. ..Q
  1. I $D(PSDSEL("PR")) D
  1. .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)_");"
  1. I $G(DIR(0))'="" D
  1. .K PSDERR D ^DIR I $D(DIRUT) S PSDERR=1 Q
  1. .S PSDA=$E(Y(0))
  1. Q:$D(PSDERR)
  1. 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
  1. 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
  1. 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
  1. W !,"Error somewhere" G ASKP
  1. PROCESS ;process selection
  1. I PSDA'="O" S PSDFLNO=XXX ;fill number
  1. I PSDA="O" S NEW=1,(NEW(1),NEW(2))=0 ;Original
  1. I PSDA="R" S NEW(1)=XXX,(NEW,NEW(2))=0 ;Refill
  1. I PSDA="P" S NEW(2)=XXX,(NEW,NEW(1))=0 ;Partial
  1. ; p90 Stop processing if med returned to stock and label not reprinted for original fill.
  1. 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
  1. 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
  1. .I NUMBER=0,$G(NEW)=1,$G(NEW(1))=0 D CMOPMSG
  1. .I NUMBER=$G(NEW(1)),$G(NEW)=0,PSDA'="P",'$D(PSDRET("RF",NUMBER)) D CMOPMSG
  1. I $G(PSDOUT)=1 G ASKP
  1. ;
  1. D:PSDA="O" PSDORIG^PSDOPT1 D:PSDA="R" PSDRFL^PSDOPT1 D:PSDA="P" PSDPRTL^PSDOPT1
  1. I $G(PSDOUT)=1 G ASKP
  1. 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.
  1. I $G(PSDPOST)=1,$G(PSDREL)="",'PSDREPR W !,"This fill has already been posted.",$C(7) G ASKP
  1. I $G(PSDREL)'="",$G(PSDPOST)'>0,'PSDREPR W !,"This fill has already been released.",$C(7)
  1. I $G(PSDREL)'="",$G(PSDPOST)>0,'PSDREPR W !,"This fill has already been posted & released, no further action required.",$C(7) G ASKP
  1. D DISPLAY G:PSDOUT END
  1. I $G(PSDQUIT) K PSDQUIT G ASKP ;RTW
  1. K DA,DIR,DIRUT S DIR(0)="YA",DIR("B")="YES",DIR("A")="Is this OK? "
  1. S DIR("?",1)="Answer 'YES' to log this RX transaction in your CS vault,",DIR("?")="answer 'NO' to reselect a prescription, or '^' to quit."
  1. D ^DIR K DIR I Y<1 D MSG G:$D(DIRUT) END G:Y<1 ASKP
  1. D ^PSDOPT1 G ASKP
  1. 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
  1. I $G(PSDRX)'="" L -^PSRX(PSDRX)
  1. K PATN,PHARM,PHARMN,PRF,PSDA,PSDATE,PSDOUT,PSDQUIT,PSDR,PSDRN,PSDRPH,PSDRX,PSDS,PSDSN,PSDT,PSDUZ,PSOCSUB,QTY,RF,RPDT,RXNUM,X,Y
  1. D KVAR^VADPT K VA("PID"),VA("BID")
  1. Q
  1. CHKEY ;check if user has access
  1. I '$D(^XUSEC("PSJ RPHARM",DUZ)) D S PSDOUT=1
  1. .W !!?12,"** You have no access to release this prescription."
  1. .W !?15,"The PSJ RPHARM security key is required. **",!
  1. Q
  1. CLLDIR2 S CNT=$G(CNT)+1,DIR(0)=$S($G(CNT)=1:"S^1:Refill #"_X1,1:DIR(0)_CNT_":Refill #"_X1)_";"
  1. Q
  1. DISPLAY ;disp data
  1. W !!,?20,"View Controlled Substances Rx # ",RXNUM,!,?28,RPDT,!,LN,!!
  1. W "Location: ",?10,PSDSN,?55
  1. S PSDRN(1)=$S(NEW:"Original",$G(NEW(1)):"Refill #"_NEW(1),1:"Partial #"_$G(NEW(2))) W PSDRN(1)
  1. W !,"Drug: ",?10,PSDRN,?55,"Quantity: ",QTY
  1. ;
  1. ;DAVE B (PSD*3*15) check for Non-numeric quantity
  1. I QTY'?.N W !,"The Quantity is not strictly numeric. This will cause the new balance to be",!,"calculated incorrectly.",!
  1. W !,"Patient: ",?10,PATN_" ("_VA("BID")_")",?55,PSDRN(1)," Date: ",?65,$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3),!
  1. 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
  1. S PSDON=$P(PSDSITE,U,3) ;RTW BEGIN NSR20171101
  1. I $D(^PSD(58.8,"BC",1,PSDON)) D ;RTW BALANCE DISCREPANCY CHECK ON OR OFF
  1. . N PSDOUT
  1. . D ^PSDNBAL
  1. . I PSDOUT=1 S PSDQUIT=PSDOUT G MSG Q
  1. Q:$D(PSDQUIT) ;RTW END NSR20171101
  1. W !!,?15,"Old Balance: ",BAL,?40,"New Balance: ",BAL-QTY,!!
  1. Q
  1. MSG W $C(7),!!,"No action taken. This transaction has not been recorded.",!!
  1. Q
  1. VER ;Current Outpatient Version, and Rx status added 6/17/98
  1. 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)
  1. I $G(PSDRXIN) S PSDSTA=$S(PSOVR:$P($G(^PSRX(PSDRXIN,"STA")),"^"),1:$P($G(^PSRX(PSDRXIN,0)),"^",15))
  1. Q
  1. CHKRF ;Dave B (PSD*3*30) if its deleted, show status.
  1. 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.")
  1. ;< JD*62
  1. 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 "="
  1. 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
  1. .I $G(X)'="" S ACTIVITY=$$EXTERNAL^DILFD(52.3,.02,,X)
  1. .S DELDUZ=$$EXTERNAL^DILFD(52.3,.03,,$P(DATA,"^",3)) S DELDUZ=$S($G(DELDUZ)="":"Unknown ("_$P(DATA,"^",3)_")",1:DELDUZ)
  1. .K DELREAS S DELREAS=$P(DATA,"^",5)
  1. .W !,DATE,?22,DELDUZ,?45,ACTIVITY I $G(DELREAS)'="" W !,"Comment: ",$G(DELREAS)
  1. I $G(PSDSTA)'=12 S PSDNEXT=1 Q
  1. ASK12 R !,"Do you wish to continue? NO // ",AN:DTIME S:AN="" AN="N"
  1. I "YyNn"'[AN W !,"Answer 'N'o, and you will prompted for another prescription." G ASK12
  1. I "nN"[AN S PSDNEXT=1 Q
  1. K PSDNEXT
  1. Q
  1. CMOPMSG W !,?10,"This is a CMOP fill and has been transmitted, dispensed or ",!?10,"retransmitted.",! S PSDOUT=1 Q
  1. KLLALL ;Kill all