Routine: PSOCAN1

PSOCAN1 ;BIR/BHW - modular rx cancel with speed cancel ability ;12/03/18  11:04

 ;;7.0;OUTPATIENT PHARMACY;**8,20,24,27,32,131,163,185,238,372,442,508,477,617**;DEC 1997;Build 110

 ;External reference to File #55 supported by DBIA 2228

 ;External reference to ^PSDRUG supported by DBIA 221

 ;External reference to ^DPT supported by DBIA 10035

 ;External references L, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789

PAT S RXCNT=0 K X,PSODFN,ASKED,BC,DELCNT,WARN W ! S DIR("A")="Are you entering the patient name or barcode",DIR(0)="SBO^P:Patient Name;B:Barcode"

 S DIR("?")="Enter a P if you are going to enter the patient name.  Enter a B if you are going to enter or wand the barcode."

 D ^DIR K DIR G:$D(DIRUT) ^PSOCAN S BC=Y

BC D KCAN1^PSOCAN3 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 discontinue all prescriptions for one patient" D ^DIR K DIR G:$G(DIRUT) PAT S BCNUM=Y D

 .D PSOINST^PSOSUPAT Q:OUT  S RX=$P(BCNUM,"-",2) D:$D(^PSRX(RX,0))

 ..S PSODFN=$P(^PSRX(RX,0),"^",2) W " ",$P($G(^DPT(PSODFN,0)),"^")

 ..D ICN^PSODPT(PSODFN)

 .I '$D(^PSRX(RX,0)) W !,$C(7),"No Prescription record for this barcode." S OUT=1

 G:OUT BC

