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