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
Q
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
Q
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
Q
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
Q
KILL D KILL^PSOCAN2
K PSOMSG,PSOPLCK,PSOWUN,PSOULRX
Q
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
Q
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
Q
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
Q
ONOFF ;
I $G(PSOREINF) S PSORX("DOSING INFO")=1
I $G(PSORX("DOSING INFO"))&'$G(PSOREINF) S PSOREINF=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN1 9011 printed Sep 23, 2025@20:01:27 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