NAM D KCAN^PSOCAN3 S PSOCANRA=1 I BC="P" W ! S DIC(0)="AEMZQ",DIC="^DPT(" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) PAT S PSODFN=+Y S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD

 I PSODFN'=$G(PSOODOSP) K PSORX("DOSING OFF"),PSOREINF S PSOODOSP=PSODFN

 I $G(PSOREINF)!($G(PSORX("DOSING INFO"))) S PSOONOFO=1

 N PSONEW,PSORX S PSFROM="N" D CHK^PSOCAN G:DEAD NAM K PSOSD D ^PSOBUILD S PSOOPT=-1 D ^PSODSPL G:'$D(PSOSD) NAM

 D ONOFF

 S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G PAT

 W ! S DIR("A")="Discontinue all or specific Rx#'s?",DIR(0)="SBO^A:ALL Rx's;S:SPECIFIC Rx's"

 S DIR("?")="Enter the letter A for all listed Rx's OR the letter for specific Rx's." D ^DIR K DIR I $D(DIRUT) D ULP^PSOCAN G PAT

 S ALL=Y G:Y="S" LINE D RTESTA D COM I '$D(INCOM)!($D(DIRUT)) D ULP^PSOCAN G NAM

 K PSOSDX,PSOSDXY,PENCAN,PSOCANPN S SPEED=1,(DRG,DRUG,IN,STA)="",II=0 F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DRUG=$O(PSOSD(STA,DRUG)) Q:DRUG=""  S II=II+1,DRG=DRUG D

 .I STA="PENDING" S DA=$P(PSOSD(STA,DRG),"^",10) S PSOSDX(DA)="" Q

 .;PSO*7*238

 .I STA="ZNONVA" D  Q

 ..D NOW^%DTC

 ..N TMP

 ..S TMP(55.05,PSOOI_","_PSODFN_",",5)=1

 ..S TMP(55.05,PSOOI_","_PSODFN_",",6)=%

 ..D FILE^DIE("","TMP")

 .S PSOCANPN=1

 .D PSPEED

 K SPEED D ASK D:$G(REA)="C"&('$G(PSOSDXY))&($O(PSOSDX(0)))&($G(PSOCANPN))  D:'$G(PSOCANPN)  K PSOCANPN,PSOSDX,PSOSDXY,PENCAN D ULP^PSOCAN G PAT

 .S PENCAN="" F  S PENCAN=$O(PSOSDX(PENCAN)) Q:'PENCAN  S DA=PENCAN D PSOL^PSSLOCK(DA_"S") I $G(PSOMSG) D PEN,PSOUL^PSSLOCK(DA_"S")

LINE W !! S DIR(0)="LO^1:"_$S($G(PSOHI):PSOHI,1:PSOSD),DIR("A")="ENTER THE LINE #",DIR("?",1)="Enter the line number(s) displayed to the left of the Rx#."

 S DIR("?",2)="   Separate the numbers with commas (Example: 3,8,10,7),",DIR("?",3)="   OR a dash (Example: 12-20), OR a combination of commas and",DIR("?",4)="   dashes (Example: 3-5,1,12)."

 S DIR("?")="Do not exceed 245 characters including commas and dashes." D ^DIR K DIR D:$D(DIRUT) ULP^PSOCAN G:$G(DIRUT) KILL I Y["." W !?53,$C(7),"INVALID LINE NUMBER(S)." G LINE

 S LINE=Y K PSCAN,PSOCAN S (DRG,IN,STA)="",CNT=0

 F  S STA=$O(PSOSD(STA))  Q:STA=""  F  S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""  S CNT=CNT+1,PSOCAN(CNT)=$S(STA'="PENDING":$P(PSOSD(STA,DRG),"^"),1:$P(PSOSD(STA,DRG),"^",10)_"^P")

 F CNT=1:1 S PLINE=$P(LINE,",",CNT) Q:'$P(LINE,",",CNT)  S IN=$S(IN="":PSOCAN(PLINE),1:IN_","_PSOCAN(PLINE))

 D RTEST D SPEED D ULP^PSOCAN G:BC="P" NAM G:BC="B" BC

PSPEED S (YY,DA)=$P(PSOSD(STA,DRG),"^"),RX=$P($G(^PSRX(DA,0)),"^") D SPEED1 Q:PSPOP!($D(PSINV(RX)))

 Q:$G(SPEED)&(REA="R")

SHOW S DRG=+$P(^PSRX(DA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:"")

PSHOW S LC=0 W !,$P(^PSRX(DA,0),"^"),"  ",DRG,?52,$S($D(^DPT(+$P(^PSRX(DA,0),"^",2),0)):$P(^(0),"^"),1:"PATIENT UNKNOWN")

 I REA="C" W !?25,"Rx to be Discontinued",! G SHOW1

 W !?21,"*** Rx to be Reinstated ***",!

SHOW1 ;S LC=LC+3 I LC>20 R !,"Press return to continue",X:DTIME G:X'="" SHOW1 S LC=0

 I $Y+4>IOSL K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E",DIR("A")="Press Return to Continue",DIR("?")="Press Return to continue Listing Orders" D ^DIR K DIR,DTOUT,DIRUT,DUOUT W @IOF

SPEED1 S PSPOP=0 I $G(PSODIV),+$P($G(^PSRX(DA,2)),"^",9)'=$G(PSOSITE) D:'$G(SPEED) DIV^PSOCAN

 K STAT S STAT=+$P(^PSRX(DA,"STA"),"^"),REA=$E("C00CCCCCCCCCR000C",STAT+1)

 I $$CONJ^PSOUTL(DA) S PSINV(RX)="" Q

 Q:$G(SPEED)&(REA="R")

 I REA="R",$P($G(^PSRX(DA,"PKI")),"^")!$P($G(^PSRX(DA,"PKI")),"^",3) S PKI=1 S PSINV(RX)="" Q

 I REA=0!(PSPOP)!($P(^PSRX(+YY,"STA"),"^")>12),$P(^("STA"),"^")<16 S PSINV(RX)="" Q

 S:REA'=0&('PSPOP) PSCAN(RX)=DA_"^"_REA,RXCNT=$G(RXCNT)+1

AREC S:'$G(DEAD) REA=$S($G(REA)="L":"L",1:$P(PSCAN($P(^PSRX(DA,0),"^")),"^",2)) S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB  S ACNT=SUB

 S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF  S RFCNT=RF S:RF>5 RFCNT=RF+1

 D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1) S ^PSRX(DA,"A",ACNT+1,0)=%_"^"_REA_"^"_DUZ_"^"_RFCNT_"^"_$S($G(MSG)]"":MSG,1:$G(ACOM)_$G(INCOM)) S ACOM=""

 I $D(PKIR) N J S J=ACNT+2 D ADR^PSOPKIV1

 D EXP^PSOHELP1

SPEED ;

 D COM Q:'$D(INCOM)!($D(DIRUT))  N PKI K PSINV,PSCAN F II=1:1 S DA=$P(IN,",",II) Q:'$P(IN,",",II)  D

 .I $P(DA,"^",2)="P" S DA=+DA D  Q

 ..D PSOL^PSSLOCK(DA_"S") I $G(PSOMSG) D PEN D PSOUL^PSSLOCK(DA_"S")

 .I $D(^PSRX(DA,0)) S YY=DA,RX=$P(^(0),"^") S:DA<0 PSINV(RX)="" D:DA>0 SPEED1

 G:ALL="S"&($D(PSINV(RX))) INVALD

 G:'$D(PSCAN) INVALD S II="",RXCNT=0 F  S II=$O(PSCAN(II)) Q:II=""  S DA=+PSCAN(II),REA=$P(PSCAN(II),"^",2),RXCNT=RXCNT+1  D SHOW

ASK G:'$D(PSCAN) INVALD W ! S DIR("A")="OK to "_$S($G(RXCNT)>1:"Change Status",REA="C":"Discontinue",1:"Reinstate"),DIR(0)="Y",DIR("B")="N" D ^DIR K DIR I $D(DIRUT) S:$O(PSOSDX(0)) PSOSDXY=1 Q

 I 'Y S:$O(PSOSDX(0)) PSOSDXY=1 K PSCAN D INVALD Q

 S RX="" F  S RX=$O(PSCAN(RX)) Q:RX=""  D PSOL^PSSLOCK(+PSCAN(RX)) I $G(PSOMSG) D ACT D PSOUL^PSSLOCK(+PSCAN(RX))

 D INVALD Q

ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 I '$G(PSORX("DFLG")) D DCORD^PSONEW2 Q  ;*442

 D CAN^PSOCAN Q

INVALD K PSCAN Q:'$D(PSINV)  W !! F I=1:1:80 W "="

 W $C(7),!!,"The Following Rx Number(s) Are Invalid Choices, Expired, "_$S($G(PKI):"Digitally Signed",1:""),!,"Discontinued by Provider, invalid except conjunction or Marked As Deleted:" S II="" F  S II=$O(PSINV(II)) Q:II=""  W !?10,II

 K PSINV I $G(PSOERR)!($G(SPEED)) K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DIRUT,DUOUT

 G KILL Q

LISTPAT S X="?",DIC(0)="EMQ",DIC="^DPT(" D ^DIC K DIC Q

COM ;

 ; PSO*7*508 - if this is an eRx, set the comments and nature of order and quit - no user interaction

 I $G(ERXDCIEN) D  Q

 .S INCOM=$$GET1^DIQ(52.49,ERXDCIEN,52.2,"E")

 .I INCOM']"" S INCOM="eRx discontinued by external prescriber"

 .; set nature of order to 'auto'

 .S PSOONOR="A"

 ; PSO*7*505 - end changes

W !

 K MSG  ;Added to prevent INCOM from being superseded in AREC tag if DC comments entered.

 S DIR("A")="Comments"_$S($D(PKIR):"/Reason for DCing",1:""),DIR(0)="F^5:75"

 S DIR("?")="Comments must be entered.  Comments must be 5 to 75 characters and must not contain embedded uparrow"

 S:$D(INCOM) DIR("B")=INCOM

 D ^DIR I $D(DIRUT) K DIR,DTOUT,DUOUT,Y Q

 S INCOM=Y S:$D(PKIR) PKIR=Y K DIR,DTOUT,DIRUT,DUOUT

 D NOOR^PSOCAN4

KILL D KILL^PSOCAN2

 K PSOMSG,PSOPLCK,PSOWUN,PSOULRX

PEN ;discontinue pending orders

 S PSODAPND=DA

 K ^PS(52.41,"AOR",$P(^PS(52.41,DA,0),"^",2),+$P($G(^PS(52.41,DA,"INI")),"^"),DA) S $P(^PS(52.41,DA,0),"^",3)="DC",^PS(52.41,DA,4)=INCOM_" Discontinued by Pharmacy."

 D EN^PSOHLSN(+^PS(52.41,DA,0),"OC",INCOM,PSONOOR)

 S DA=PSODAPND K PSODAPND

RTEST ;

 Q:'$G(LINE)

 N PCIN,PCINFLAG,PCINX

 S PCINFLAG=0 F PCIN=1:1 S PCINX=$P(LINE,",",PCIN) Q:$P(LINE,",",PCIN)']""  D

 .Q:'$G(PCINX)

 .Q:'$G(PSOCAN(PCINX))

 .I PSOCAN(PCINX)'["^P" I $P($G(^PSRX(+$G(PSOCAN(PCINX)),"STA")),"^")'=12,'$G(PCINFLAG) S PSOCANRD=+$P($G(^PSRX($G(PSOCAN(PCINX)),0)),"^",4) S PCINFLAG=1

 .I PSOCAN(PCINX)["^P",'$G(PCINFLAG) S PSOCANRD=+$P($G(^PS(52.41,+$P(PSOCAN(PCINX),"^"),0)),"^",5) S PCINFLAG=1

 I '$G(PCINFLAG) S PSOCANRZ=1

RTESTA ;

 N PFIN,PFINZ,PFINFLAG

 S PFINFLAG=0 S PFIN="" F  S PFIN=$O(PSOSD(PFIN)) Q:PFIN=""  S PFINZ="" F  S PFINZ=$O(PSOSD(PFIN,PFINZ)) Q:PFINZ=""  D

 .I $G(PFIN)'="PENDING" I $P($G(^PSRX(+$P($G(PSOSD(PFIN,PFINZ)),"^"),"STA")),"^")'=12,'$G(PFINFLAG) S PSOCANRD=+$P($G(^(0)),"^",4),PFINFLAG=1

 .I $G(PFIN)="PENDING",'$G(PFINFLAG) S PSOCANRD=+$P($G(^PS(52.41,+$P($G(PSOSD(PFIN,PFINZ)),"^",10),0)),"^",5) S PFINFLAG=1

 I '$G(PFINFLAG) S PSOCANRZ=1

ONOFF ;

 I $G(PSOREINF) S PSORX("DOSING INFO")=1

 I $G(PSORX("DOSING INFO"))&'$G(PSOREINF) S PSOREINF=1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN1   9011     printed  Feb 18, 2025@23:51:38                                                                                                                                                                                                     Page 2

PSOCAN1   ;BIR/BHW - modular rx cancel with speed cancel ability ;12/03/18  11:04

 +1       ;;7.0;OUTPATIENT PHARMACY;**8,20,24,27,32,131,163,185,238,372,442,508,477,617**;DEC 1997;Build 110

 +2       ;External reference to File #55 supported by DBIA 2228

 +3       ;External reference to ^PSDRUG supported by DBIA 221

 +4       ;External reference to ^DPT supported by DBIA 10035

 +5       ;External references L, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789

 +6       ;

PAT        SET RXCNT=0

           KILL X,PSODFN,ASKED,BC,DELCNT,WARN

           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 a P if you are going to enter the patient name.  Enter a B if you are going to enter or wand the barcode."

 +2        DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO ^PSOCAN

           SET BC=Y

BC         DO KCAN1^PSOCAN3

           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 discontinue all prescriptions for one patient"

               DO ^DIR

               KILL DIR

               if $GET(DIRUT)

                   GOTO PAT

               SET BCNUM=Y

               Begin DoDot:1

 +1                DO PSOINST^PSOSUPAT

                   if OUT

                       QUIT

                   SET RX=$PIECE(BCNUM,"-",2)

                   if $DATA(^PSRX(RX,0))

                       Begin DoDot:2

 +2                        SET PSODFN=$PIECE(^PSRX(RX,0),"^",2)

                           WRITE " ",$PIECE($GET(^DPT(PSODFN,0)),"^")

 +3                        DO ICN^PSODPT(PSODFN)

                       End DoDot:2

 +4                IF '$DATA(^PSRX(RX,0))

                       WRITE !,$CHAR(7),"No Prescription record for this barcode."

                       SET OUT=1

               End DoDot:1

 +5        if OUT

               GOTO BC

NAM        DO KCAN^PSOCAN3

           SET PSOCANRA=1

           IF BC="P"

               WRITE !

               SET DIC(0)="AEMZQ"

               SET DIC="^DPT("

               DO ^DIC

               KILL DIC

               if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)

                   GOTO PAT

               SET PSODFN=+Y

               SET PSOLOUD=1

               if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2

                   DO EN^PSOHLUP(PSODFN)

               KILL PSOLOUD

 +1        IF PSODFN'=$GET(PSOODOSP)

               KILL PSORX("DOSING OFF"),PSOREINF

               SET PSOODOSP=PSODFN

 +2        IF $GET(PSOREINF)!($GET(PSORX("DOSING INFO")))

               SET PSOONOFO=1

 +3        NEW PSONEW,PSORX

           SET PSFROM="N"

           DO CHK^PSOCAN

           if DEAD

               GOTO NAM

           KILL PSOSD

           DO ^PSOBUILD

           SET PSOOPT=-1

           DO ^PSODSPL

           if '$DATA(PSOSD)

               GOTO NAM

 +4        DO ONOFF

 +5        SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)

           IF '$GET(PSOPLCK)

               DO LOCK^PSOORCPY

               KILL PSOPLCK

               GOTO PAT

 +6        WRITE !

           SET DIR("A")="Discontinue all or specific Rx#'s?"

           SET DIR(0)="SBO^A:ALL Rx's;S:SPECIFIC Rx's"

 +7        SET DIR("?")="Enter the letter A for all listed Rx's OR the letter for specific Rx's."

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               DO ULP^PSOCAN

               GOTO PAT

 +8        SET ALL=Y

           if Y="S"

               GOTO LINE

           DO RTESTA

           DO COM

           IF '$DATA(INCOM)!($DATA(DIRUT))

               DO ULP^PSOCAN

               GOTO NAM

 +9        KILL PSOSDX,PSOSDXY,PENCAN,PSOCANPN

           SET SPEED=1

           SET (DRG,DRUG,IN,STA)=""

           SET II=0

