PSOSUCHG ;BIR/RTR-CHANGE SUSPENSE AND FILL AND REFILL DATES ;4/29/93
;;7.0;OUTPATIENT PHARMACY;**20,26,130,235,148**;DEC 1997
;External reference A^PSXCH is supported by DBIA 2205
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
;External reference P^PSXCH is supported by DBIA 2205
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^DPT supported by DBIA 10035
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) D WARN^PSOSUDCN Q
LU N PSOSDLK,PSOLKQT,PSODELLK,PSOSSTP W !! S DIR("A")="Change a specific Rx# or all Rx's for one patient",DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR ONE PATIENT"
S DIR("?",1)="Enter 'S' to change a single prescription suspense date.",DIR("?")="Enter 'A' to change all of the prescription suspense dates for one patient."
D ^DIR K DIR G:$G(DIRUT)!(Y="") EXIT S ACT=Y D:ACT="A" ALL D:ACT="S" SPEC D ULK G LU
EXIT D ULK K ISFLAG,ACT,BC,BCNUM,CBD,CNT,COM,D1,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,HDSFN,I,II,INDT,OLD,OUT,PSPOP,RF,RFCNT,RX,RXDATE,RXREC,SFN,STOP,SUB,SUSCNT,VADM,WARN,X,Y,XOK,SRXPAR,SRXREC,SUSDOD,RECORD,PSOPOPUP,PSOSDLK,DELFLAG
K VADM,VA("PID"),VA("BID"),PSDIVCHK,PSOMSG,PSOLKQT,PSODELLK,PSOSSTP Q
SPEC D ULK K INDT S (DELCNT,WARN,PSPOP,OUT)=0 W ! S DIR("A")="Select SUSPENDED Rx #: ",DIR(0)="FOA",DIR("?")="Enter the prescription# or wand the barcode. To obtain a list of suspense prescriptions, type '??'",DIR("??")="^D LISTSUS^PSOSUCH1"
D ^DIR K DIR Q:$D(DIRUT) D:Y["-" PSOINST^PSOSUPAT G:$G(OUT) SPEC D W ! S DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0))",DIC="^PS(52.5,",DIC(0)="ZQE" D ^DIC K DIC W ! Q:$D(DTOUT)!($D(DUOUT))
.I Y["-" S Y=$P(Y,"-",2),X=+$P($G(^PSRX(Y,0)),"^") Q
.S X=Y
G:Y<0 SPEC S DEAD=0,(SFN,DA)=+Y,RXREC=+Y(0),DFN=$P(^PS(52.5,SFN,0),"^",3),RXDATE=$P(Y(0),"^",2),STOP=$P(^PSRX(RXREC,2),"^",6),STAT=$P($G(^("STA")),"^") D Q:$G(PSOLKQT) D TST G:$T P^PSXCH
.K PSOMSG,PSOLKQT D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be changed because" D LMES,PAUSE S PSOLKQT=1 K PSOMSG Q
.K PSOMSG S PSOSDLK(RXREC)=""
RTN I STAT=11!(STOP<DT)!(STAT=12) D EXPCAN Q
D:$P($G(^PSRX(RXREC,"STA")),"^")<9 CHKDEAD^PSOSUCH1 Q:DEAD I $G(PSODIV),+$P($G(^PS(52.5,SFN,0)),"^",6)'=PSOSITE S PSPOP=0 D CKDIV^PSOSUPAT Q:PSPOP
S DA=SFN,DIE=52.5,DR=".02;S INDT=X" D ^DIE K DIE D Q:$D(Y) W !
.I $D(INDT),INDT'=RXDATE,INDT<+$P($G(^PSRX(RXREC,0)),"^",13) S DA=SFN,DIE=52.5,DR=".02///"_RXDATE D ^DIE K DIE S Y="" W !!,"Suspense date cannot be before Issue Date of Rx!",!
I $D(X),X'=RXDATE S DA=RXREC D CHANGE^PSOSUCH1(RXREC)
D DEL G:ACT="A" ALL G:ACT="S" SPEC
ALL D ULK K INDT S (DELCNT,PSDIVCHK,DELFLAG,PSPOP,PSOPOPUP,WARN,SUSCNT)=0 W ! S DIR("A")="Are you entering the patient name or barcode?",DIR(0)="SBO^P:Patient Name;B:Barcode"
S DIR("?")="Enter 'P' if you are going to enter the patient name. Enter 'B' to enter or wand the barcode." D ^DIR K DIR Q:$D(DIRUT) S BC=Y
BC S OUT=0 I BC="B" W ! S DIR("A")="Enter/wand barcode",DIR(0)="FO^5:20",DIR("?")="Enter the barcode number or wand the barcode to change all of the prescription suspense dates for one patient" D ^DIR K DIR G:$G(DIRUT) ALL S BCNUM=Y D
.S RX=$P(BCNUM,"-",2) I '$G(RX) S OUT=1 W $C(7),!!?5,"Invalid Barcode!" Q
.I $D(^PSRX(RX,0)) D PSOINST^PSOSUPAT Q:OUT S DFN=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(DFN,0)),"^")
G:OUT BC
I BC="B",'$D(^PSRX(RX,0)) W $C(7),!!?5,"Invalid Barcode!",! G BC
I BC="B",'$D(^PS(52.5,"AC",DFN)) W !!?3,"This patient has no Rx's in suspense that have not already been printed!",! G BC
NAM I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(",DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) ALL S DFN=+Y
F CBD=0:0 S CBD=$O(^PS(55,DFN,"P",CBD)) Q:CBD'>0!($G(PSOPOPUP)) S:$D(^PS(55,DFN,"P",CBD,0)) RXREC=+^(0) D:$D(^PS(52.5,"B",RXREC)) TEST D ULK
G:ACT="A" ALL G:ACT="S" SPEC
TEST S SFN=+$O(^PS(52.5,"B",RXREC,0)) Q:'SFN Q:$P($G(^PS(52.5,SFN,"P")),"^")'=0 S STOP=$P(^PSRX(RXREC,2),"^",6),STAT=$P($G(^("STA")),"^") D Q:$G(PSOLKQT) D TST D:$T A^PSXCH Q:$G(XOK)=0 I STAT=11!(STOP<DT)!(STAT=12) D EXPCAN Q
.K PSOMSG,PSOLKQT D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be changed because" D LMES,PAUSE S PSOLKQT=1 K PSOMSG Q
.K PSOMSG S PSOSDLK(RXREC)=""
S PSPOP=0 D:PSODIV&('$G(PSDIVCHK)) DIV^PSOSUPAT S PSDIVCHK=1 S:PSPOP PSOPOPUP=1 I 'PSPOP D:$P($G(^PSRX(RXREC,"STA")),"^")<9 CHKDEAD^PSOSUCH1 Q:DEAD D BEG
Q
BEG S RXDATE=$P(^PS(52.5,SFN,0),"^",2),ISFLAG=0
I 'SUSCNT S DA=SFN,DIE=52.5,DR=".02;S INDT=X" D ^DIE D SI Q:ISFLAG K:$G(^PS(52.5,SFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P(^PS(52.5,SFN,0),"^",2),SFN) S:$D(Y) PSOPOPUP=1 Q:X=""!($D(DTOUT))!($G(PSOPOPUP)) S SUSCNT=1
I SUSCNT D IS Q:$G(ISFLAG) S DA=SFN,DIE=52.5,DR=".02///"_INDT D ^DIE K DIE K:$G(^PS(52.5,SFN,"P"))=1 ^PS(52.5,"AC",DFN,+$P($G(^PS(52.5,SFN,0)),"^",2),SFN) I $D(DTOUT)!($D(DUOUT))!($D(Y)) S PSOPOPUP=1 Q
D CHANGE^PSOSUCH1(RXREC)
DEL I 'DELCNT W !! S DIR("A")="Do you want to delete"_$S($G(ACT)="S":" this Rx ",1:" Rx's ")_"from suspense"_$S($G(ACT)="A":" for this patient",1:""),DIR("B")="N",DIR(0)="Y" D ^DIR K DIR S DELCNT=1 S DEL=Y Q:'Y I $D(DIRUT) S PSOPOPUP=1 Q
I $G(ACT)="A",DELCNT,$G(DEL),'$G(DELFLAG) W !!,"Deleting Rx's from suspense..",! S DELFLAG=1 D DEL1 Q
Q:'DEL
I '$D(PSOSDLK(RXREC)) D Q:$G(PSODELLK)
.K PSOMSG,PSODELLK D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be deleted from suspense because" D LMES,PAUSE S PSODELLK=1 K PSOMSG Q
.K PSOMSG S PSOSDLK(RXREC)=""
I DEL S DA=$O(^PS(52.5,"B",RXREC,0)) D RF S DIK="^PS(52.5," D ^DIK K DIK D:$P(^PSRX(RXREC,"STA"),"^")=5 W:$G(ACT)="S" !!,"Rx# ",$P($G(^PSRX(RXREC,0)),"^")," has been deleted from suspense!",!
.S $P(^PSRX(RXREC,"STA"),"^")=0
.N PSOZZD S PSOZZD="Removed from suspense" D EN^PSOHLSN1(RXREC,"SC","ZU",PSOZZD) K PSOZZD Q
Q
EXPCAN S DIK="^PS(52.5,",DA=SFN D ^DIK K DIK S Y=STOP D DD^%DT S PSOSSTP=Y I STOP<DT!(STAT=11) D:STAT'=11 W $C(7),!,"Rx# "_$P($G(^PSRX(RXREC,0)),"^")_" expired "_$G(PSOSSTP)_"."
.S $P(^PSRX(RXREC,"STA"),"^")=11
.N PSOZZD S PSOZZD="Expired while suspended" D EN^PSOHLSN1(RXREC,"SC","ZE",PSOZZD) K PSOZZD
W:STAT=12 $C(7),!,"Rx# "_$P(^PSRX(RXREC,0),"^")_" was discontinued "_Y_"." K STAT,STOP Q
TST N X S X="PSXCH" X ^%ZOSF("TEST") K X Q
;
RF ;
S PSSHLDDA=DA,PSODFS=0
S SNODE=$G(^PS(52.5,DA,0)),PSINN=+SNODE D DAREC^PSOSUCH1 I '$G(PSINN)!($P(SNODE,"^",5)) K PSINN,SNODE,PSODFS S DA=PSSHLDDA Q
S PSIFN=0 F S PSIFN=$O(^PSRX(PSINN,1,PSIFN)) Q:'PSIFN D
.I $P($G(^PSRX(PSINN,1,PSIFN,0)),"^")=$P(SNODE,"^",2),'$P($G(^PSRX(PSINN,1,PSIFN,0)),"^",18),$P($G(^PS(52.5,+$G(PSSHLDDA),"P")),"^")=0 D
..N DIK,DA S DIK="^PSRX("_PSINN_",1,",DA(1)=PSINN,DA=PSIFN D ^DIK
..S PSODFS=1,PSUSD=$P(SNODE,"^",2) D DATE
I '$G(PSODFS) G RFPS
S PSIFN=0 F S PSIFN=$O(^PSRX(PSINN,1,PSIFN)) Q:'PSIFN I '$O(^PSRX(PSINN,1,PSIFN)) S $P(^PSRX(PSINN,3),"^")=+$P(^PSRX(PSINN,1,PSIFN,0),"^")
I '$O(^PSRX(PSINN,1,0)) S $P(^PSRX(PSINN,3),"^")=$P(^PSRX(PSINN,2),"^",2)
S PSOX("IRXN")=PSINN D NEXT^PSOUTIL(.PSOX) S PSONEXT=$P(PSOX("RX3"),"^",2),DA=PSINN,DIE=52,DR="102///"_PSONEXT D ^DIE K DIE K PSONEXT,PSOX
RFPS K PSODFS,ZZZ,PSINN,PSIFN,PSUSD,PNOD,SNODE S DA=PSSHLDDA K PSSHLDDA Q
DATE S PNOD=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(PSINN,1,ZZZ)) Q:'ZZZ S PNOD=ZZZ
I PNOD=1 S $P(^PSRX(PSINN,3),"^",4)=$P(^PSRX(PSINN,2),"^",2) Q
DATEX I $G(PNOD) S PNOD=PNOD-1 G:'$D(^PSRX(PSINN,1,PNOD,0)) DATEX
I PNOD=0 S $P(^PSRX(PSINN,3),"^",4)=$P(^PSRX(PSINN,2),"^",2) Q
S $P(^PSRX(PSINN,3),"^",4)=$P(^PSRX(PSINN,1,PNOD,0),"^") Q
Q
IS K DIE I $G(INDT),$G(INDT)<+$P($G(^PSRX(RXREC,0)),"^",13) S DIE=52.5,DA=SFN,DR=".02///"_RXDATE D ^DIE K DIE W !!,"Suspense date cannot be before Issue Date for Rx# ",$P($G(^PSRX(RXREC,0)),"^") S ISFLAG=1
Q
SI ;
S SUSCNT=1
I $D(Y) S (ISFLAG,PSOPOPUP)=1
G IS
DEL1 ;
S PSOSUPOP=1
F WW=0:0 S WW=$O(^PS(55,DFN,"P",WW)) Q:WW'>0 S:$D(^PS(55,DFN,"P",WW,0)) RXREC=+^(0) D:$D(^PS(52.5,"B",+$G(RXREC)))
.I '$D(PSOSDLK(RXREC)) K PSODELLK D DELONE Q:$G(PSODELLK)
.I $P($G(^PSRX(RXREC,"STA")),"^")=11!($P($G(^PSRX(RXREC,2)),"^",6)<DT) D EXPCAN1 Q
.S DA=$O(^PS(52.5,"B",RXREC,0)) D RF S DIK="^PS(52.5," D ^DIK K DIK D:$P(^PSRX(RXREC,"STA"),"^")=5 W:$G(ACT)="S" !!,"Rx# ",$P($G(^PSRX(RXREC,0)),"^")," has been deleted from suspense!",!
..S $P(^PSRX(RXREC,"STA"),"^")=0
..N PSOZZD S PSOZZD="Removed from suspense" D EN^PSOHLSN1(RXREC,"SC","ZU",PSOZZD) K PSOZZD Q
Q
ULK ;Unlock prescriptions
I '$O(PSOSDLK("")) Q
N PSOSDLKR S PSOSDLKR="" F S PSOSDLKR=$O(PSOSDLK(PSOSDLKR)) Q:PSOSDLKR="" D PSOUL^PSSLOCK(PSOSDLKR)
K PSOSDLK
Q
PAUSE ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR W !
Q
LMES ;
W !,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order.")
Q
DELONE ;
K PSOMSG,PSODELLK D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !,"Rx number: "_$P($G(^PSRX(RXREC,0)),"^")_" cannot be deleted from suspense because" D LMES,PAUSE S PSODELLK=1 K PSOMSG Q
K PSOMSG S PSOSDLK(RXREC)=""
Q
EXPCAN1 ;
N SFN,Y,PSOSSTP,STAT,STOP
S STAT=$P($G(^PSRX(RXREC,"STA")),"^"),STOP=$P($G(^PSRX(RXREC,2)),"^",6)
S SFN=+$O(^PS(52.5,"B",RXREC,0)) Q:'SFN
S DIK="^PS(52.5,",DA=SFN D ^DIK K DIK S Y=STOP D DD^%DT S PSOSSTP=Y I STOP<DT!(STAT=11) D:STAT'=11 W $C(7),!,"Rx# "_$P($G(^PSRX(RXREC,0)),"^")_" expired "_$G(PSOSSTP)_"."
.S $P(^PSRX(RXREC,"STA"),"^")=11
.N PSOZZD S PSOZZD="Expired while suspended" D EN^PSOHLSN1(RXREC,"SC","ZE",PSOZZD) K PSOZZD
Q
PSOSUCHG ;BIR/RTR-CHANGE SUSPENSE AND FILL AND REFILL DATES ;4/29/93
+1 ;;7.0;OUTPATIENT PHARMACY;**20,26,130,235,148**;DEC 1997
+2 ;External reference A^PSXCH is supported by DBIA 2205
+3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+4 ;External reference P^PSXCH is supported by DBIA 2205
+5 ;External reference to ^PS(55 supported by DBIA 2228
+6 ;External reference to ^DPT supported by DBIA 10035
+7 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
DO WARN^PSOSUDCN
QUIT
LU NEW PSOSDLK,PSOLKQT,PSODELLK,PSOSSTP
WRITE !!
SET DIR("A")="Change a specific Rx# or all Rx's for one patient"
SET DIR(0)="SBO^S:SPECIFIC RX;A:ALL RXs FOR ONE PATIENT"
+1 SET DIR("?",1)="Enter 'S' to change a single prescription suspense date."
SET DIR("?")="Enter 'A' to change all of the prescription suspense dates for one patient."
+2 DO ^DIR
KILL DIR
IF $GET(DIRUT)!(Y="")
GOTO EXIT
SET ACT=Y
IF ACT="A"
DO ALL
IF ACT="S"
DO SPEC
DO ULK
GOTO LU
EXIT DO ULK
KILL ISFLAG,ACT,BC,BCNUM,CBD,CNT,COM,D1,DA,DEAD,DEL,DELCNT,DFN,DIRUT,DR,DTOUT,DUOUT,HDSFN,I,II,INDT,OLD,OUT,PSPOP,RF,RFCNT,RX,RXDATE,RXREC,SFN,STOP,SUB,SUSCNT,VADM,WARN,X,Y,XOK,SRXPAR,SRXREC,SUSDOD,RECORD,PSOPOPUP,PSOSDLK,DELFLAG
+1 KILL VADM,VA("PID"),VA("BID"),PSDIVCHK,PSOMSG,PSOLKQT,PSODELLK,PSOSSTP
QUIT
SPEC DO ULK
KILL INDT
SET (DELCNT,WARN,PSPOP,OUT)=0
WRITE !
SET DIR("A")="Select SUSPENDED Rx #: "
SET DIR(0)="FOA"
SET DIR("?")="Enter the prescription# or wand the barcode. To obtain a list of suspense prescriptions, type '??'"
SET DIR("??")="^D LISTSUS^PSOSUCH1"
+1 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
IF Y["-"
DO PSOINST^PSOSUPAT
IF $GET(OUT)
GOTO SPEC
Begin DoDot:1
+2 IF Y["-"
SET Y=$PIECE(Y,"-",2)
SET X=+$PIECE($GET(^PSRX(Y,0)),"^")
QUIT
+3 SET X=Y
End DoDot:1
WRITE !
SET DIC("S")="I $D(^PSRX(+$P(^PS(52.5,+Y,0),""^""),0))"
SET DIC="^PS(52.5,"
SET DIC(0)="ZQE"
DO ^DIC
KILL DIC
WRITE !
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+4 IF Y<0
GOTO SPEC
SET DEAD=0
SET (SFN,DA)=+Y
SET RXREC=+Y(0)
SET DFN=$PIECE(^PS(52.5,SFN,0),"^",3)
SET RXDATE=$PIECE(Y(0),"^",2)
SET STOP=$PIECE(^PSRX(RXREC,2),"^",6)
SET STAT=$PIECE($GET(^("STA")),"^")
Begin DoDot:1
+5 KILL PSOMSG,PSOLKQT
DO PSOL^PSSLOCK(RXREC)
IF '$GET(PSOMSG)
WRITE !,"Rx number: "_$PIECE($GET(^PSRX(RXREC,0)),"^")_" cannot be changed because"
DO LMES
DO PAUSE
SET PSOLKQT=1
KILL PSOMSG
QUIT
+6 KILL PSOMSG
SET PSOSDLK(RXREC)=""
End DoDot:1
IF $GET(PSOLKQT)
QUIT
DO TST
IF $TEST
GOTO P^PSXCH
RTN IF STAT=11!(STOP<DT)!(STAT=12)
DO EXPCAN
QUIT
+1 IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")<9
DO CHKDEAD^PSOSUCH1
IF DEAD
QUIT
IF $GET(PSODIV)
IF +$PIECE($GET(^PS(52.5,SFN,0)),"^",6)'=PSOSITE
SET PSPOP=0
DO CKDIV^PSOSUPAT
IF PSPOP
QUIT
+2 SET DA=SFN
SET DIE=52.5
SET DR=".02;S INDT=X"
DO ^DIE
KILL DIE
Begin DoDot:1
+3 IF $DATA(INDT)
IF INDT'=RXDATE
IF INDT<+$PIECE($GET(^PSRX(RXREC,0)),"^",13)
SET DA=SFN
SET DIE=52.5
SET DR=".02///"_RXDATE
DO ^DIE
KILL DIE
SET Y=""
WRITE !!,"Suspense date cannot be before Issue Date of Rx!",!
End DoDot:1
IF $DATA(Y)
QUIT
WRITE !
+4 IF $DATA(X)
IF X'=RXDATE
SET DA=RXREC
DO CHANGE^PSOSUCH1(RXREC)
+5 DO DEL
IF ACT="A"
GOTO ALL
IF ACT="S"
GOTO SPEC
ALL DO ULK
KILL INDT
SET (DELCNT,PSDIVCHK,DELFLAG,PSPOP,PSOPOPUP,WARN,SUSCNT)=0
WRITE !
SET DIR("A")="Are you entering the patient name or barcode?"
SET DIR(0)="SBO^P:Patient Name;B:Barcode"
+1 SET DIR("?")="Enter 'P' if you are going to enter the patient name. Enter 'B' to enter or wand the barcode."
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
SET BC=Y
BC SET OUT=0
IF BC="B"
WRITE !
SET DIR("A")="Enter/wand barcode"
SET DIR(0)="FO^5:20"
SET DIR("?")="Enter the barcode number or wand the barcode to change all of the prescription suspense dates for one patient"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
GOTO ALL
SET BCNUM=Y
Begin DoDot:1
+1 SET RX=$PIECE(BCNUM,"-",2)
IF '$GET(RX)
SET OUT=1
WRITE $CHAR(7),!!?5,"Invalid Barcode!"
QUIT
+2 IF $DATA(^PSRX(RX,0))
DO PSOINST^PSOSUPAT
IF OUT
QUIT
SET DFN=$PIECE(^PSRX(RX,0),"^",2)
WRITE " ",$PIECE($GET(^DPT(DFN,0)),"^")
End DoDot:1
+3 IF OUT
GOTO BC
+4 IF BC="B"
IF '$DATA(^PSRX(RX,0))
WRITE $CHAR(7),!!?5,"Invalid Barcode!",!
GOTO BC
+5 IF BC="B"
IF '$DATA(^PS(52.5,"AC",DFN))
WRITE !!?3,"This patient has no Rx's in suspense that have not already been printed!",!
GOTO BC
NAM IF BC="P"
WRITE !
SET DIC(0)="AEMZQ"
SET DIC="^DPT("
SET DIC("S")="I $D(^PS(52.5,""AC"",+Y))!($D(^PS(52.5,""AG"",+Y)))"
DO ^DIC
KILL DIC
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
GOTO ALL
SET DFN=+Y
+1 FOR CBD=0:0
SET CBD=$ORDER(^PS(55,DFN,"P",CBD))
IF CBD'>0!($GET(PSOPOPUP))
QUIT
IF $DATA(^PS(55,DFN,"P",CBD,0))
SET RXREC=+^(0)
IF $DATA(^PS(52.5,"B",RXREC))
DO TEST
DO ULK
+2 IF ACT="A"
GOTO ALL
IF ACT="S"
GOTO SPEC
TEST SET SFN=+$ORDER(^PS(52.5,"B",RXREC,0))
IF 'SFN
QUIT
IF $PIECE($GET(^PS(52.5,SFN,"P")),"^")'=0
QUIT
SET STOP=$PIECE(^PSRX(RXREC,2),"^",6)
SET STAT=$PIECE($GET(^("STA")),"^")
Begin DoDot:1
+1 KILL PSOMSG,PSOLKQT
DO PSOL^PSSLOCK(RXREC)
IF '$GET(PSOMSG)
WRITE !!,"Rx number: "_$PIECE($GET(^PSRX(RXREC,0)),"^")_" cannot be changed because"
DO LMES
DO PAUSE
SET PSOLKQT=1
KILL PSOMSG
QUIT
+2 KILL PSOMSG
SET PSOSDLK(RXREC)=""
End DoDot:1
IF $GET(PSOLKQT)
QUIT
DO TST
IF $TEST
DO A^PSXCH
IF $GET(XOK)=0
QUIT
IF STAT=11!(STOP<DT)!(STAT=12)
DO EXPCAN
QUIT
+3 SET PSPOP=0
IF PSODIV&('$GET(PSDIVCHK))
DO DIV^PSOSUPAT
SET PSDIVCHK=1
IF PSPOP
SET PSOPOPUP=1
IF 'PSPOP
IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")<9
DO CHKDEAD^PSOSUCH1
IF DEAD
QUIT
DO BEG
+4 QUIT
BEG SET RXDATE=$PIECE(^PS(52.5,SFN,0),"^",2)
SET ISFLAG=0
+1 IF 'SUSCNT
SET DA=SFN
SET DIE=52.5
SET DR=".02;S INDT=X"
DO ^DIE
DO SI
IF ISFLAG
QUIT
IF $GET(^PS(52.5,SFN,"P"))=1
KILL ^PS(52.5,"AC",DFN,+$PIECE(^PS(52.5,SFN,0),"^",2),SFN)
IF $DATA(Y)
SET PSOPOPUP=1
IF X=""!($DATA(DTOUT))!($GET(PSOPOPUP))
QUIT
SET SUSCNT=1
+2 IF SUSCNT
DO IS
IF $GET(ISFLAG)
QUIT
SET DA=SFN
SET DIE=52.5
SET DR=".02///"_INDT
DO ^DIE
KILL DIE
IF $GET(^PS(52.5,SFN,"P"))=1
KILL ^PS(52.5,"AC",DFN,+$PIECE($GET(^PS(52.5,SFN,0)),"^",2),SFN)
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(Y))
SET PSOPOPUP=1
QUIT
+3 DO CHANGE^PSOSUCH1(RXREC)
DEL IF 'DELCNT
WRITE !!
SET DIR("A")="Do you want to delete"_$SELECT($GET(ACT)="S":" this Rx ",1:" Rx's ")_"from suspense"_$SELECT($GET(ACT)="A":" for this patient",1:"")
SET DIR("B")="N"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
SET DELCNT=1
SET DEL=Y
IF 'Y
QUIT
IF $DATA(DIRUT)
SET PSOPOPUP=1
QUIT
+1 IF $GET(ACT)="A"
IF DELCNT
IF $GET(DEL)
IF '$GET(DELFLAG)
WRITE !!,"Deleting Rx's from suspense..",!
SET DELFLAG=1
DO DEL1
QUIT
+2 IF 'DEL
QUIT
+3 IF '$DATA(PSOSDLK(RXREC))
Begin DoDot:1
+4 KILL PSOMSG,PSODELLK
DO PSOL^PSSLOCK(RXREC)
IF '$GET(PSOMSG)
WRITE !,"Rx number: "_$PIECE($GET(^PSRX(RXREC,0)),"^")_" cannot be deleted from suspense because"
DO LMES
DO PAUSE
SET PSODELLK=1
KILL PSOMSG
QUIT
+5 KILL PSOMSG
SET PSOSDLK(RXREC)=""
End DoDot:1
IF $GET(PSODELLK)
QUIT
+6 IF DEL
SET DA=$ORDER(^PS(52.5,"B",RXREC,0))
DO RF
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
IF $PIECE(^PSRX(RXREC,"STA"),"^")=5
Begin DoDot:1
+7 SET $PIECE(^PSRX(RXREC,"STA"),"^")=0
+8 NEW PSOZZD
SET PSOZZD="Removed from suspense"
DO EN^PSOHLSN1(RXREC,"SC","ZU",PSOZZD)
KILL PSOZZD
QUIT
End DoDot:1
IF $GET(ACT)="S"
WRITE !!,"Rx# ",$PIECE($GET(^PSRX(RXREC,0)),"^")," has been deleted from suspense!",!
+9 QUIT
EXPCAN SET DIK="^PS(52.5,"
SET DA=SFN
DO ^DIK
KILL DIK
SET Y=STOP
DO DD^%DT
SET PSOSSTP=Y
IF STOP<DT!(STAT=11)
IF STAT'=11
Begin DoDot:1
+1 SET $PIECE(^PSRX(RXREC,"STA"),"^")=11
+2 NEW PSOZZD
SET PSOZZD="Expired while suspended"
DO EN^PSOHLSN1(RXREC,"SC","ZE",PSOZZD)
KILL PSOZZD
End DoDot:1
WRITE $CHAR(7),!,"Rx# "_$PIECE($GET(^PSRX(RXREC,0)),"^")_" expired "_$GET(PSOSSTP)_"."
+3 IF STAT=12
WRITE $CHAR(7),!,"Rx# "_$PIECE(^PSRX(RXREC,0),"^")_" was discontinued "_Y_"."
KILL STAT,STOP
QUIT
TST NEW X
SET X="PSXCH"
XECUTE ^%ZOSF("TEST")
KILL X
QUIT
+1 ;
RF ;
+1 SET PSSHLDDA=DA
SET PSODFS=0
+2 SET SNODE=$GET(^PS(52.5,DA,0))
SET PSINN=+SNODE
DO DAREC^PSOSUCH1
IF '$GET(PSINN)!($PIECE(SNODE,"^",5))
KILL PSINN,SNODE,PSODFS
SET DA=PSSHLDDA
QUIT
+3 SET PSIFN=0
FOR
SET PSIFN=$ORDER(^PSRX(PSINN,1,PSIFN))
IF 'PSIFN
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PSRX(PSINN,1,PSIFN,0)),"^")=$PIECE(SNODE,"^",2)
IF '$PIECE($GET(^PSRX(PSINN,1,PSIFN,0)),"^",18)
IF $PIECE($GET(^PS(52.5,+$GET(PSSHLDDA),"P")),"^")=0
Begin DoDot:2
+5 NEW DIK,DA
SET DIK="^PSRX("_PSINN_",1,"
SET DA(1)=PSINN
SET DA=PSIFN
DO ^DIK
+6 SET PSODFS=1
SET PSUSD=$PIECE(SNODE,"^",2)
DO DATE
End DoDot:2
End DoDot:1
+7 IF '$GET(PSODFS)
GOTO RFPS
+8 SET PSIFN=0
FOR
SET PSIFN=$ORDER(^PSRX(PSINN,1,PSIFN))
IF 'PSIFN
QUIT
IF '$ORDER(^PSRX(PSINN,1,PSIFN))
SET $PIECE(^PSRX(PSINN,3),"^")=+$PIECE(^PSRX(PSINN,1,PSIFN,0),"^")
+9 IF '$ORDER(^PSRX(PSINN,1,0))
SET $PIECE(^PSRX(PSINN,3),"^")=$PIECE(^PSRX(PSINN,2),"^",2)
+10 SET PSOX("IRXN")=PSINN
DO NEXT^PSOUTIL(.PSOX)
SET PSONEXT=$PIECE(PSOX("RX3"),"^",2)
SET DA=PSINN
SET DIE=52
SET DR="102///"_PSONEXT
DO ^DIE
KILL DIE
KILL PSONEXT,PSOX
RFPS KILL PSODFS,ZZZ,PSINN,PSIFN,PSUSD,PNOD,SNODE
SET DA=PSSHLDDA
KILL PSSHLDDA
QUIT
DATE SET PNOD=0
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PSRX(PSINN,1,ZZZ))
IF 'ZZZ
QUIT
SET PNOD=ZZZ
+1 IF PNOD=1
SET $PIECE(^PSRX(PSINN,3),"^",4)=$PIECE(^PSRX(PSINN,2),"^",2)
QUIT
DATEX IF $GET(PNOD)
SET PNOD=PNOD-1
IF '$DATA(^PSRX(PSINN,1,PNOD,0))
GOTO DATEX
+1 IF PNOD=0
SET $PIECE(^PSRX(PSINN,3),"^",4)=$PIECE(^PSRX(PSINN,2),"^",2)
QUIT
+2 SET $PIECE(^PSRX(PSINN,3),"^",4)=$PIECE(^PSRX(PSINN,1,PNOD,0),"^")
QUIT
+3 QUIT
IS KILL DIE
IF $GET(INDT)
IF $GET(INDT)<+$PIECE($GET(^PSRX(RXREC,0)),"^",13)
SET DIE=52.5
SET DA=SFN
SET DR=".02///"_RXDATE
DO ^DIE
KILL DIE
WRITE !!,"Suspense date cannot be before Issue Date for Rx# ",$PIECE($GET(^PSRX(RXREC,0)),"^")
SET ISFLAG=1
+1 QUIT
SI ;
+1 SET SUSCNT=1
+2 IF $DATA(Y)
SET (ISFLAG,PSOPOPUP)=1
+3 GOTO IS
DEL1 ;
+1 SET PSOSUPOP=1
+2 FOR WW=0:0
SET WW=$ORDER(^PS(55,DFN,"P",WW))
IF WW'>0
QUIT
IF $DATA(^PS(55,DFN,"P",WW,0))
SET RXREC=+^(0)
IF $DATA(^PS(52.5,"B",+$GET(RXREC)))
Begin DoDot:1
+3 IF '$DATA(PSOSDLK(RXREC))
KILL PSODELLK
DO DELONE
IF $GET(PSODELLK)
QUIT
+4 IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")=11!($PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT)
DO EXPCAN1
QUIT
+5 SET DA=$ORDER(^PS(52.5,"B",RXREC,0))
DO RF
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
IF $PIECE(^PSRX(RXREC,"STA"),"^")=5
Begin DoDot:2
+6 SET $PIECE(^PSRX(RXREC,"STA"),"^")=0
+7 NEW PSOZZD
SET PSOZZD="Removed from suspense"
DO EN^PSOHLSN1(RXREC,"SC","ZU",PSOZZD)
KILL PSOZZD
QUIT
End DoDot:2
IF $GET(ACT)="S"
WRITE !!,"Rx# ",$PIECE($GET(^PSRX(RXREC,0)),"^")," has been deleted from suspense!",!
End DoDot:1
+8 QUIT
ULK ;Unlock prescriptions
+1 IF '$ORDER(PSOSDLK(""))
QUIT
+2 NEW PSOSDLKR
SET PSOSDLKR=""
FOR
SET PSOSDLKR=$ORDER(PSOSDLK(PSOSDLKR))
IF PSOSDLKR=""
QUIT
DO PSOUL^PSSLOCK(PSOSDLKR)
+3 KILL PSOSDLK
+4 QUIT
PAUSE ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
WRITE !
+2 QUIT
LMES ;
+1 WRITE !,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
+2 QUIT
DELONE ;
+1 KILL PSOMSG,PSODELLK
DO PSOL^PSSLOCK(RXREC)
IF '$GET(PSOMSG)
WRITE !,"Rx number: "_$PIECE($GET(^PSRX(RXREC,0)),"^")_" cannot be deleted from suspense because"
DO LMES
DO PAUSE
SET PSODELLK=1
KILL PSOMSG
QUIT
+2 KILL PSOMSG
SET PSOSDLK(RXREC)=""
+3 QUIT
EXPCAN1 ;
+1 NEW SFN,Y,PSOSSTP,STAT,STOP
+2 SET STAT=$PIECE($GET(^PSRX(RXREC,"STA")),"^")
SET STOP=$PIECE($GET(^PSRX(RXREC,2)),"^",6)
+3 SET SFN=+$ORDER(^PS(52.5,"B",RXREC,0))
IF 'SFN
QUIT
+4 SET DIK="^PS(52.5,"
SET DA=SFN
DO ^DIK
KILL DIK
SET Y=STOP
DO DD^%DT
SET PSOSSTP=Y
IF STOP<DT!(STAT=11)
IF STAT'=11
Begin DoDot:1
+5 SET $PIECE(^PSRX(RXREC,"STA"),"^")=11
+6 NEW PSOZZD
SET PSOZZD="Expired while suspended"
DO EN^PSOHLSN1(RXREC,"SC","ZE",PSOZZD)
KILL PSOZZD
End DoDot:1
WRITE $CHAR(7),!,"Rx# "_$PIECE($GET(^PSRX(RXREC,0)),"^")_" expired "_$GET(PSOSSTP)_"."
+7 QUIT
