PSOSUCHG.m

PSOSUCHG ;BIR/RTR-CHANGE SUSPENSE AND FILL AND REFILL DATES ;4/29/93

 ;;7.0;OUTPATIENT PHARMACY;**20,26,130,235,148,561**;DEC 1997;Build 41

 ;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

 ;

 ; Display a message to the user if the Bypass 3/4 Day Supply flag is set.

 ;

 N PSOFILL

 S PSOFILL=$O(^PSRX(RXREC,1,"A"),-1)

 I PSOFILL="" S PSOFILL=0

 I $$FLAG^PSOBPSU4(RXREC,PSOFILL)="YES" D

 . W !!,"Currently, Bypass 3/4 Day Supply is set to YES.  If you continue, the"

 . W !,"prescription fill will transmit to CMOP on the new Suspense Date entered.",!

 . Q

 ;

 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

 ;

 ; For each of the patient's prescriptions, check whether the Bypass 3/4 Day

 ; Supply flag is set.  If it is, display a message.

 ;

 N PSOCNT,PSOFILL,PSOPP

 S PSOCNT=0

 S PSOPP=0

 F  S PSOPP=$O(^PS(55,DFN,"P",PSOPP)) Q:'PSOPP  D

 . S RXREC=$G(^PS(55,DFN,"P",PSOPP,0))  ; Rx#

 . I $P($$SUSPFILL^PSOBPSU4(RXREC),"^",1)="" Q  ; Skip if not on suspense queue

 . S PSOFILL=$O(^PSRX(RXREC,1,"A"),-1)  ; Fill#

 . I PSOFILL="" S PSOFILL=0

 . I $$FLAG^PSOBPSU4(RXREC,PSOFILL)="YES" D

 . . S PSOCNT=PSOCNT+1

 . . I PSOCNT=1 W !

 . . W !,"Rx #: ",$$GET1^DIQ(52,RXREC,.01,"E")

 . . Q

 . Q

 I PSOCNT D

 . W !,"Currently, Bypass 3/4 Day Supply is set to YES.  If you continue, the"

 . W !,"prescription fill(s) will transmit to CMOP on the new Suspense Date entered.",!

 . Q

 ;

 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSOSUCHG   10775     printed  Apr 23, 2025@18:49:48                                                                                                                                                                                                   Page 2

PSOSUCHG  ;BIR/RTR-CHANGE SUSPENSE AND FILL AND REFILL DATES ;4/29/93

 +1       ;;7.0;OUTPATIENT PHARMACY;**20,26,130,235,148,561**;DEC 1997;Build 41

 +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

 +7       ;

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       ;

 +3       ; Display a message to the user if the Bypass 3/4 Day Supply flag is set.

 +4       ;

 +5        NEW PSOFILL

 +6        SET PSOFILL=$ORDER(^PSRX(RXREC,1,"A"),-1)

 +7        IF PSOFILL=""

               SET PSOFILL=0

 +8        IF $$FLAG^PSOBPSU4(RXREC,PSOFILL)="YES"

               Begin DoDot:1

 +9                WRITE !!,"Currently, Bypass 3/4 Day Supply is set to YES.  If you continue, the"

 +10               WRITE !,"prescription fill will transmit to CMOP on the new Suspense Date entered.",!

 +11               QUIT 

               End DoDot:1

 +12      ;

 +13       SET DA=SFN

           SET DIE=52.5

           SET DR=".02;S INDT=X"

           DO ^DIE

           KILL DIE

           Begin DoDot:1

 +14           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 !

 +15       IF $DATA(X)

               IF X'=RXDATE

                   SET DA=RXREC

                   DO CHANGE^PSOSUCH1(RXREC)

 +16       DO DEL

           if ACT="A"

               GOTO ALL

           if ACT="S"

               GOTO SPEC

 +17      ;

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

 +6       ;

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       ;

 +2       ; For each of the patient's prescriptions, check whether the Bypass 3/4 Day

 +3       ; Supply flag is set.  If it is, display a message.

 +4       ;

 +5        NEW PSOCNT,PSOFILL,PSOPP

 +6        SET PSOCNT=0

 +7        SET PSOPP=0

 +8        FOR 

               SET PSOPP=$ORDER(^PS(55,DFN,"P",PSOPP))

               if 'PSOPP

                   QUIT 

               Begin DoDot:1

 +9       ; Rx#

                   SET RXREC=$GET(^PS(55,DFN,"P",PSOPP,0))

 +10      ; Skip if not on suspense queue

                   IF $PIECE($$SUSPFILL^PSOBPSU4(RXREC),"^",1)=""

                       QUIT 

 +11      ; Fill#

                   SET PSOFILL=$ORDER(^PSRX(RXREC,1,"A"),-1)

 +12               IF PSOFILL=""

                       SET PSOFILL=0

 +13               IF $$FLAG^PSOBPSU4(RXREC,PSOFILL)="YES"

                       Begin DoDot:2

 +14                       SET PSOCNT=PSOCNT+1

 +15                       IF PSOCNT=1

                               WRITE !

 +16                       WRITE !,"Rx #: ",$$GET1^DIQ(52,RXREC,.01,"E")

 +17                       QUIT 

                       End DoDot:2

 +18               QUIT 

               End DoDot:1

 +19       IF PSOCNT

               Begin DoDot:1

 +20               WRITE !,"Currently, Bypass 3/4 Day Supply is set to YES.  If you continue, the"

 +21               WRITE !,"prescription fill(s) will transmit to CMOP on the new Suspense Date entered.",!

 +22               QUIT 

               End DoDot:1

 +23      ;

 +24       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

 +25       if ACT="A"

               GOTO ALL

           if ACT="S"

               GOTO SPEC

 +26      ;

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)_"."