FOR

               SET STA=$ORDER(PSOSD(STA))

               if STA=""

                   QUIT

FOR

                   SET DRUG=$ORDER(PSOSD(STA,DRUG))

                   if DRUG=""

                       QUIT

                   SET II=II+1

                   SET DRG=DRUG

                   Begin DoDot:1

 +10                   IF STA="PENDING"

                           SET DA=$PIECE(PSOSD(STA,DRG),"^",10)

                           SET PSOSDX(DA)=""

                           QUIT

 +11      ;PSO*7*238

 +12                   IF STA="ZNONVA"

                           Begin DoDot:2

 +13                           DO NOW^%DTC

 +14                           NEW TMP

 +15                           SET TMP(55.05,PSOOI_","_PSODFN_",",5)=1

 +16                           SET TMP(55.05,PSOOI_","_PSODFN_",",6)=%

 +17                           DO FILE^DIE("","TMP")

                           End DoDot:2

                           QUIT

 +18                   SET PSOCANPN=1

 +19                   DO PSPEED

                   End DoDot:1

 +20       KILL SPEED

           DO ASK

           if $GET(REA)="C"&('$GET(PSOSDXY))&($ORDER(PSOSDX(0)))&($GET(PSOCANPN))

               Begin DoDot:1

 +21               SET PENCAN=""

FOR

                       SET PENCAN=$ORDER(PSOSDX(PENCAN))

                       if 'PENCAN

                           QUIT

                       SET DA=PENCAN

                       DO PSOL^PSSLOCK(DA_"S")

                       IF $GET(PSOMSG)

                           DO PEN

                           DO PSOUL^PSSLOCK(DA_"S")

               End DoDot:1

           if '$GET(PSOCANPN)

               Begin DoDot:1

               End DoDot:1

           KILL PSOCANPN,PSOSDX,PSOSDXY,PENCAN

           DO ULP^PSOCAN

           GOTO PAT

LINE       WRITE !!

           SET DIR(0)="LO^1:"_$SELECT($GET(PSOHI):PSOHI,1:PSOSD)

           SET DIR("A")="ENTER THE LINE #"

           SET DIR("?",1)="Enter the line number(s) displayed to the left of the Rx#."

 +1        SET DIR("?",2)="   Separate the numbers with commas (Example: 3,8,10,7),"

           SET DIR("?",3)="   OR a dash (Example: 12-20), OR a combination of commas and"

           SET DIR("?",4)="   dashes (Example: 3-5,1,12)."

 +2        SET DIR("?")="Do not exceed 245 characters including commas and dashes."

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               DO ULP^PSOCAN

           if $GET(DIRUT)

               GOTO KILL

           IF Y["."

               WRITE !?53,$CHAR(7),"INVALID LINE NUMBER(S)."

               GOTO LINE

 +3        SET LINE=Y

           KILL PSCAN,PSOCAN

           SET (DRG,IN,STA)=""

           SET CNT=0

 +4        FOR

               SET STA=$ORDER(PSOSD(STA))

               if STA=""

                   QUIT

FOR

                   SET DRG=$ORDER(PSOSD(STA,DRG))

                   if DRG=""

                       QUIT

                   SET CNT=CNT+1

                   SET PSOCAN(CNT)=$SELECT(STA'="PENDING":$PIECE(PSOSD(STA,DRG),"^"),1:$PIECE(PSOSD(STA,DRG),"^",10)_"^P")

 +5        FOR CNT=1:1

               SET PLINE=$PIECE(LINE,",",CNT)

               if '$PIECE(LINE,",",CNT)

                   QUIT

               SET IN=$SELECT(IN="":PSOCAN(PLINE),1:IN_","_PSOCAN(PLINE))

 +6        DO RTEST

           DO SPEED

           DO ULP^PSOCAN

           if BC="P"

               GOTO NAM

           if BC="B"

               GOTO BC

PSPEED     SET (YY,DA)=$PIECE(PSOSD(STA,DRG),"^")

           SET RX=$PIECE($GET(^PSRX(DA,0)),"^")

           DO SPEED1

           if PSPOP!($DATA(PSINV(RX)))

               QUIT

 +1        if $GET(SPEED)&(REA="R")

               QUIT

SHOW       SET DRG=+$PIECE(^PSRX(DA,0),"^",6)

           SET DRG=$SELECT($DATA(^PSDRUG(DRG,0)):$PIECE(^(0),"^"),1:"")

PSHOW      SET LC=0

           WRITE !,$PIECE(^PSRX(DA,0),"^"),"  ",DRG,?52,$SELECT($DATA(^DPT(+$PIECE(^PSRX(DA,0),"^",2),0)):$PIECE(^(0),"^"),1:"PATIENT UNKNOWN")

 +1        IF REA="C"

               WRITE !?25,"Rx to be Discontinued",!

               GOTO SHOW1

 +2        WRITE !?21,"*** Rx to be Reinstated ***",!

SHOW1     ;S LC=LC+3 I LC>20 R !,"Press return to continue",X:DTIME G:X'="" SHOW1 S LC=0

 +1        IF $Y+4>IOSL

               KILL DIR,DUOUT,DTOUT,DIRUT

               SET DIR(0)="E"

               SET DIR("A")="Press Return to Continue"

               SET DIR("?")="Press Return to continue Listing Orders"

               DO ^DIR

               KILL DIR,DTOUT,DIRUT,DUOUT

               WRITE @IOF

 +2        QUIT

SPEED1     SET PSPOP=0

           IF $GET(PSODIV)

               IF +$PIECE($GET(^PSRX(DA,2)),"^",9)'=$GET(PSOSITE)

                   if '$GET(SPEED)

                       DO DIV^PSOCAN

 +1        KILL STAT

           SET STAT=+$PIECE(^PSRX(DA,"STA"),"^")

           SET REA=$EXTRACT("C00CCCCCCCCCR000C",STAT+1)

 +2        IF $$CONJ^PSOUTL(DA)

               SET PSINV(RX)=""

               QUIT

 +3        if $GET(SPEED)&(REA="R")

               QUIT

 +4        IF REA="R"

               IF $PIECE($GET(^PSRX(DA,"PKI")),"^")!$PIECE($GET(^PSRX(DA,"PKI")),"^",3)

                   SET PKI=1

                   SET PSINV(RX)=""

                   QUIT

 +5        IF REA=0!(PSPOP)!($PIECE(^PSRX(+YY,"STA"),"^")>12)

               IF $PIECE(^("STA"),"^")<16

                   SET PSINV(RX)=""

                   QUIT

 +6        if REA'=0&('PSPOP)

               SET PSCAN(RX)=DA_"^"_REA

               SET RXCNT=$GET(RXCNT)+1

 +7        QUIT

AREC       if '$GET(DEAD)

               SET REA=$SELECT($GET(REA)="L":"L",1:$PIECE(PSCAN($PIECE(^PSRX(DA,0),"^")),"^",2))

           SET ACNT=0

           FOR SUB=0:0

               SET SUB=$ORDER(^PSRX(DA,"A",SUB))

               if 'SUB

                   QUIT

               SET ACNT=SUB

 +1        SET RFCNT=0

           FOR RF=0:0

               SET RF=$ORDER(^PSRX(DA,1,RF))

               if 'RF

                   QUIT

               SET RFCNT=RF

               if RF>5

                   SET RFCNT=RF+1

 +2        DO NOW^%DTC

           SET ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1)

           SET ^PSRX(DA,"A",ACNT+1,0)=%_"^"_REA_"^"_DUZ_"^"_RFCNT_"^"_$SELECT($GET(MSG)]"":MSG,1:$GET(ACOM)_$GET(INCOM))

           SET ACOM=""

 +3        IF $DATA(PKIR)

               NEW J

               SET J=ACNT+2

               DO ADR^PSOPKIV1

 +4        DO EXP^PSOHELP1

 +5        QUIT

