- PSDOPT ;BIR/JPW,LTL,BJW - Outpatient Rx Entry ;Feb 2, 2004@12:15
- ;;3.0;CONTROLLED SUBSTANCES;**10,11,15,21,30,39,48,62,69,71,79,84,90**;13 Feb 97;Build 4
- ;Reference to ^PSDRUG( supported by DBIA #221
- ;References to ^PSD(58.8 are covered by DBIA #2711
- ;References to file 58.81 are covered by DBIA #2808
- ;Reference to PSRX( supported by DBIA #986
- ;Reference to PSOFUNC supported by DBIA #981
- ;Line Tag FINAL^PSOLSET supported by DBIA #982
- ;
- ;mod.for nois:tua-0498-32173,askp,bc1;ver
- ;enhancement for Outpat V7 status code of 12,13,14,15 in askp
- ;
- ;further modifications related to the deletion of
- ;refills made in April 1999
- ;
- ;PSD*3*39 Kill all variables
- D PSDKLL^PSDOPT2
- I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
- 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
- I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH G END
- N X,X1 D SIG^XUSESIG I X1="" G END
- N LN S (PSDOUT,NEW)=0,PSDUZ=DUZ,$P(LN,"-",80)="",Y=DT
- X ^DD("DD") S RPDT=Y
- ASKD ;ask disp site
- S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
- G:$P(PSDSITE,U,5) CHKD
- 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)"
- S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=$P(PSDSITE,U,4)
- W ! D ^DIC K DIC G:Y<0 END
- S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
- CHKD I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no stocked drugs for this Pharmacy Vault!!",!! G END
- ASKPH ;ask releasing RPH
- S DIC="^VA(200,",DIC(0)="QEAM",DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
- S DIC("A")="Please identify Pharmacist for Outpatient Release: "
- S:$D(^XUSEC("PSORPH",DUZ)) DIC("B")=$P($G(^VA(200,DUZ,0)),U)
- W ! D ^DIC K DIC G:Y<1 END S PSDRPH=+Y
- ASKP ;ask rx #
- K PSDSEL,PSDPOST,PSDREL
- ;PSD*3*30 (Dave Blocker ) Lock the script node
- I $G(PSDRX)'="" L -^PSRX(PSDRX)
- W ! K DIR,NEW,PSDRX,PSDRXIN,RXNUM S PSDOUT=0 S DIR("A")="Enter/Wand PRESCRIPTION number"
- S DIR("?")="^D HELP^PSODISP",DIR(0)="F^1:35" D ^DIR K DIR
- G:$D(DTOUT)!($D(DUOUT)) END G:X="" ASKPH
- S X=$$UP^XLFSTR(X)
- I X'["-" D S PSDRX=$G(PSDRXIN)
- .S PSDRX=0 F S PSDRX=$O(^PSRX("B",X,PSDRX)) Q:'PSDRX S PSDRXIN=PSDRX D VER
- I X'["-",'$G(PSDRX)!('$D(^PSRX(+$G(PSDRX),0))) W !,"INVALID PRESCRIPTION NUMBER" G ASKP
- ;
- ;PSD*3*30 - lock the script
- I X'["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editing this prescription. Please try again later." K PSDRX G ASKP
- ;
- ;DAVE B (PSD*3*15) Show previous postings
- 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
- ;<JD *62
- ;
- S PSD(1)=X,DIC="^DIC(4,",DR=99,DA=+$P($G(^XMB(1,1,"XUS")),U,17)
- K DIQ S DIQ="PSD" D EN^DIQ1 S X=PSD(1) K DIC,DR,DIQ
- I X["-",$P(X,"-")'=PSD(4,DA,99) K DA,PSD W !?7,$C(7)," INVALID STATION NUMBER !!",! G ASKP
- K DA,PSD
- I X["-" S PSDRX=$P(X,"-",2) I (PSDRX'?1N.N.1U) W !?7,$C(7)," INVALID PRESCRIPTION NUMBER" G ASKP
- I X["-" I '$D(^PSRX(+$G(PSDRX),0))!($G(PSDRX)']"") W !?7,$C(7)," NON-EXISTENT PRESCRIPTION" G ASKP
- ;
- 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
- I X["-" L +^PSRX(PSDRX):5 I '$T W !!,"Sorry, someone else is editing this prescription. Please try again later." K PSDRX G ASKP
- ;
- ; (PSD*3*21) Check for transmission status for barcode entry
- ;
- G:$D(^PSRX(PSDRX,0)) BC1
- W !?7,$C(7)," IMPROPER BARCODE FORMAT" G ASKP
- BC1 ;
- S PSDRXIN=+PSDRX D VER
- I $G(PSDSTA)=13!(+$P($G(^PSRX(+PSDRX,0)),"^",2)=0) W !?7,$C(7)," PRESCRIPTION HAS BEEN DELETED." G ASKP
- 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
- .S RX0=$G(^PSRX(+PSDRX,0)),RX2=^PSRX(+PSDRX,2),J=PSDRX S $P(RX0,"^",15)=$G(PSDSTA) D ^PSOFUNC
- .W !!,$C(7)," Status of ",ST," is not appropriate for selection."
- K PSDSTA,PSOVR,PSDRXIN
- 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)),"^")
- N C S Y=DFN,C=$P(^DD(58.81,73,0),U,2) D Y^DIQ S PATN=Y
- D PID^VADPT6
- I '$D(^PSD(58.8,+PSDS,1,PSDR,0)) W !!,PSDRN," is not currently stocked in ",PSDSN,".",!!,"** No action taken. **",!! G END
- I $D(^PSD(58.81,"AOP",PSDRX)) D ^PSDOPT2 I PSDOUT D MSG G END
- G ^PSDOPT0
- CHK ;displays and checks if ok
- CLLDIR I $D(PSDSEL("OR")) S DIR(0)="S^1:Original;",CNT=1
- I $D(PSDSEL("RF")) D
- .S X1=0 F S X1=$O(PSDSEL("RF",X1)) Q:X1="" D
- ..I $D(PSDRET("RF",X1)),(PSDRET("RF",X1)\1)=$P(PSDSEL("RF",X1),"^") D RTSDTC^PSDOPT2 Q
- ..I $D(PSDRET("RF",X1)),PSDRET("RF",X1)<$P(PSDSEL("RF",X1),"^") D CLLDIR2 Q
- ..I '$D(PSDRET("RF",X1)) D CLLDIR2 Q
- ..Q
- I $D(PSDSEL("PR")) D
- .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)_");"
- I $G(DIR(0))'="" D
- .K PSDERR D ^DIR I $D(DIRUT) S PSDERR=1 Q
- .S PSDA=$E(Y(0))
- Q:$D(PSDERR)
- 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
- 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
- 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
- W !,"Error somewhere" G ASKP
- PROCESS ;process selection
- I PSDA'="O" S PSDFLNO=XXX ;fill number
- I PSDA="O" S NEW=1,(NEW(1),NEW(2))=0 ;Original
- I PSDA="R" S NEW(1)=XXX,(NEW,NEW(2))=0 ;Refill
- I PSDA="P" S NEW(2)=XXX,(NEW,NEW(1))=0 ;Partial
- ; p90 Stop processing if med returned to stock and label not reprinted for original fill.
- 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
- 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
- .I NUMBER=0,$G(NEW)=1,$G(NEW(1))=0 D CMOPMSG
- .I NUMBER=$G(NEW(1)),$G(NEW)=0,PSDA'="P",'$D(PSDRET("RF",NUMBER)) D CMOPMSG
- I $G(PSDOUT)=1 G ASKP
- ;
- D:PSDA="O" PSDORIG^PSDOPT1 D:PSDA="R" PSDRFL^PSDOPT1 D:PSDA="P" PSDPRTL^PSDOPT1
- I $G(PSDOUT)=1 G ASKP
- 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.
- I $G(PSDPOST)=1,$G(PSDREL)="",'PSDREPR W !,"This fill has already been posted.",$C(7) G ASKP
- I $G(PSDREL)'="",$G(PSDPOST)'>0,'PSDREPR W !,"This fill has already been released.",$C(7)
- I $G(PSDREL)'="",$G(PSDPOST)>0,'PSDREPR W !,"This fill has already been posted & released, no further action required.",$C(7) G ASKP
- D DISPLAY G:PSDOUT END
- I $G(PSDQUIT) K PSDQUIT G ASKP ;RTW
- K DA,DIR,DIRUT S DIR(0)="YA",DIR("B")="YES",DIR("A")="Is this OK? "
- S DIR("?",1)="Answer 'YES' to log this RX transaction in your CS vault,",DIR("?")="answer 'NO' to reselect a prescription, or '^' to quit."
- D ^DIR K DIR I Y<1 D MSG G:$D(DIRUT) END G:Y<1 ASKP
- D ^PSDOPT1 G ASKP
- 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
- I $G(PSDRX)'="" L -^PSRX(PSDRX)
- K PATN,PHARM,PHARMN,PRF,PSDA,PSDATE,PSDOUT,PSDQUIT,PSDR,PSDRN,PSDRPH,PSDRX,PSDS,PSDSN,PSDT,PSDUZ,PSOCSUB,QTY,RF,RPDT,RXNUM,X,Y
- D KVAR^VADPT K VA("PID"),VA("BID")
- Q
- CHKEY ;check if user has access
- I '$D(^XUSEC("PSJ RPHARM",DUZ)) D S PSDOUT=1
- .W !!?12,"** You have no access to release this prescription."
- .W !?15,"The PSJ RPHARM security key is required. **",!
- Q
- CLLDIR2 S CNT=$G(CNT)+1,DIR(0)=$S($G(CNT)=1:"S^1:Refill #"_X1,1:DIR(0)_CNT_":Refill #"_X1)_";"
- Q
- DISPLAY ;disp data
- W !!,?20,"View Controlled Substances Rx # ",RXNUM,!,?28,RPDT,!,LN,!!
- W "Location: ",?10,PSDSN,?55
- S PSDRN(1)=$S(NEW:"Original",$G(NEW(1)):"Refill #"_NEW(1),1:"Partial #"_$G(NEW(2))) W PSDRN(1)
- W !,"Drug: ",?10,PSDRN,?55,"Quantity: ",QTY
- ;
- ;DAVE B (PSD*3*15) check for Non-numeric quantity
- I QTY'?.N W !,"The Quantity is not strictly numeric. This will cause the new balance to be",!,"calculated incorrectly.",!
- W !,"Patient: ",?10,PATN_" ("_VA("BID")_")",?55,PSDRN(1)," Date: ",?65,$E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_$E(DAT,2,3),!
- 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
- S PSDON=$P(PSDSITE,U,3) ;RTW BEGIN NSR20171101
- I $D(^PSD(58.8,"BC",1,PSDON)) D ;RTW BALANCE DISCREPANCY CHECK ON OR OFF
- . N PSDOUT
- . D ^PSDNBAL
- . I PSDOUT=1 S PSDQUIT=PSDOUT G MSG Q
- Q:$D(PSDQUIT) ;RTW END NSR20171101
- W !!,?15,"Old Balance: ",BAL,?40,"New Balance: ",BAL-QTY,!!
- Q
- MSG W $C(7),!!,"No action taken. This transaction has not been recorded.",!!
- Q
- VER ;Current Outpatient Version, and Rx status added 6/17/98
- 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)
- I $G(PSDRXIN) S PSDSTA=$S(PSOVR:$P($G(^PSRX(PSDRXIN,"STA")),"^"),1:$P($G(^PSRX(PSDRXIN,0)),"^",15))
- Q
- CHKRF ;Dave B (PSD*3*30) if its deleted, show status.
- 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.")
- ;< JD*62
- 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 "="
- 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
- .I $G(X)'="" S ACTIVITY=$$EXTERNAL^DILFD(52.3,.02,,X)
- .S DELDUZ=$$EXTERNAL^DILFD(52.3,.03,,$P(DATA,"^",3)) S DELDUZ=$S($G(DELDUZ)="":"Unknown ("_$P(DATA,"^",3)_")",1:DELDUZ)
- .K DELREAS S DELREAS=$P(DATA,"^",5)
- .W !,DATE,?22,DELDUZ,?45,ACTIVITY I $G(DELREAS)'="" W !,"Comment: ",$G(DELREAS)
- I $G(PSDSTA)'=12 S PSDNEXT=1 Q
- ASK12 R !,"Do you wish to continue? NO // ",AN:DTIME S:AN="" AN="N"
- I "YyNn"'[AN W !,"Answer 'N'o, and you will prompted for another prescription." G ASK12
- I "nN"[AN S PSDNEXT=1 Q
- K PSDNEXT
- Q
- CMOPMSG W !,?10,"This is a CMOP fill and has been transmitted, dispensed or ",!?10,"retransmitted.",! S PSDOUT=1 Q
- KLLALL ;Kill all
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDOPT 10896 printed Jan 18, 2025@02:48:30 Page 2
- 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
- +2 ;Reference to ^PSDRUG( supported by DBIA #221
- +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 ;Reference to PSOFUNC supported by DBIA #981
- +7 ;Line Tag FINAL^PSOLSET supported by DBIA #982
- +8 ;
- +9 ;mod.for nois:tua-0498-32173,askp,bc1;ver
- +10 ;enhancement for Outpat V7 status code of 12,13,14,15 in askp
- +11 ;
- +12 ;further modifications related to the deletion of
- +13 ;refills made in April 1999
- +14 ;
- +15 ;PSD*3*39 Kill all variables
- +16 DO PSDKLL^PSDOPT2
- +17 IF '$DATA(PSDSITE)
- DO ^PSDSET
- if '$DATA(PSDSITE)
- QUIT
- +18 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
- IF '$DATA(^XUSEC("PSD TECH ADV",DUZ))
- WRITE !!,"Please contact your Pharmacy Coordinator for access",!,"to log Outpatient Prescriptions. Either the PSJ RPHARM",!,"or PSD TECH ADV security key required.",!!
- QUIT
- +19 IF $PIECE($GET(^VA(200,DUZ,20)),U,4)']""
- NEW XQH
- SET XQH="PSD ESIG"
- DO EN^XQH
- GOTO END
- +20 NEW X,X1
- DO SIG^XUSESIG
- IF X1=""
- GOTO END
- +21 NEW LN
- SET (PSDOUT,NEW)=0
- SET PSDUZ=DUZ
- SET $PIECE(LN,"-",80)=""
- SET Y=DT
- +22 XECUTE ^DD("DD")
- SET RPDT=Y
- ASKD ;ask disp site
- +1 SET PSDS=$PIECE(PSDSITE,U,3)
- SET PSDSN=$PIECE(PSDSITE,U,4)
- +2 if $PIECE(PSDSITE,U,5)
- GOTO CHKD
- +3 KILL DIC,DA
- SET DIC=58.8
- SET DIC(0)="QEAZ"
- SET 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)"
- +4 SET DIC("A")="Select Primary Dispensing Site: "
- SET DIC("B")=$PIECE(PSDSITE,U,4)
- +5 WRITE !
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- +6 SET PSDS=+Y
- SET PSDSN=$PIECE(Y,"^",2)
- SET $PIECE(PSDSITE,U,3)=+Y
- SET $PIECE(PSDSITE,U,4)=PSDSN
- CHKD IF '$ORDER(^PSD(58.8,PSDS,1,0))
- WRITE !!,"There are no stocked drugs for this Pharmacy Vault!!",!!
- GOTO END
- ASKPH ;ask releasing RPH
- +1 SET DIC="^VA(200,"
- SET DIC(0)="QEAM"
- SET DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
- +2 SET DIC("A")="Please identify Pharmacist for Outpatient Release: "
- +3 if $DATA(^XUSEC("PSORPH",DUZ))
- SET DIC("B")=$PIECE($GET(^VA(200,DUZ,0)),U)
- +4 WRITE !
- DO ^DIC
- KILL DIC
- if Y<1
- GOTO END
- SET PSDRPH=+Y
- ASKP ;ask rx #
- +1 KILL PSDSEL,PSDPOST,PSDREL
- +2 ;PSD*3*30 (Dave Blocker ) Lock the script node
- +3 IF $GET(PSDRX)'=""
- LOCK -^PSRX(PSDRX)
- +4 WRITE !
- KILL DIR,NEW,PSDRX,PSDRXIN,RXNUM
- SET PSDOUT=0
- SET DIR("A")="Enter/Wand PRESCRIPTION number"
- +5 SET DIR("?")="^D HELP^PSODISP"
- SET DIR(0)="F^1:35"
- DO ^DIR
- KILL DIR
- +6 if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO END
- if X=""
- GOTO ASKPH
- +7 SET X=$$UP^XLFSTR(X)
- +8 IF X'["-"
- Begin DoDot:1
- +9 SET PSDRX=0
- FOR
- SET PSDRX=$ORDER(^PSRX("B",X,PSDRX))
- if 'PSDRX
- QUIT
- SET PSDRXIN=PSDRX
- DO VER
- End DoDot:1
- SET PSDRX=$GET(PSDRXIN)
- +10 IF X'["-"
- IF '$GET(PSDRX)!('$DATA(^PSRX(+$GET(PSDRX),0)))
- WRITE !,"INVALID PRESCRIPTION NUMBER"
- GOTO ASKP
- +11 ;
- +12 ;PSD*3*30 - lock the script
- +13 IF X'["-"
- LOCK +^PSRX(PSDRX):5
- IF '$TEST
- WRITE !!,"Sorry, someone else is editing this prescription. Please try again later."
- KILL PSDRX
- GOTO ASKP
- +14 ;
- +15 ;DAVE B (PSD*3*15) Show previous postings
- +16 IF X'["-"
- IF $GET(PSOVR)=1
- IF $GET(PSDSTA)=12!($GET(PSDSTA)=13)!($GET(PSDSTA)=14)!($GET(PSDSTA)=15)!($GET(PSDSTA)=11)
- SET PSDXXX=X
- DO CHKRF
- IF $GET(PSDNEXT)=1
- GOTO ASKP
- +17 ;<JD *62
- +18 ;
- +19 SET PSD(1)=X
- SET DIC="^DIC(4,"
- SET DR=99
- SET DA=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
- +20 KILL DIQ
- SET DIQ="PSD"
- DO EN^DIQ1
- SET X=PSD(1)
- KILL DIC,DR,DIQ
- +21 IF X["-"
- IF $PIECE(X,"-")'=PSD(4,DA,99)
- KILL DA,PSD
- WRITE !?7,$CHAR(7)," INVALID STATION NUMBER !!",!
- GOTO ASKP
- +22 KILL DA,PSD
- +23 IF X["-"
- SET PSDRX=$PIECE(X,"-",2)
- IF (PSDRX'?1N.N.1U)
- WRITE !?7,$CHAR(7)," INVALID PRESCRIPTION NUMBER"
- GOTO ASKP
- +24 IF X["-"
- IF '$DATA(^PSRX(+$GET(PSDRX),0))!($GET(PSDRX)']"")
- WRITE !?7,$CHAR(7)," NON-EXISTENT PRESCRIPTION"
- GOTO ASKP
- +25 ;
- +26 IF X["-"
- IF $DATA(^PSRX(PSDRX,0))
- SET PSDRXIN=+PSDRX
- DO VER
- IF PSOVR=1
- IF $GET(PSDSTA)=12!($GET(PSDSTA)=13)!($GET(PSDSTA)=14)!($GET(PSDSTA)=15)
- DO CHKRF
- IF $GET(PSDNEXT)=1
- GOTO ASKP
- +27 IF X["-"
- LOCK +^PSRX(PSDRX):5
- IF '$TEST
- WRITE !!,"Sorry, someone else is editing this prescription. Please try again later."
- KILL PSDRX
- GOTO ASKP
- +28 ;
- +29 ; (PSD*3*21) Check for transmission status for barcode entry
- +30 ;
- +31 if $DATA(^PSRX(PSDRX,0))
- GOTO BC1
- +32 WRITE !?7,$CHAR(7)," IMPROPER BARCODE FORMAT"
- GOTO ASKP
- BC1 ;
- +1 SET PSDRXIN=+PSDRX
- DO VER
- +2 IF $GET(PSDSTA)=13!(+$PIECE($GET(^PSRX(+PSDRX,0)),"^",2)=0)
- WRITE !?7,$CHAR(7)," PRESCRIPTION HAS BEEN DELETED."
- GOTO ASKP
- +3 IF $GET(PSDSTA)
- IF $SELECT($GET(PSDSTA)=2:0,$GET(PSDSTA)=5:0,$GET(PSDSTA)=11:0,$GET(PSDSTA)=12:0,$GET(PSDSTA)=14:0,$GET(PSDSTA)=15:0,1:1)
- Begin DoDot:1
- +4 SET RX0=$GET(^PSRX(+PSDRX,0))
- SET RX2=^PSRX(+PSDRX,2)
- SET J=PSDRX
- SET $PIECE(RX0,"^",15)=$GET(PSDSTA)
- DO ^PSOFUNC
- +5 WRITE !!,$CHAR(7)," Status of ",ST," is not appropriate for selection."
- End DoDot:1
- KILL J,RX0,RX2,ST,ST0
- GOTO ASKP
- +6 KILL PSDSTA,PSOVR,PSDRXIN
- +7 SET RXNUM=$PIECE($GET(^PSRX(+PSDRX,0)),U)
- SET PSDR=+$PIECE($GET(^(0)),U,6)
- SET DFN=+$PIECE($GET(^(0)),U,2)
- SET QTY=$PIECE($GET(^(0)),U,7)
- SET PSDRN=$PIECE($GET(^PSDRUG(PSDR,0)),"^")
- +8 NEW C
- SET Y=DFN
- SET C=$PIECE(^DD(58.81,73,0),U,2)
- DO Y^DIQ
- SET PATN=Y
- +9 DO PID^VADPT6
- +10 IF '$DATA(^PSD(58.8,+PSDS,1,PSDR,0))
- WRITE !!,PSDRN," is not currently stocked in ",PSDSN,".",!!,"** No action taken. **",!!
- GOTO END
- +11 IF $DATA(^PSD(58.81,"AOP",PSDRX))
- DO ^PSDOPT2
- IF PSDOUT
- DO MSG
- GOTO END
- +12 GOTO ^PSDOPT0
- CHK ;displays and checks if ok
- CLLDIR IF $DATA(PSDSEL("OR"))
- SET DIR(0)="S^1:Original;"
- SET CNT=1
- +1 IF $DATA(PSDSEL("RF"))
- Begin DoDot:1
- +2 SET X1=0
- FOR
- SET X1=$ORDER(PSDSEL("RF",X1))
- if X1=""
- QUIT
- Begin DoDot:2
- +3 IF $DATA(PSDRET("RF",X1))
- IF (PSDRET("RF",X1)\1)=$PIECE(PSDSEL("RF",X1),"^")
- DO RTSDTC^PSDOPT2
- QUIT
- +4 IF $DATA(PSDRET("RF",X1))
- IF PSDRET("RF",X1)<$PIECE(PSDSEL("RF",X1),"^")
- DO CLLDIR2
- QUIT
- +5 IF '$DATA(PSDRET("RF",X1))
- DO CLLDIR2
- QUIT
- +6 QUIT
- End DoDot:2
- End DoDot:1
- +7 IF $DATA(PSDSEL("PR"))
- Begin DoDot:1
- +8 SET X1=0
- FOR
- SET X1=$ORDER(PSDSEL("PR",X1))
- if X1=""
- QUIT
- IF '$DATA(PSDRET("PR",X1))
- SET CNT=$GET(CNT)+1
- SET DIR(0)=$SELECT($GET(CNT)=1:"S^1:Partial #"_X1,1:DIR(0)_CNT_":Partial #"_X1)_" ("_$PIECE(PSDSEL("PR",X1),"^",2)_");"
- End DoDot:1
- +9 IF $GET(DIR(0))'=""
- Begin DoDot:1
- +10 KILL PSDERR
- DO ^DIR
- IF $DATA(DIRUT)
- SET PSDERR=1
- QUIT
- +11 SET PSDA=$EXTRACT(Y(0))
- End DoDot:1
- +12 if $DATA(PSDERR)
- QUIT
- +13 if '$DATA(Y(0))
- QUIT
- IF PSDA="O"
- SET DAT=$PIECE($GET(^PSRX(PSDRX,2)),U,2)
- SET PSDPOST=$PIECE(PSDSEL("OR"),"^",3)
- SET PSDREL=$PIECE(PSDSEL("OR"),"^",4)
- GOTO PROCESS
- +14 IF PSDA="R"
- SET XX=$PIECE(Y(0),"#",2)
- SET XXX=$PIECE(XX," ",1)
- SET DAT=$PIECE($GET(PSDSEL("RF",XXX)),"^",1)
- SET QTY=$PIECE(PSDSEL("RF",XXX),U,2)
- SET PSDPOST=$PIECE(PSDSEL("RF",XXX),U,3)
- SET PSDREL=$PIECE(PSDSEL("RF",XXX),U,4)
- GOTO PROCESS
- +15 IF PSDA="P"
- SET XX=$PIECE(Y(0),"#",2)
- SET XXX=$PIECE(XX," ",1)
- SET DAT=$PIECE($GET(PSDSEL("PR",XXX)),"^",1)
- SET QTY=$PIECE(PSDSEL("PR",XXX),U,2)
- SET PSDPOST=$PIECE(PSDSEL("PR",XXX),U,3)
- SET PSDREL=$PIECE(PSDSEL("PR",XXX),U,4)
- GOTO PROCESS
- +16 WRITE !,"Error somewhere"
- GOTO ASKP
- PROCESS ;process selection
- +1 ;fill number
- IF PSDA'="O"
- SET PSDFLNO=XXX
- +2 ;Original
- IF PSDA="O"
- SET NEW=1
- SET (NEW(1),NEW(2))=0
- +3 ;Refill
- IF PSDA="R"
- SET NEW(1)=XXX
- SET (NEW,NEW(2))=0
- +4 ;Partial
- IF PSDA="P"
- SET NEW(2)=XXX
- SET (NEW,NEW(1))=0
- +5 ; p90 Stop processing if med returned to stock and label not reprinted for original fill.
- +6 IF PSDA="O"
- IF $PIECE($GET(^PSRX(PSDRX,2)),U,15)
- IF '$PIECE($GET(^PSRX(PSDRX,2)),U,14)
- WRITE !!,"Label not reprinted for this Rx that was returned to stock."
- GOTO ASKP
- +7 SET X=0
- FOR
- SET X=$ORDER(^PSRX(PSDRX,4,X))
- if X'>0
- QUIT
- SET STATUS=$PIECE($GET(^PSRX(PSDRX,4,X,0)),"^",4)
- SET NUMBER=$PIECE($GET(^PSRX(PSDRX,4,X,0)),"^",3)
- IF $GET(STATUS)'=3
- Begin DoDot:1
- +8 IF NUMBER=0
- IF $GET(NEW)=1
- IF $GET(NEW(1))=0
- DO CMOPMSG
- +9 IF NUMBER=$GET(NEW(1))
- IF $GET(NEW)=0
- IF PSDA'="P"
- IF '$DATA(PSDRET("RF",NUMBER))
- DO CMOPMSG
- End DoDot:1
- +10 IF $GET(PSDOUT)=1
- GOTO ASKP
- +11 ;
- +12 if PSDA="O"
- DO PSDORIG^PSDOPT1
- if PSDA="R"
- DO PSDRFL^PSDOPT1
- if PSDA="P"
- DO PSDPRTL^PSDOPT1
- +13 IF $GET(PSDOUT)=1
- GOTO ASKP
- +14 ; p90 Original RX was returned to stock and a label was reprinted.
- NEW PSDREPR
- SET PSDREPR=0
- if ($GET(PSDA)="O")&($$PSDREPR^PSDOPT0($GET(PSDRX)))
- SET PSDREPR=1
- +15 IF $GET(PSDPOST)=1
- IF $GET(PSDREL)=""
- IF 'PSDREPR
- WRITE !,"This fill has already been posted.",$CHAR(7)
- GOTO ASKP
- +16 IF $GET(PSDREL)'=""
- IF $GET(PSDPOST)'>0
- IF 'PSDREPR
- WRITE !,"This fill has already been released.",$CHAR(7)
- +17 IF $GET(PSDREL)'=""
- IF $GET(PSDPOST)>0
- IF 'PSDREPR
- WRITE !,"This fill has already been posted & released, no further action required.",$CHAR(7)
- GOTO ASKP
- +18 DO DISPLAY
- if PSDOUT
- GOTO END
- +19 ;RTW
- IF $GET(PSDQUIT)
- KILL PSDQUIT
- GOTO ASKP
- +20 KILL DA,DIR,DIRUT
- SET DIR(0)="YA"
- SET DIR("B")="YES"
- SET DIR("A")="Is this OK? "
- +21 SET DIR("?",1)="Answer 'YES' to log this RX transaction in your CS vault,"
- SET DIR("?")="answer 'NO' to reselect a prescription, or '^' to quit."
- +22 DO ^DIR
- KILL DIR
- IF Y<1
- DO MSG
- if $DATA(DIRUT)
- GOTO END
- if Y<1
- GOTO ASKP
- +23 DO ^PSDOPT1
- GOTO ASKP
- END KILL %,%H,%I,BAL,C,CNT,DA,DAT,DD,DFN,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,JJ,LN,NEW,NODE,NODE6
- DO FINAL^PSOLSET
- +1 IF $GET(PSDRX)'=""
- LOCK -^PSRX(PSDRX)
- +2 KILL PATN,PHARM,PHARMN,PRF,PSDA,PSDATE,PSDOUT,PSDQUIT,PSDR,PSDRN,PSDRPH,PSDRX,PSDS,PSDSN,PSDT,PSDUZ,PSOCSUB,QTY,RF,RPDT,RXNUM,X,Y
- +3 DO KVAR^VADPT
- KILL VA("PID"),VA("BID")
- +4 QUIT
- CHKEY ;check if user has access
- +1 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
- Begin DoDot:1
- +2 WRITE !!?12,"** You have no access to release this prescription."
- +3 WRITE !?15,"The PSJ RPHARM security key is required. **",!
- End DoDot:1
- SET PSDOUT=1
- +4 QUIT
- CLLDIR2 SET CNT=$GET(CNT)+1
- SET DIR(0)=$SELECT($GET(CNT)=1:"S^1:Refill #"_X1,1:DIR(0)_CNT_":Refill #"_X1)_";"
- +1 QUIT
- DISPLAY ;disp data
- +1 WRITE !!,?20,"View Controlled Substances Rx # ",RXNUM,!,?28,RPDT,!,LN,!!
- +2 WRITE "Location: ",?10,PSDSN,?55
- +3 SET PSDRN(1)=$SELECT(NEW:"Original",$GET(NEW(1)):"Refill #"_NEW(1),1:"Partial #"_$GET(NEW(2)))
- WRITE PSDRN(1)
- +4 WRITE !,"Drug: ",?10,PSDRN,?55,"Quantity: ",QTY
- +5 ;
- +6 ;DAVE B (PSD*3*15) check for Non-numeric quantity
- +7 IF QTY'?.N
- WRITE !,"The Quantity is not strictly numeric. This will cause the new balance to be",!,"calculated incorrectly.",!
- +8 WRITE !,"Patient: ",?10,PATN_" ("_VA("BID")_")",?55,PSDRN(1)," Date: ",?65,$EXTRACT(DAT,4,5)_"/"_$EXTRACT(DAT,6,7)_"/"_$EXTRACT(DAT,2,3),!
- +9 SET BAL=+$PIECE($GET(^PSD(58.8,+PSDS,1,PSDR,0)),"^",4)
- IF QTY>BAL
- WRITE !!,?5,"Your balance is ",BAL,".",!,?5,"You may not dispense lower than your balance.",!!
- DO MSG
- SET PSDOUT=1
- QUIT
- +10 ;RTW BEGIN NSR20171101
- SET PSDON=$PIECE(PSDSITE,U,3)
- +11 ;RTW BALANCE DISCREPANCY CHECK ON OR OFF
- IF $DATA(^PSD(58.8,"BC",1,PSDON))
- Begin DoDot:1
- +12 NEW PSDOUT
- +13 DO ^PSDNBAL
- +14 IF PSDOUT=1
- SET PSDQUIT=PSDOUT
- GOTO MSG
- QUIT
- End DoDot:1
- +15 ;RTW END NSR20171101
- if $DATA(PSDQUIT)
- QUIT
- +16 WRITE !!,?15,"Old Balance: ",BAL,?40,"New Balance: ",BAL-QTY,!!
- +17 QUIT
- MSG WRITE $CHAR(7),!!,"No action taken. This transaction has not been recorded.",!!
- +1 QUIT
- VER ;Current Outpatient Version, and Rx status added 6/17/98
- +1 KILL PSDSTA
- SET PSDHOLDX=$GET(X)
- SET PSOVR=$$VERSION^XPDUTL("PSO")
- SET X=$GET(PSDHOLDX)
- KILL PSDHOLDX
- SET PSOVR=$SELECT($GET(PSOVR)>6:1,1:0)
- +2 IF $GET(PSDRXIN)
- SET PSDSTA=$SELECT(PSOVR:$PIECE($GET(^PSRX(PSDRXIN,"STA")),"^"),1:$PIECE($GET(^PSRX(PSDRXIN,0)),"^",15))
- +3 QUIT
- CHKRF ;Dave B (PSD*3*30) if its deleted, show status.
- +1 WRITE !,"This RX has a status of '"_$SELECT(PSDSTA=11:"EXPIRED",PSDSTA=12:"DISCONTINUED",PSDSTA=13:"DELETED",PSDSTA=14:"DISCONTINUED BY PROVIDER",PSDSTA=15:"DISCONTINUED (EDIT)",1:"Unknown Procedure")_$SELECT(PSDSTA=12:"'.",1:"', no action can
- be taken.")
- +2 ;< JD*62
- +3 IF $ORDER(^PSRX(PSDRX,"A",0))>0
- WRITE !!,"Below is a list of actions taken on the prescription.",!!,"DATE/TIME",?22,"PERSON",?45,"ACTIVITY",!
- FOR X=1:1:53
- WRITE "="
- FOR X=1:1:(IOM-1)
- WRITE "="
- +4 SET X3=0
- FOR
- SET X3=$ORDER(^PSRX(PSDRX,"A",X3))
- if X3=""
- QUIT
- SET DATA=$GET(^PSRX(PSDRX,"A",X3,0))
- SET Y=$PIECE(DATA,"^",1)
- XECUTE ^DD("DD")
- SET DATE=Y
- SET X=$PIECE(DATA,"^",2)
- Begin DoDot:1
- +5 IF $GET(X)'=""
- SET ACTIVITY=$$EXTERNAL^DILFD(52.3,.02,,X)
- +6 SET DELDUZ=$$EXTERNAL^DILFD(52.3,.03,,$PIECE(DATA,"^",3))
- SET DELDUZ=$SELECT($GET(DELDUZ)="":"Unknown ("_$PIECE(DATA,"^",3)_")",1:DELDUZ)
- +7 KILL DELREAS
- SET DELREAS=$PIECE(DATA,"^",5)
- +8 WRITE !,DATE,?22,DELDUZ,?45,ACTIVITY
- IF $GET(DELREAS)'=""
- WRITE !,"Comment: ",$GET(DELREAS)
- End DoDot:1
- +9 IF $GET(PSDSTA)'=12
- SET PSDNEXT=1
- QUIT
- ASK12 READ !,"Do you wish to continue? NO // ",AN:DTIME
- if AN=""
- SET AN="N"
- +1 IF "YyNn"'[AN
- WRITE !,"Answer 'N'o, and you will prompted for another prescription."
- GOTO ASK12
- +2 IF "nN"[AN
- SET PSDNEXT=1
- QUIT
- +3 KILL PSDNEXT
- +4 QUIT
- CMOPMSG WRITE !,?10,"This is a CMOP fill and has been transmitted, dispensed or ",!?10,"retransmitted.",!
- SET PSDOUT=1
- QUIT
- KLLALL ;Kill all