PSOORFI6 ;BIR/SJA - finish cprs orders cont. ;Nov 30, 2021@08:00:07
;;7.0;OUTPATIENT PHARMACY;**225,505,441,671**;DEC 1997;Build 3
;External reference to ^PSDRUG supported by DBIA 221
;External references PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to ^DPT supported by DBIA 10035
;External reference to ^PSSUTLA1 supported by DBIA 3373
;
DC N ACTION,LST,PSI,PSODFLG,PSONOORS,PSOOPT
N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE
I '$G(PSOERR("DEAD")) S PSOELSE=1 D PDATA Q:$D(DUOUT)!$D(DTOUT) D Q:$D(DIRUT)
.D NOOR^PSOCAN4 Q:$D(DIRUT)
.S DIR("A")="Comments",DIR(0)="F^10:75",DIR("B")="Per Pharmacy Request" D ^DIR K DIR
I '$G(PSOELSE) K PSOELSE S PSONOOR="A" D DE^PSOORFI2 I '$G(ACTION)!('$D(PSODFLG)) S VALMBCK="R" Q
K PSOELSE I $D(DIRUT) K DIRUT,DUOUT,DTOUT,Y Q
S ACOM=Y
S INCOM=ACOM,PSONOORS=PSONOOR D DE^PSOORFI2
I '$G(ACTION)!('$D(PSODFLG)) Q
S PSONOOR=PSONOORS D RTEST D SPEED D ULP^PSOCAN
K PSOCAN,ACOM,INCOM,ACTION,LINE,PSONOOR,PSOSDXY,PSONOORS,PSOOPT,RXCNT,REA,RX,PSODA,DRG
S Y=-1
Q
PSPEED S (YY,PSODA)=$P(PSOSD(STA,DRG),"^"),RX=$P($G(^PSRX(PSODA,0)),"^") D SPEED1 Q:PSPOP!($D(PSINV(RX)))
Q:$G(SPEED)&(REA="R")
SHOW S DRG=+$P(^PSRX(PSODA,0),"^",6),DRG=$S($D(^PSDRUG(DRG,0)):$P(^(0),"^"),1:"")
S LC=0 W !,$P(^PSRX(PSODA,0),"^")," ",DRG,?52,$S($D(^DPT(+$P(^PSRX(PSODA,0),"^",2),0)):$P(^(0),"^"),1:"PATIENT UNKNOWN")
I REA="C" W !?25,"Rx to be Discontinued",! Q
W !?21,"*** Rx to be Reinstated ***",!
Q
SPEED1 S PSPOP=0 I $G(PSODIV),+$P($G(^PSRX(PSODA,2)),"^",9)'=$G(PSOSITE) D:'$G(SPEED) DIV^PSOCAN
K STAT S STAT=+$P(^PSRX(PSODA,"STA"),"^"),REA=$E("C00CCCCCCCCCR000C",STAT+1)
Q:$G(SPEED)&(REA="R")
I REA="R",$P($G(^PSRX(PSODA,"PKI")),"^") 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)=PSODA_"^"_REA,RXCNT=$G(RXCNT)+1
Q
SPEED N PKI K PSINV,PSCAN S PSODA=IN I $D(^PSRX(PSODA,0)) S YY=PSODA,RX=$P(^(0),"^") S:PSODA<0 PSINV(RX)="" D:PSODA>0 SPEED1
G:'$D(PSCAN) INVALD S II="",RXCNT=0 F S II=$O(PSCAN(II)) Q:II="" S PSODA=+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 the active order",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 Q
S PSOOPT=-1 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, 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
KILL D KILL^PSOCAN2
K PSOMSG,PSOPLCK,PSOWUN,PSOULRX
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 $P($G(^PSRX(+$G(PSOCAN(PCINX)),"STA")),"^")'=12,'$G(PCINFLAG) S PSOCANRD=+$P($G(^PSRX($G(PSOCAN(PCINX)),0)),"^",4) 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(PFINFLAG) S PSOCANRZ=1
Q
PDATA Q:$P(^PS(52.41,ORD,0),"^",3)'="RNW"!('$P(^PS(52.41,ORD,0),"^",21))
S PSI=0,IN=0 F S PSI=$O(PSOLST(PSI)) Q:'PSI!(IN) I $P(PSOLST(PSI),"^",2)=$P(^PS(52.41,ORD,0),"^",21) S LINE=PSI,(PSOCAN(PSI),IN)=$P(PSOLST(PSI),"^",2)
Q:'$G(LINE)
S:(+$G(^PSRX($P(^PS(52.41,ORD,0),"^",21),"STA"))<9) PSODFLG=1 Q:'$G(PSODFLG)
D ASKDC S ACTION=Y
Q
ASKDC W ! K DIR,DUOUT,DIRUT,DTOUT
S DIR("A")="There is an active Rx for this pending order, Discontinue both (Y/N)",DIR("B")="NO",DIR(0)="Y"
S DIR("?",1)="Y - Discontinue both pending and active Rx",DIR("?",2)="N - Discontinue pending order only"
S DIR("?")="'^' - Quit (no action taken)" D ^DIR K DIR Q
; INPUT
; FS - the first sort type that was done before calling into the secondary sort.
; - EX: PA:PATIENT, RT:ROUTE, PR:PRIORITY ..
; FSVAL - the value associated with the first sort.
DIR(FSORT,FSVAL) ;
N DIR,Y,RLINE,STAG,SVAL,RES,FILSTR,DONE,FILTER,FIRST,JCNT,J
K DIR
S DIR(0)="Y",DIR("B")="N"
S DIR("A")="Would you like to select a secondary filter"
D ^DIR K DIR I 'Y K Y Q 0
I $G(FSORT)']"" S FILSTR="PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAGGED;CS:CONTROLLED SUBSTANCES;SU:SUPPLY;C:CONTINUE W/PRIMARY;E:EXIT"
I '$L($G(FILSTR)) D
.S (DONE,JCNT)=0
.F J=1:1 D Q:DONE
..S FILTER=$T(SCRIT+J) I FILTER=" Q" S DONE=1 Q
..S FILTER=$P(FILTER,";;",2)
..I $D(FSORT),FILTER=FSORT Q
..I $D(FSORT),FSORT="SU:SUPPLY",FILTER="CS:CONTROLLED SUBSTANCES" Q
..I $D(FSORT),FSORT="CS:CONTROLLED SUBSTANCES",FILTER="SU:SUPPLY" Q
..; set up default for DIR("B"), in our case we will use the first item in the list that is not equal
..; to the first sort that occured
..S JCNT=JCNT+1 I JCNT=1 S FIRST=FILTER
..I '$L($G(FILSTR)) S FILSTR=FILTER Q
..S FILSTR=$G(FILSTR)_";"_FILTER
I $G(FIRST)']"" S FIRST="PA:PATIENT"
S DIR("?")="^D ST^PSOORFI1("_""""_$P(FSORT,":")_""""_")",DIR("A")="Select another filter",DIR("B")=$P($G(FIRST),":",2)
S DIR(0)="SMB"_U_FILSTR
D ^DIR K DIR
I $D(DIRUT)!(Y="E") Q U
I Y="C" Q 0
S RES=Y
S RLINE=$S(RES="PA":"PAT",RES="RT":"RTE",RES="PR":"PRI",RES="CL":"CLIN",RES="FL":"FLG",RES="CS":"CS",RES="SU":"SUPPLY",1:"")
I RLINE']"" Q 0
S STAG=RLINE
S SVAL=$$@STAG
I SVAL=U Q U
I SVAL=""!(SVAL=0) Q 0
; consider a message indicating that the secondary sort may cause delays/hang time before display
Q RES_U_SVAL
PAT() ;
N DIR,Y,PSOSORT,DIC,SEL
S PSOSORT="PATIENT"
S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE"
D ^DIR K DIR
S SEL=Y
I $D(DIRUT)!(SEL="E") Q U
PRMT I SEL="S" D Q PSOSORT
.S PSOSORT=PSOSORT_U_"SINGLE"
.S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" S PSOSORT=0 Q
.I $D(DIRUT) S PSOSORT=0 Q
.S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
.D ^DIC K DIC
.I "^"[X S PSOSORT=0 Q
.S (PSODFN,PAT)=+Y,PSOFINY=Y
.I $P(Y,U)<1 G PRMT
.I $P(Y,U) S PSOSORT=PSOSORT_U_$P(Y,U),(PSODFN,PAT)=+Y,PSOFINY=Y
I SEL="A" S PSOSORT=PSOSORT_U_"ALL"
Q PSOSORT
RTE() ;
N DIR,Y,PSOSORT,RESULTS,PSOPARKX
K DIR S PSOSORT="ROUTE"
S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
I $G(PSOPARKX(0))="YES" S DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;C:CLINIC;E:EXIT"
D ^DIR K DIR
I $D(DIRUT)!(Y="E") Q U
S PSOSORT=PSOSORT_"^"_Y
Q PSOSORT
PRI() ;
N DIR,Y,PSOSORT
K DIR S PSOSORT="PRIORITY"
S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
D ^DIR K DIR
I $D(DIRUT) Q U
S PSOSORT=PSOSORT_"^"_Y
Q PSOSORT
CLIN() ;
K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
N PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
K DIR S DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT",DIR("A")="Select By",DIR("B")="Clinic",DIR("?",1)="Enter 'C' to process orders for one individual Clinic,"
S DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,",DIR("?",3)=" '^' or 'E' to exit" S DIR("?")=" "
W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(Y="E") W ! Q U
I Y="S" D SORT I $O(^TMP($J,"PSOCL",0)) Q 1
CLIN2 W ! K DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) Q 0
S PSOCLIN=+Y,PSOCLINF=1 D CHECK^PSOORFI3 I $G(PSOCFLAG) D INSTNM^PSOORFI2 W !!,"You are signed in under the "_$G(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",! K PSODINST G CLIN2
S ^TMP($J,"PSOCL",PSOCLIN)=PSOCLIN K PSOCLIN Q 1
SORT W ! K DIC S DIC="^PS(59.8,",DIC(0)="QEAMZ",DIC("A")="Select CLINIC SORT GROUP: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) Q 0
S PSOCLINS=+Y
K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX") F PSCLP=0:0 S PSCLP=$O(^PS(59.8,PSOCLINS,1,PSCLP)) Q:'PSCLP S PSOSTC=+$P($G(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^") S:$G(PSOSTC)&($D(^SC(PSOSTC,0))) ^TMP($J,"PSOCL",PSOSTC)=PSOSTC
I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics associated with this Sort Group!",! K ^TMP($J,"PSOCL") G SORT
F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCL",PSCLP)) Q:'PSCLP S PSOCLIN=PSCLP D CHECK^PSOORFI3 I $G(PSOCFLAG) S ^TMP($J,"PSOCLX",PSCLP)=PSCLP K ^TMP($J,"PSOCL",PSCLP)
I $O(^TMP($J,"PSOCLX",0)) H 1 W @IOF W !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",! D
.F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCLX",PSCLP)) Q:'PSCLP D:($Y+4)>IOSL W !,$P($G(^SC(PSCLP,0)),"^")
..W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR W @IOF
I $O(^TMP($J,"PSOCLX",0)) D EOP^PSOORFI3 Q 1
K ^TMP($J,"PSOCLX") I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics that have a matching Institution!",! D EOP^PSOORFI3 G SORT
Q
FLG() ;
Q "FLAGGED^FLAGGED"
CS() ;
N DIR,PSOCSRT,PSOPARKX,PSOSORT,RESULTS,Y
K DIR S DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT",DIR("B")="BOTH"
S RESULTS="PSOPARKX" D GETPARK^PSORPC01()
I $G(PSOPARKX(0))="YES" S DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;A:ALL;E:EXIT",DIR("B")="ALL"
D ^DIR
Q:$D(DIRUT)!(Y="E") U
S PSOCSRT=$S(Y="A":1,Y="B":1,1:Y)
W !!,"Select a schedule(s)"
K DIR S PSOSORT="DIGITALLY SIGNED"
S DIR("A")="Select Schedule(s)",DIR(0)="S^1:SCHEDULE II;2:SCHEDULES III - V;3:SCHEDULES II - V;4:NON-CS+SCHEDULES III - V;5:NON-CS ONLY;E:EXIT",DIR("B")=3
D ^DIR K DIR
I $D(DIRUT)!(Y="E") Q U
S PSOSORT=PSOSORT_"^"_Y_U_PSOCSRT
Q PSOSORT
SUPPLY() ;
Q "SUPPLY^SUPPLY"
; INPUT
; IEN - IEN of the entry in 52.41 (PENDING OUTPATIENT ORDERS)
; FLTR - filter criteria as returned from $$DIR
CHKFLTR(IEN,FLTR,CNT) ; CHECK THE SECONDARY FILTER FOR PENDING ORDERS
N FLTRTYP,FLTRVAL,RES,DRG,CLIN,OR0
; everytime we have a result of 0 increment the counter
; everytime we have a result of 1, reset the counter
; when counter reaches 100, display a '.' on the screen and reset the counter
;S GL=$NA(^TMP($J,"ROUTINE","CNT"))
I '$G(IEN) Q 0
S FLTRTYP=$P(FLTR,U) I FLTRTYP="" Q 1
S FLTRVAL=$P(FLTR,U,3)
; always return 1 for all patients
I FLTRTYP="PA",FLTRVAL="ALL" Q 1
; route filter
I FLTRTYP="RT" D Q RES
.I $$GET1^DIQ(52.41,IEN,19,"I")'=FLTRVAL S RES=0 Q
.S RES=1
; single patient
I FLTRTYP="PA" D Q RES
.; for a single patient selection, the IEN is piece 4. also, if there is no filter value, how could we filter? just return 1?
.S FLTRVAL=$P(FLTR,U,4) I 'FLTRVAL S RES=1 Q
.I $$GET1^DIQ(52.41,IEN,1,"I")'=FLTRVAL S RES=0 Q
.S RES=1
; clinic filter
I FLTRTYP="CL" D Q RES
.I $P(FLTR,U,2)'=1 S RES=1 Q
.I '$O(^TMP($J,"PSOCL",0)) S RES=1 Q
.S CLIN=$$GET1^DIQ(52.41,IEN,1.1,"I") I 'CLIN S RES=0 Q
.I '$D(^TMP($J,"PSOCL",CLIN)) S RES=0 Q
.S RES=1
; supply items filter
I FLTRTYP="FL" D Q RES
.I '$D(^PS(52.41,IEN,0))!('$P($G(^PS(52.41,IEN,0)),"^",23)) S RES=0 Q
.S RES=1
; priority
I FLTRTYP="PR" D Q RES
.I $$GET1^DIQ(52.41,IEN,25,"I")'=FLTRVAL S RES=0 Q
.S RES=1
; supply filter
I FLTRTYP="SU" D Q RES
.S RES=$$ISSUPPLY(IEN)
; controlled substances
S FLTRVAL=$P(FLTR,U,3)
I FLTRTYP="CS" D Q RES
.N PSRT ;p671
.S PDEA=0,OR0=$G(^PS(52.41,IEN,0)),PSRT=FLTRVAL
.D PDEA^PSOORFI5 I 'PDEA!(PDEA'=PSRT) S RES=0 Q
.S RES=1
Q
ISSUPPLY(IEN) ;
N DIEN,DEAHLDG,ORITEM,ORSUP,RES
S RES=0
S DIEN=$$GET1^DIQ(52.41,IEN,11,"I")
I DIEN S DEAHLDG=$$GET1^DIQ(50,DIEN,3,"E")
S ORITEM=$$GET1^DIQ(52.41,IEN,8,"I") Q:'ORITEM
I ORITEM S ORSUP=$$GET1^DIQ(50.7,ORITEM,.09,"I")
I $G(DEAHLDG)["S"!($G(ORSUP)=1) S RES=1
Q RES
; replace PDEA^PSOORFI5 with updated version
PDEA ;
I +$P(OR0,"^",9) S PDEA=$P($G(^PSDRUG($P(OR0,"^",9),0)),"^",3),PDEA=$S(PDEA[2:1,PDEA[3!(PDEA[4)!(PDEA[5):2,1:0)
E S PDEA=$$OIDEA^PSSUTLA1($P(OR0,"^",8),"O")
I PDEA=2,PSRT=4 S PDEA=4 Q
I PDEA=0,PSRT=5 S PDEA=5 Q
I PDEA,PSRT=3 S PDEA=3
Q
SCRIT ;
;;PA:PATIENT
;;RT:ROUTE
;;PR:PRIORITY
;;CL:CLINIC
;;FL:FLAGGED
;;CS:CONTROLLED SUBSTANCES
;;SU:SUPPLY
;;C:CONTINUE W/PRIMARY
;;E:EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORFI6 12966 printed Apr 09, 2024@21:31:28 Page 2
PSOORFI6 ;BIR/SJA - finish cprs orders cont. ;Nov 30, 2021@08:00:07
+1 ;;7.0;OUTPATIENT PHARMACY;**225,505,441,671**;DEC 1997;Build 3
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External references PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+4 ;External reference to ^DPT supported by DBIA 10035
+5 ;External reference to ^PSSUTLA1 supported by DBIA 3373
+6 ;
DC NEW ACTION,LST,PSI,PSODFLG,PSONOORS,PSOOPT
+1 NEW VALMCNT
WRITE !
KILL DIR,DUOUT,DIROUT,DTOUT,PSOELSE
+2 IF '$GET(PSOERR("DEAD"))
SET PSOELSE=1
DO PDATA
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
Begin DoDot:1
+3 DO NOOR^PSOCAN4
if $DATA(DIRUT)
QUIT
+4 SET DIR("A")="Comments"
SET DIR(0)="F^10:75"
SET DIR("B")="Per Pharmacy Request"
DO ^DIR
KILL DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+5 IF '$GET(PSOELSE)
KILL PSOELSE
SET PSONOOR="A"
DO DE^PSOORFI2
IF '$GET(ACTION)!('$DATA(PSODFLG))
SET VALMBCK="R"
QUIT
+6 KILL PSOELSE
IF $DATA(DIRUT)
KILL DIRUT,DUOUT,DTOUT,Y
QUIT
+7 SET ACOM=Y
+8 SET INCOM=ACOM
SET PSONOORS=PSONOOR
DO DE^PSOORFI2
+9 IF '$GET(ACTION)!('$DATA(PSODFLG))
QUIT
+10 SET PSONOOR=PSONOORS
DO RTEST
DO SPEED
DO ULP^PSOCAN
+11 KILL PSOCAN,ACOM,INCOM,ACTION,LINE,PSONOOR,PSOSDXY,PSONOORS,PSOOPT,RXCNT,REA,RX,PSODA,DRG
+12 SET Y=-1
+13 QUIT
PSPEED SET (YY,PSODA)=$PIECE(PSOSD(STA,DRG),"^")
SET RX=$PIECE($GET(^PSRX(PSODA,0)),"^")
DO SPEED1
if PSPOP!($DATA(PSINV(RX)))
QUIT
+1 if $GET(SPEED)&(REA="R")
QUIT
SHOW SET DRG=+$PIECE(^PSRX(PSODA,0),"^",6)
SET DRG=$SELECT($DATA(^PSDRUG(DRG,0)):$PIECE(^(0),"^"),1:"")
+1 SET LC=0
WRITE !,$PIECE(^PSRX(PSODA,0),"^")," ",DRG,?52,$SELECT($DATA(^DPT(+$PIECE(^PSRX(PSODA,0),"^",2),0)):$PIECE(^(0),"^"),1:"PATIENT UNKNOWN")
+2 IF REA="C"
WRITE !?25,"Rx to be Discontinued",!
QUIT
+3 WRITE !?21,"*** Rx to be Reinstated ***",!
+4 QUIT
SPEED1 SET PSPOP=0
IF $GET(PSODIV)
IF +$PIECE($GET(^PSRX(PSODA,2)),"^",9)'=$GET(PSOSITE)
if '$GET(SPEED)
DO DIV^PSOCAN
+1 KILL STAT
SET STAT=+$PIECE(^PSRX(PSODA,"STA"),"^")
SET REA=$EXTRACT("C00CCCCCCCCCR000C",STAT+1)
+2 if $GET(SPEED)&(REA="R")
QUIT
+3 IF REA="R"
IF $PIECE($GET(^PSRX(PSODA,"PKI")),"^")
SET PKI=1
SET PSINV(RX)=""
QUIT
+4 IF REA=0!(PSPOP)!($PIECE(^PSRX(+YY,"STA"),"^")>12)
IF $PIECE(^("STA"),"^")<16
SET PSINV(RX)=""
QUIT
+5 if REA'=0&('PSPOP)
SET PSCAN(RX)=PSODA_"^"_REA
SET RXCNT=$GET(RXCNT)+1
+6 QUIT
SPEED NEW PKI
KILL PSINV,PSCAN
SET PSODA=IN
IF $DATA(^PSRX(PSODA,0))
SET YY=PSODA
SET RX=$PIECE(^(0),"^")
if PSODA<0
SET PSINV(RX)=""
if PSODA>0
DO SPEED1
+1 if '$DATA(PSCAN)
GOTO INVALD
SET II=""
SET RXCNT=0
FOR
SET II=$ORDER(PSCAN(II))
if II=""
QUIT
SET PSODA=+PSCAN(II)
SET REA=$PIECE(PSCAN(II),"^",2)
SET RXCNT=RXCNT+1
DO SHOW
+2 ;
ASK if '$DATA(PSCAN)
GOTO INVALD
WRITE !
SET DIR("A")="OK to "_$SELECT($GET(RXCNT)>1:"Change Status",REA="C":"Discontinue the active order",1:"Reinstate")
SET DIR(0)="Y"
SET DIR("B")="N"
+1 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
if $ORDER(PSOSDX(0))
SET PSOSDXY=1
QUIT
+2 IF 'Y
if $ORDER(PSOSDX(0))
SET PSOSDXY=1
KILL PSCAN
DO INVALD
QUIT
+3 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))
+4 DO INVALD
+5 QUIT
ACT 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
QUIT
+1 SET PSOOPT=-1
DO CAN^PSOCAN
+2 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, 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"
+3 DO ^DIR
KILL DIR,DTOUT,DIRUT,DUOUT
KILL DO KILL^PSOCAN2
+1 KILL PSOMSG,PSOPLCK,PSOWUN,PSOULRX
+2 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 $PIECE($GET(^PSRX(+$GET(PSOCAN(PCINX)),"STA")),"^")'=12
IF '$GET(PCINFLAG)
SET PSOCANRD=+$PIECE($GET(^PSRX($GET(PSOCAN(PCINX)),0)),"^",4)
SET PCINFLAG=1
End DoDot:1
+7 IF '$GET(PCINFLAG)
SET PSOCANRZ=1
+8 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
End DoDot:1
+4 IF '$GET(PFINFLAG)
SET PSOCANRZ=1
+5 QUIT
PDATA if $PIECE(^PS(52.41,ORD,0),"^",3)'="RNW"!('$PIECE(^PS(52.41,ORD,0),"^",21))
QUIT
+1 SET PSI=0
SET IN=0
FOR
SET PSI=$ORDER(PSOLST(PSI))
if 'PSI!(IN)
QUIT
IF $PIECE(PSOLST(PSI),"^",2)=$PIECE(^PS(52.41,ORD,0),"^",21)
SET LINE=PSI
SET (PSOCAN(PSI),IN)=$PIECE(PSOLST(PSI),"^",2)
+2 if '$GET(LINE)
QUIT
+3 if (+$GET(^PSRX($PIECE(^PS(52.41,ORD,0),"^",21),"STA"))<9)
SET PSODFLG=1
if '$GET(PSODFLG)
QUIT
+4 DO ASKDC
SET ACTION=Y
+5 QUIT
ASKDC WRITE !
KILL DIR,DUOUT,DIRUT,DTOUT
+1 SET DIR("A")="There is an active Rx for this pending order, Discontinue both (Y/N)"
SET DIR("B")="NO"
SET DIR(0)="Y"
+2 SET DIR("?",1)="Y - Discontinue both pending and active Rx"
SET DIR("?",2)="N - Discontinue pending order only"
+3 SET DIR("?")="'^' - Quit (no action taken)"
DO ^DIR
KILL DIR
QUIT
+4 ; INPUT
+5 ; FS - the first sort type that was done before calling into the secondary sort.
+6 ; - EX: PA:PATIENT, RT:ROUTE, PR:PRIORITY ..
+7 ; FSVAL - the value associated with the first sort.
DIR(FSORT,FSVAL) ;
+1 NEW DIR,Y,RLINE,STAG,SVAL,RES,FILSTR,DONE,FILTER,FIRST,JCNT,J
+2 KILL DIR
+3 SET DIR(0)="Y"
SET DIR("B")="N"
+4 SET DIR("A")="Would you like to select a secondary filter"
+5 DO ^DIR
KILL DIR
IF 'Y
KILL Y
QUIT 0
+6 IF $GET(FSORT)']""
SET FILSTR="PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAGGED;CS:CONTROLLED SUBSTANCES;SU:SUPPLY;C:CONTINUE W/PRIMARY;E:EXIT"
+7 IF '$LENGTH($GET(FILSTR))
Begin DoDot:1
+8 SET (DONE,JCNT)=0
+9 FOR J=1:1
Begin DoDot:2
+10 SET FILTER=$TEXT(SCRIT+J)
IF FILTER=" Q"
SET DONE=1
QUIT
+11 SET FILTER=$PIECE(FILTER,";;",2)
+12 IF $DATA(FSORT)
IF FILTER=FSORT
QUIT
+13 IF $DATA(FSORT)
IF FSORT="SU:SUPPLY"
IF FILTER="CS:CONTROLLED SUBSTANCES"
QUIT
+14 IF $DATA(FSORT)
IF FSORT="CS:CONTROLLED SUBSTANCES"
IF FILTER="SU:SUPPLY"
QUIT
+15 ; set up default for DIR("B"), in our case we will use the first item in the list that is not equal
+16 ; to the first sort that occured
+17 SET JCNT=JCNT+1
IF JCNT=1
SET FIRST=FILTER
+18 IF '$LENGTH($GET(FILSTR))
SET FILSTR=FILTER
QUIT
+19 SET FILSTR=$GET(FILSTR)_";"_FILTER
End DoDot:2
if DONE
QUIT
End DoDot:1
+20 IF $GET(FIRST)']""
SET FIRST="PA:PATIENT"
+21 SET DIR("?")="^D ST^PSOORFI1("_""""_$PIECE(FSORT,":")_""""_")"
SET DIR("A")="Select another filter"
SET DIR("B")=$PIECE($GET(FIRST),":",2)
+22 SET DIR(0)="SMB"_U_FILSTR
+23 DO ^DIR
KILL DIR
+24 IF $DATA(DIRUT)!(Y="E")
QUIT U
+25 IF Y="C"
QUIT 0
+26 SET RES=Y
+27 SET RLINE=$SELECT(RES="PA":"PAT",RES="RT":"RTE",RES="PR":"PRI",RES="CL":"CLIN",RES="FL":"FLG",RES="CS":"CS",RES="SU":"SUPPLY",1:"")
+28 IF RLINE']""
QUIT 0
+29 SET STAG=RLINE
+30 SET SVAL=$$@STAG
+31 IF SVAL=U
QUIT U
+32 IF SVAL=""!(SVAL=0)
QUIT 0
+33 ; consider a message indicating that the secondary sort may cause delays/hang time before display
+34 QUIT RES_U_SVAL
PAT() ;
+1 NEW DIR,Y,PSOSORT,DIC,SEL
+2 SET PSOSORT="PATIENT"
+3 SET DIR("?")="^D PT^PSOORFI1"
SET DIR("A")="All Patients or Single Patient"
SET DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT"
SET DIR("B")="SINGLE"
+4 DO ^DIR
KILL DIR
+5 SET SEL=Y
+6 IF $DATA(DIRUT)!(SEL="E")
QUIT U
PRMT IF SEL="S"
Begin DoDot:1
+1 SET PSOSORT=PSOSORT_U_"SINGLE"
+2 SET DIR(0)="FO^2:30"
SET DIR("A")="Select Patient"
SET DIR("?")="^D HELP^PSOORFI2"
DO ^DIR
IF $EXTRACT(X)="?"
SET PSOSORT=0
QUIT
+3 IF $DATA(DIRUT)
SET PSOSORT=0
QUIT
+4 SET DIC(0)="EQM"
SET DIC=2
SET DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
+5 DO ^DIC
KILL DIC
+6 IF "^"[X
SET PSOSORT=0
QUIT
+7 SET (PSODFN,PAT)=+Y
SET PSOFINY=Y
+8 IF $PIECE(Y,U)<1
GOTO PRMT
+9 IF $PIECE(Y,U)
SET PSOSORT=PSOSORT_U_$PIECE(Y,U)
SET (PSODFN,PAT)=+Y
SET PSOFINY=Y
End DoDot:1
QUIT PSOSORT
+10 IF SEL="A"
SET PSOSORT=PSOSORT_U_"ALL"
+11 QUIT PSOSORT
RTE() ;
+1 NEW DIR,Y,PSOSORT,RESULTS,PSOPARKX
+2 KILL DIR
SET PSOSORT="ROUTE"
+3 SET DIR("?")="^D RT^PSOORFI1"
SET DIR("A")="Route"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT"
SET DIR("B")="WINDOW"
+4 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+5 IF $GET(PSOPARKX(0))="YES"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;C:CLINIC;E:EXIT"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)!(Y="E")
QUIT U
+8 SET PSOSORT=PSOSORT_"^"_Y
+9 QUIT PSOSORT
PRI() ;
+1 NEW DIR,Y,PSOSORT
+2 KILL DIR
SET PSOSORT="PRIORITY"
+3 SET DIR("A")="Select Priority"
SET DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE"
SET DIR("B")="ROUTINE"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT U
+6 SET PSOSORT=PSOSORT_"^"_Y
+7 QUIT PSOSORT
CLIN() ;
+1 KILL ^TMP($JOB,"PSOCL"),^TMP($JOB,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST
+2 NEW PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP
+3 KILL DIR
SET DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT"
SET DIR("A")="Select By"
SET DIR("B")="Clinic"
SET DIR("?",1)="Enter 'C' to process orders for one individual Clinic,"
+4 SET DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,"
SET DIR("?",3)=" '^' or 'E' to exit"
SET DIR("?")=" "
+5 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="E")
WRITE !
QUIT U
+6 IF Y="S"
DO SORT
IF $ORDER(^TMP($JOB,"PSOCL",0))
QUIT 1
CLIN2 WRITE !
KILL DIC
SET DIC="^SC("
SET DIC(0)="QEAMZ"
SET DIC("A")="Select CLINIC: "
DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
QUIT 0
+1 SET PSOCLIN=+Y
SET PSOCLINF=1
DO CHECK^PSOORFI3
IF $GET(PSOCFLAG)
DO INSTNM^PSOORFI2
WRITE !!,"You are signed in under the "_$GET(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",!
KILL PSODINST
GOTO CLIN2
+2 SET ^TMP($JOB,"PSOCL",PSOCLIN)=PSOCLIN
KILL PSOCLIN
QUIT 1
SORT WRITE !
KILL DIC
SET DIC="^PS(59.8,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select CLINIC SORT GROUP: "
DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
QUIT 0
+1 SET PSOCLINS=+Y
+2 KILL ^TMP($JOB,"PSOCL"),^TMP($JOB,"PSOCLX")
FOR PSCLP=0:0
SET PSCLP=$ORDER(^PS(59.8,PSOCLINS,1,PSCLP))
if 'PSCLP
QUIT
SET PSOSTC=+$PIECE($GET(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^")
if $GET(PSOSTC)&($DATA(^SC(PSOSTC,0)))
SET ^TMP($JOB,"PSOCL",PSOSTC)=PSOSTC
+3 IF '$ORDER(^TMP($JOB,"PSOCL",0))
WRITE !!,"There are no Clinics associated with this Sort Group!",!
KILL ^TMP($JOB,"PSOCL")
GOTO SORT
+4 FOR PSCLP=0:0
SET PSCLP=$ORDER(^TMP($JOB,"PSOCL",PSCLP))
if 'PSCLP
QUIT
SET PSOCLIN=PSCLP
DO CHECK^PSOORFI3
IF $GET(PSOCFLAG)
SET ^TMP($JOB,"PSOCLX",PSCLP)=PSCLP
KILL ^TMP($JOB,"PSOCL",PSCLP)
+5 IF $ORDER(^TMP($JOB,"PSOCLX",0))
HANG 1
WRITE @IOF
WRITE !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",!
Begin DoDot:1
+6 FOR PSCLP=0:0
SET PSCLP=$ORDER(^TMP($JOB,"PSOCLX",PSCLP))
if 'PSCLP
QUIT
if ($Y+4)>IOSL
Begin DoDot:2
+7 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
WRITE @IOF
End DoDot:2
WRITE !,$PIECE($GET(^SC(PSCLP,0)),"^")
End DoDot:1
+8 IF $ORDER(^TMP($JOB,"PSOCLX",0))
DO EOP^PSOORFI3
QUIT 1
+9 KILL ^TMP($JOB,"PSOCLX")
IF '$ORDER(^TMP($JOB,"PSOCL",0))
WRITE !!,"There are no Clinics that have a matching Institution!",!
DO EOP^PSOORFI3
GOTO SORT
+10 QUIT
FLG() ;
+1 QUIT "FLAGGED^FLAGGED"
CS() ;
+1 NEW DIR,PSOCSRT,PSOPARKX,PSOSORT,RESULTS,Y
+2 KILL DIR
SET DIR("A")="Route"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT"
SET DIR("B")="BOTH"
+3 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+4 IF $GET(PSOPARKX(0))="YES"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;A:ALL;E:EXIT"
SET DIR("B")="ALL"
+5 DO ^DIR
+6 if $DATA(DIRUT)!(Y="E")
QUIT U
+7 SET PSOCSRT=$SELECT(Y="A":1,Y="B":1,1:Y)
+8 WRITE !!,"Select a schedule(s)"
+9 KILL DIR
SET PSOSORT="DIGITALLY SIGNED"
+10 SET DIR("A")="Select Schedule(s)"
SET DIR(0)="S^1:SCHEDULE II;2:SCHEDULES III - V;3:SCHEDULES II - V;4:NON-CS+SCHEDULES III - V;5:NON-CS ONLY;E:EXIT"
SET DIR("B")=3
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)!(Y="E")
QUIT U
+13 SET PSOSORT=PSOSORT_"^"_Y_U_PSOCSRT
+14 QUIT PSOSORT
SUPPLY() ;
+1 QUIT "SUPPLY^SUPPLY"
+2 ; INPUT
+3 ; IEN - IEN of the entry in 52.41 (PENDING OUTPATIENT ORDERS)
+4 ; FLTR - filter criteria as returned from $$DIR
CHKFLTR(IEN,FLTR,CNT) ; CHECK THE SECONDARY FILTER FOR PENDING ORDERS
+1 NEW FLTRTYP,FLTRVAL,RES,DRG,CLIN,OR0
+2 ; everytime we have a result of 0 increment the counter
+3 ; everytime we have a result of 1, reset the counter
+4 ; when counter reaches 100, display a '.' on the screen and reset the counter
+5 ;S GL=$NA(^TMP($J,"ROUTINE","CNT"))
+6 IF '$GET(IEN)
QUIT 0
+7 SET FLTRTYP=$PIECE(FLTR,U)
IF FLTRTYP=""
QUIT 1
+8 SET FLTRVAL=$PIECE(FLTR,U,3)
+9 ; always return 1 for all patients
+10 IF FLTRTYP="PA"
IF FLTRVAL="ALL"
QUIT 1
+11 ; route filter
+12 IF FLTRTYP="RT"
Begin DoDot:1
+13 IF $$GET1^DIQ(52.41,IEN,19,"I")'=FLTRVAL
SET RES=0
QUIT
+14 SET RES=1
End DoDot:1
QUIT RES
+15 ; single patient
+16 IF FLTRTYP="PA"
Begin DoDot:1
+17 ; for a single patient selection, the IEN is piece 4. also, if there is no filter value, how could we filter? just return 1?
+18 SET FLTRVAL=$PIECE(FLTR,U,4)
IF 'FLTRVAL
SET RES=1
QUIT
+19 IF $$GET1^DIQ(52.41,IEN,1,"I")'=FLTRVAL
SET RES=0
QUIT
+20 SET RES=1
End DoDot:1
QUIT RES
+21 ; clinic filter
+22 IF FLTRTYP="CL"
Begin DoDot:1
+23 IF $PIECE(FLTR,U,2)'=1
SET RES=1
QUIT
+24 IF '$ORDER(^TMP($JOB,"PSOCL",0))
SET RES=1
QUIT
+25 SET CLIN=$$GET1^DIQ(52.41,IEN,1.1,"I")
IF 'CLIN
SET RES=0
QUIT
+26 IF '$DATA(^TMP($JOB,"PSOCL",CLIN))
SET RES=0
QUIT
+27 SET RES=1
End DoDot:1
QUIT RES
+28 ; supply items filter
+29 IF FLTRTYP="FL"
Begin DoDot:1
+30 IF '$DATA(^PS(52.41,IEN,0))!('$PIECE($GET(^PS(52.41,IEN,0)),"^",23))
SET RES=0
QUIT
+31 SET RES=1
End DoDot:1
QUIT RES
+32 ; priority
+33 IF FLTRTYP="PR"
Begin DoDot:1
+34 IF $$GET1^DIQ(52.41,IEN,25,"I")'=FLTRVAL
SET RES=0
QUIT
+35 SET RES=1
End DoDot:1
QUIT RES
+36 ; supply filter
+37 IF FLTRTYP="SU"
Begin DoDot:1
+38 SET RES=$$ISSUPPLY(IEN)
End DoDot:1
QUIT RES
+39 ; controlled substances
+40 SET FLTRVAL=$PIECE(FLTR,U,3)
+41 IF FLTRTYP="CS"
Begin DoDot:1
+42 ;p671
NEW PSRT
+43 SET PDEA=0
SET OR0=$GET(^PS(52.41,IEN,0))
SET PSRT=FLTRVAL
+44 DO PDEA^PSOORFI5
IF 'PDEA!(PDEA'=PSRT)
SET RES=0
QUIT
+45 SET RES=1
End DoDot:1
QUIT RES
+46 QUIT
ISSUPPLY(IEN) ;
+1 NEW DIEN,DEAHLDG,ORITEM,ORSUP,RES
+2 SET RES=0
+3 SET DIEN=$$GET1^DIQ(52.41,IEN,11,"I")
+4 IF DIEN
SET DEAHLDG=$$GET1^DIQ(50,DIEN,3,"E")
+5 SET ORITEM=$$GET1^DIQ(52.41,IEN,8,"I")
if 'ORITEM
QUIT
+6 IF ORITEM
SET ORSUP=$$GET1^DIQ(50.7,ORITEM,.09,"I")
+7 IF $GET(DEAHLDG)["S"!($GET(ORSUP)=1)
SET RES=1
+8 QUIT RES
+9 ; replace PDEA^PSOORFI5 with updated version
PDEA ;
+1 IF +$PIECE(OR0,"^",9)
SET PDEA=$PIECE($GET(^PSDRUG($PIECE(OR0,"^",9),0)),"^",3)
SET PDEA=$SELECT(PDEA[2:1,PDEA[3!(PDEA[4)!(PDEA[5):2,1:0)
+2 IF '$TEST
SET PDEA=$$OIDEA^PSSUTLA1($PIECE(OR0,"^",8),"O")
+3 IF PDEA=2
IF PSRT=4
SET PDEA=4
QUIT
+4 IF PDEA=0
IF PSRT=5
SET PDEA=5
QUIT
+5 IF PDEA
IF PSRT=3
SET PDEA=3
+6 QUIT
SCRIT ;
+1 ;;PA:PATIENT
+2 ;;RT:ROUTE
+3 ;;PR:PRIORITY
+4 ;;CL:CLINIC
+5 ;;FL:FLAGGED
+6 ;;CS:CONTROLLED SUBSTANCES
+7 ;;SU:SUPPLY
+8 ;;C:CONTINUE W/PRIMARY
+9 ;;E:EXIT
+10 QUIT