SPEED     ;

 +1        DO COM

           if '$DATA(INCOM)!($DATA(DIRUT))

               QUIT

           NEW PKI

           KILL PSINV,PSCAN

           FOR II=1:1

               SET DA=$PIECE(IN,",",II)

               if '$PIECE(IN,",",II)

                   QUIT

               Begin DoDot:1

 +2                IF $PIECE(DA,"^",2)="P"

                       SET DA=+DA

                       Begin DoDot:2

 +3                        DO PSOL^PSSLOCK(DA_"S")

                           IF $GET(PSOMSG)

                               DO PEN

                               DO PSOUL^PSSLOCK(DA_"S")

                       End DoDot:2

                       QUIT

 +4                IF $DATA(^PSRX(DA,0))

                       SET YY=DA

                       SET RX=$PIECE(^(0),"^")

                       if DA<0

                           SET PSINV(RX)=""

                       if DA>0

                           DO SPEED1

               End DoDot:1

 +5        if ALL="S"&($DATA(PSINV(RX)))

               GOTO INVALD

 +6        if '$DATA(PSCAN)

               GOTO INVALD

           SET II=""

           SET RXCNT=0

FOR

               SET II=$ORDER(PSCAN(II))

               if II=""

                   QUIT

               SET DA=+PSCAN(II)

               SET REA=$PIECE(PSCAN(II),"^",2)

               SET RXCNT=RXCNT+1

               DO SHOW

 +7       ;

ASK        if '$DATA(PSCAN)

               GOTO INVALD

           WRITE !

           SET DIR("A")="OK to "_$SELECT($GET(RXCNT)>1:"Change Status",REA="C":"Discontinue",1:"Reinstate")

           SET DIR(0)="Y"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               if $ORDER(PSOSDX(0))

                   SET PSOSDXY=1

               QUIT

 +1        IF 'Y

               if $ORDER(PSOSDX(0))

                   SET PSOSDXY=1

               KILL PSCAN

               DO INVALD

               QUIT

 +2        SET RX=""

FOR

               SET RX=$ORDER(PSCAN(RX))

               if RX=""

                   QUIT

               DO PSOL^PSSLOCK(+PSCAN(RX))

               IF $GET(PSOMSG)

                   DO ACT

                   DO PSOUL^PSSLOCK(+PSCAN(RX))

 +3        DO INVALD

           QUIT

ACT       ;*442

           SET DA=+PSCAN(RX)

           SET REA=$PIECE(PSCAN(RX),"^",2)

           SET II=RX

           SET PSODFN=$PIECE(^PSRX(DA,0),"^",2)

           IF REA="R"

               DO REINS^PSOCAN2

               IF '$GET(PSORX("DFLG"))

                   DO DCORD^PSONEW2

                   QUIT

 +1        DO CAN^PSOCAN

           QUIT

INVALD     KILL PSCAN

           if '$DATA(PSINV)

               QUIT

           WRITE !!

           FOR I=1:1:80

               WRITE "="

 +1        WRITE $CHAR(7),!!,"The Following Rx Number(s) Are Invalid Choices, Expired, "_$SELECT($GET(PKI):"Digitally Signed",1:""),!,"Discontinued by Provider, invalid except conjunction or Marked As Deleted:"

           SET II=""

FOR

               SET II=$ORDER(PSINV(II))

               if II=""

                   QUIT

               WRITE !?10,II

 +2        KILL PSINV

           IF $GET(PSOERR)!($GET(SPEED))

               KILL DIR,DUOUT,DTOUT,DIRUT

               SET DIR(0)="E"

               SET DIR("A")="Press Return to Continue"

               DO ^DIR

               KILL DIR,DTOUT,DIRUT,DUOUT

 +3        GOTO KILL

           QUIT

LISTPAT    SET X="?"

           SET DIC(0)="EMQ"

           SET DIC="^DPT("

           DO ^DIC

           KILL DIC

           QUIT

 +1       ;

COM       ;

 +1       ; PSO*7*508 - if this is an eRx, set the comments and nature of order and quit - no user interaction

 +2        IF $GET(ERXDCIEN)

               Begin DoDot:1

 +3                SET INCOM=$$GET1^DIQ(52.49,ERXDCIEN,52.2,"E")

 +4                IF INCOM']""

                       SET INCOM="eRx discontinued by external prescriber"

 +5       ; set nature of order to 'auto'

 +6                SET PSOONOR="A"

               End DoDot:1

               QUIT

 +7       ; PSO*7*505 - end changes

 +8        WRITE !

 +9       ;Added to prevent INCOM from being superseded in AREC tag if DC comments entered.

           KILL MSG

 +10       SET DIR("A")="Comments"_$SELECT($DATA(PKIR):"/Reason for DCing",1:"")

           SET DIR(0)="F^5:75"

 +11       SET DIR("?")="Comments must be entered.  Comments must be 5 to 75 characters and must not contain embedded uparrow"

 +12       if $DATA(INCOM)

               SET DIR("B")=INCOM

 +13       DO ^DIR

           IF $DATA(DIRUT)

               KILL DIR,DTOUT,DUOUT,Y

               QUIT

 +14       SET INCOM=Y

           if $DATA(PKIR)

               SET PKIR=Y

           KILL DIR,DTOUT,DIRUT,DUOUT

 +15       DO NOOR^PSOCAN4

 +16       QUIT

KILL       DO KILL^PSOCAN2

 +1        KILL PSOMSG,PSOPLCK,PSOWUN,PSOULRX

 +2        QUIT

PEN       ;discontinue pending orders

 +1        SET PSODAPND=DA

 +2        KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,DA,0),"^",2),+$PIECE($GET(^PS(52.41,DA,"INI")),"^"),DA)

           SET $PIECE(^PS(52.41,DA,0),"^",3)="DC"

           SET ^PS(52.41,DA,4)=INCOM_" Discontinued by Pharmacy."

 +3        DO EN^PSOHLSN(+^PS(52.41,DA,0),"OC",INCOM,PSONOOR)

 +4        SET DA=PSODAPND

           KILL PSODAPND

 +5        QUIT

RTEST     ;

 +1        if '$GET(LINE)

               QUIT

 +2        NEW PCIN,PCINFLAG,PCINX

 +3        SET PCINFLAG=0

           FOR PCIN=1:1

               SET PCINX=$PIECE(LINE,",",PCIN)

               if $PIECE(LINE,",",PCIN)']""

                   QUIT

               Begin DoDot:1

 +4                if '$GET(PCINX)

                       QUIT

 +5                if '$GET(PSOCAN(PCINX))

                       QUIT

 +6                IF PSOCAN(PCINX)'["^P"

                       IF $PIECE($GET(^PSRX(+$GET(PSOCAN(PCINX)),"STA")),"^")'=12

                           IF '$GET(PCINFLAG)

                               SET PSOCANRD=+$PIECE($GET(^PSRX($GET(PSOCAN(PCINX)),0)),"^",4)

                               SET PCINFLAG=1

 +7                IF PSOCAN(PCINX)["^P"

                       IF '$GET(PCINFLAG)

                           SET PSOCANRD=+$PIECE($GET(^PS(52.41,+$PIECE(PSOCAN(PCINX),"^"),0)),"^",5)

                           SET PCINFLAG=1

               End DoDot:1

 +8        IF '$GET(PCINFLAG)

               SET PSOCANRZ=1

 +9        QUIT

RTESTA    ;

 +1        NEW PFIN,PFINZ,PFINFLAG

 +2        SET PFINFLAG=0

           SET PFIN=""

FOR

               SET PFIN=$ORDER(PSOSD(PFIN))

               if PFIN=""

                   QUIT

               SET PFINZ=""

FOR

                   SET PFINZ=$ORDER(PSOSD(PFIN,PFINZ))

                   if PFINZ=""

                       QUIT

                   Begin DoDot:1

 +3                    IF $GET(PFIN)'="PENDING"

                           IF $PIECE($GET(^PSRX(+$PIECE($GET(PSOSD(PFIN,PFINZ)),"^"),"STA")),"^")'=12

                               IF '$GET(PFINFLAG)

                                   SET PSOCANRD=+$PIECE($GET(^(0)),"^",4)

                                   SET PFINFLAG=1

 +4                    IF $GET(PFIN)="PENDING"

                           IF '$GET(PFINFLAG)

                               SET PSOCANRD=+$PIECE($GET(^PS(52.41,+$PIECE($GET(PSOSD(PFIN,PFINZ)),"^",10),0)),"^",5)

                               SET PFINFLAG=1

                   End DoDot:1

 +5        IF '$GET(PFINFLAG)

               SET PSOCANRZ=1

 +6        QUIT

ONOFF     ;

 +1        IF $GET(PSOREINF)

               SET PSORX("DOSING INFO")=1

 +2        IF $GET(PSORX("DOSING INFO"))&'$GET(PSOREINF)

               SET PSOREINF=1

 +3        QUIT

PSOCAN1.m