PSOORFI5 ;BIR/SJA - finish cprs orders ;Oct 21, 2022@11:13
;;7.0;OUTPATIENT PHARMACY;**225,315,266,391,372,416,504,505,557,617,441,545,743**;DEC 1997;Build 24
;External references UL^PSSLOCK supported by DBIA 2789
;External reference to ^DPT supported by DBIA 10035
;External reference to ^PSSUTLA1 supported by DBIA 3373
;
FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
N SECSORT S SECSORT=$$DIR^PSOORFI6("FL:FLAGGED","FLAGGED") Q:SECSORT=U
S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
.Q:'$D(^PS(52.41,PSOD,0))!('$P($G(^PS(52.41,PSOD,0)),"^",23))
.Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
.I PAT'=PATA K PSORX("DOSING OFF") I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
.D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
.I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
.S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
.I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
.D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
.D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
.S PAT(PAT)=PAT
.F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
..I $P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD^PSOORFIN
.S X=PAT D ULP K PSOQQ
I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
G EX
;
SUP W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="SUPPLY^SUPPLY"
N SECSORT S SECSORT=$$DIR^PSOORFI6("SU:SUPPLY","SUPPLY") Q:SECSORT=U
S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
.Q:'$D(^PS(52.41,PSOD,0))!('$$ISSUPPLY^PSOORFI6(PSOD))
.I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
.Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
.I PAT'=PATA K PSORX("DOSING OFF") I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
.D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
.I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
.S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
.D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
.D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
.S PAT(PAT)=PAT
.F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
..I $P($G(^PS(52.41,ORD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
..Q:'$$ISSUPPLY^PSOORFI6(ORD)
..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
..D PP,LK1,ORD^PSOORFIN
.S X=PAT D ULP K PSOQQ
I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
G EX
Q
PRI ; Called from PSOORFIN due to it's routine size.
K DIR S PSOSORT="PRIORITY"
S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
N SECSORT S SECSORT=$$DIR^PSOORFI6("PR:PRIORITY",Y) Q:SECSORT=U
S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
.I $P($G(^PS(52.41,PSOD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
.Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
.;PSO*7*266
.I PAT'=PATA K PSORX("DOSING OFF") D LBL^PSOORFIN
.I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
.D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
.D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
.I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
.S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
.I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
.D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
.D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
.D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
.S X=PAT D ULP
;PSO*7*266
D LBL^PSOORFIN
I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
EX D EX^PSOORFI1
Q
LK D LOCK^PSOORFI1
Q
LK1 D LOCK1^PSOORFI1 Q
QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
S:$G(PSOQFLG) PAT(PAT)=PAT
Q
ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
D CLEAN^PSOVER1
I '$G(X) Q
D UL^PSSLOCK(X) Q
KLL K PSOPTLOK
Q
KLLP K PSONOLCK
Q
SPL D SPL^PSOORFI4
Q
SDFN S PSODFN=+$G(PSODFN)
Q
PP D PP^PSOORFI4
Q
KQ K PSOQUIT,POERR("QFLG")
Q
S D S^PSOORFI2 ; Process STAT priority
Q
;
E D E^PSOORFI2 ; Process EMERGENCY priority
Q
;
R D R^PSOORFI2 ; Process ROUTINE priority
Q
;
LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Information
N FLAG
K FLAGLINE S ORD=+$G(ORD) I 'ORD Q
;
I '$G(^PS(52.41,ORD,"FLG")) Q
; S X=IORVON_"Flagged"_IORVOFF
D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",35,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7
I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
I FLAG(52.41,ORD_",",36,"I")'="" D
. S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
. S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",38,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
. S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9
. I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
Q
;
CS ; Digitally Signed CS - PSO*7*391
K DIR
N PSOCSRT,PSOPARKX,RESULTS,Y
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")
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 G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
N SECSORT S SECSORT=$$DIR^PSOORFI6("CS:CONTROLLED SUBSTANCES",Y) Q:SECSORT=U
N PDEA,OR0 S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
.Q:'$D(^PS(52.41,PSOD,0))
.S OR0=^PS(52.41,PSOD,0)
.;PSO*7*505 - still quit if the order is flagged, but now only look for digital signature if the selection does not ask for non contolled substances
.I $P(OR0,"^",23),$P(SECSORT,"^",1)'="FL" Q
.S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
.;PSO*7*505 moved digitally signed check after the DEA check (Disregards eRx Pending orders)
.I PSRT<4,'$$ERXIEN^PSOERXUT(PSOD_"P"),'$P(OR0,"^",24) Q
.I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
.Q:$G(PAT($P(OR0,"^",2)))=$P(OR0,"^",2) S PAT=$P(OR0,"^",2)
.I PAT'=PATA K PSORX("DOSING OFF") I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
.D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
.I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
.S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
.I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
.D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
.D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
.S PAT(PAT)=PAT
.F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
..Q:'$D(^PS(52.41,ORD,0))
..S OR0=^PS(52.41,ORD,0)
..;PSO*505 - Move the check for digitally signed, so non-cs substances will be shown if selected as sort criteria
..I $P(OR0,U,23),$P(SECSORT,"^",1)'="FL" Q
..I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
..I 'PSOCSRT,PSOCSRT'=$P(OR0,"^",17) Q
..Q:$P(OR0,"^",3)="DC"!($P(OR0,"^",3)="DE")
..S PDEA=0 D PDEA Q:'PDEA!(PDEA'=PSRT)
..I PSRT<4,'$$ERXIEN^PSOERXUT(ORD_"P"),'$P(OR0,"^",24) Q
..D PP,LK1,ORD^PSOORFIN
.S X=PAT D ULP K PSOQQ
I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
G EX
;
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")
; PSO*7*505 - adding checks for new sort criteria
; PDEA=0 OR 2, covers non-cs and schedule 3-5
I (PDEA=0)!(PDEA=2),PSRT=4 S PDEA=4 Q
I PDEA=0,PSRT=5 S PDEA=5 Q
; PSO*7*505 end
I PDEA,PSRT=3 S PDEA=3
Q
;
PRV(PROV,DRG,ORN) ;
N DETN,DEA,I,LBL,VADD,SPC
I PROV="" Q
;*545 - show DEA label only, get the stored DEA#
S:$L($G(PSORX("RXDEA"))) DEA=PSORX("RXDEA")
;If renew, try to get DEA from the renewal from CPRS rather than the original RX, provider may have changed
I $G(PSOORRNW),$G(ORN) S DEA=$$RXDEA^PSOUTIL(,ORN)
I '$L($G(DEA)) S DEA=$S($G(PSONEW("OIRXN")):$$RXDEA^PSOUTIL(PSONEW("OIRXN")),$G(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV)) S:DEA]"" PSORX("RXDEA")=DEA
S:$L($G(PSORX("DETX"))) DETN=PSORX("DETX")
S LBL="DEA#: " I $G(ADDS) S LBL=" "_LBL
I DRG,$$DETOX^PSSOPKI(DRG),'$L($G(DETN)) S DETN=$S($G(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
S $P(SPC," ",($S($G(ADDS):30,1:33)-$L(DEA)))=" "
I (DEA'="")!($G(DETN)'="") S IEN=IEN+1,$E(^TMP("PSOPO",$J,IEN,0),16)=LBL_DEA_$S($G(DETN)]"":SPC_"DETOX#: "_$G(DETN),1:"")
I $G(ORN) D PRVAD^PSOPKIV2 I $G(VADD(1))]"" D
.S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_" Site Address: "_VADD(1)
.S:VADD(2)'="" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_" "_VADD(2) S:VADD(3)'="" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(ADDS):" ",1:"")_" "_VADD(3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORFI5 10722 printed Dec 13, 2024@02:32:03 Page 2
PSOORFI5 ;BIR/SJA - finish cprs orders ;Oct 21, 2022@11:13
+1 ;;7.0;OUTPATIENT PHARMACY;**225,315,266,391,372,416,504,505,557,617,441,545,743**;DEC 1997;Build 24
+2 ;External references UL^PSSLOCK supported by DBIA 2789
+3 ;External reference to ^DPT supported by DBIA 10035
+4 ;External reference to ^PSSUTLA1 supported by DBIA 3373
+5 ;
FLG WRITE !
KILL MEDP,MEDA,POERR("DFLG"),DIR
DO KQ
SET PSOSORT="FLAGGED^FLAGGED"
+1 NEW SECSORT
SET SECSORT=$$DIR^PSOORFI6("FL:FLAGGED","FLAGGED")
if SECSORT=U
QUIT
+2 SET LG=0
SET PATA=0
FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
if 'LG!($GET(POERR("QFLG")))
QUIT
FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
if 'PSOD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+3 if '$DATA(^PS(52.41,PSOD,0))!('$PIECE($GET(^PS(52.41,PSOD,0)),"^",23))
QUIT
+4 if $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
QUIT
SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
+5 IF PAT'=PATA
KILL PSORX("DOSING OFF")
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+6 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+7 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG,PSOQQ
QUIT
+8 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+9 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
QUIT
+10 if '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
QUIT
+11 DO SDFN
DO POST^PSOORFI1
IF $GET(PSOQFLG)!($GET(PSOQUIT))
if $GET(PSOQUIT)
SET POERR("QFLG")=1
if $GET(PSOQFLG)
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG
QUIT
+12 SET PAT(PAT)=PAT
+13 FOR ORD=0:0
SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
if 'ORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
QUIT
Begin DoDot:2
+14 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
QUIT
+15 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
DO PP
DO LK1
DO ORD^PSOORFIN
End DoDot:2
+16 SET X=PAT
DO ULP
KILL PSOQQ
End DoDot:1
+17 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+18 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO ^PSOORFIN
+19 GOTO EX
+20 ;
SUP WRITE !
KILL MEDP,MEDA,POERR("DFLG"),DIR
DO KQ
SET PSOSORT="SUPPLY^SUPPLY"
+1 NEW SECSORT
SET SECSORT=$$DIR^PSOORFI6("SU:SUPPLY","SUPPLY")
if SECSORT=U
QUIT
+2 SET LG=0
SET PATA=0
FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
if 'LG!($GET(POERR("QFLG")))
QUIT
FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
if 'PSOD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+3 if '$DATA(^PS(52.41,PSOD,0))!('$$ISSUPPLY^PSOORFI6(PSOD))
QUIT
+4 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
QUIT
+5 if $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
QUIT
SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
+6 IF PAT'=PATA
KILL PSORX("DOSING OFF")
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+7 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+8 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG,PSOQQ
QUIT
+9 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+10 if '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
QUIT
+11 DO SDFN
DO POST^PSOORFI1
IF $GET(PSOQFLG)!($GET(PSOQUIT))
if $GET(PSOQUIT)
SET POERR("QFLG")=1
if $GET(PSOQFLG)
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG
QUIT
+12 SET PAT(PAT)=PAT
+13 FOR ORD=0:0
SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
if 'ORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
QUIT
Begin DoDot:2
+14 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+15 if '$$ISSUPPLY^PSOORFI6(ORD)
QUIT
+16 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
QUIT
+17 DO PP
DO LK1
DO ORD^PSOORFIN
End DoDot:2
+18 SET X=PAT
DO ULP
KILL PSOQQ
End DoDot:1
+19 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+20 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO ^PSOORFIN
+21 GOTO EX
+22 QUIT
PRI ; Called from PSOORFIN due to it's routine size.
+1 KILL DIR
SET PSOSORT="PRIORITY"
+2 SET DIR("A")="Select Priority"
SET DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE"
SET DIR("B")="ROUTINE"
+3 DO ^DIR
if $DATA(DIRUT)
GOTO EX
SET PSOSORT=PSOSORT_"^"_Y
SET PSRT=Y
+4 NEW SECSORT
SET SECSORT=$$DIR^PSOORFI6("PR:PRIORITY",Y)
if SECSORT=U
QUIT
+5 SET LG=0
SET PATA=0
FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
if 'LG!($GET(POERR("QFLG")))
QUIT
FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
if 'PSOD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^PS(52.41,PSOD,0)),"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+7 if $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
QUIT
SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
+8 ;PSO*7*266
+9 IF PAT'=PATA
KILL PSORX("DOSING OFF")
DO LBL^PSOORFIN
+10 IF '$ORDER(^PS(52.41,"AP",PAT,PSRT,0))
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+11 DO PRI^PSOORFI2
IF $GET(PSZFIN)
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+12 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+13 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
QUIT
+14 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+15 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
QUIT
+16 if '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
QUIT
+17 DO SDFN
DO POST^PSOORFI1
IF $GET(PSOQFLG)!($GET(PSOQUIT))
if $GET(PSOQUIT)
SET POERR("QFLG")=1
if $GET(PSOQFLG)
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG
QUIT
+18 DO PP
SET ORD=0
DO @PSRT
SET PAT(PAT)=PAT
+19 SET X=PAT
DO ULP
End DoDot:1
+20 ;PSO*7*266
+21 DO LBL^PSOORFIN
+22 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO ^PSOORFIN
EX DO EX^PSOORFI1
+1 QUIT
LK DO LOCK^PSOORFI1
+1 QUIT
LK1 DO LOCK1^PSOORFI1
QUIT
QU IF $GET(PSOQUIT)
SET POERR("QFLG")=1
KILL PSOQUIT
+1 if $GET(PSOQFLG)
SET PAT(PAT)=PAT
+2 QUIT
ULP KILL PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+1 DO CLEAN^PSOVER1
+2 IF '$GET(X)
QUIT
+3 DO UL^PSSLOCK(X)
QUIT
KLL KILL PSOPTLOK
+1 QUIT
KLLP KILL PSONOLCK
+1 QUIT
SPL DO SPL^PSOORFI4
+1 QUIT
SDFN SET PSODFN=+$GET(PSODFN)
+1 QUIT
PP DO PP^PSOORFI4
+1 QUIT
KQ KILL PSOQUIT,POERR("QFLG")
+1 QUIT
S ; Process STAT priority
DO S^PSOORFI2
+1 QUIT
+2 ;
E ; Process EMERGENCY priority
DO E^PSOORFI2
+1 QUIT
+2 ;
R ; Process ROUTINE priority
DO R^PSOORFI2
+1 QUIT
+2 ;
LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Information
+1 NEW FLAG
+2 KILL FLAGLINE
SET ORD=+$GET(ORD)
IF 'ORD
QUIT
+3 ;
+4 IF '$GET(^PS(52.41,ORD,"FLG"))
QUIT
+5 ; S X=IORVON_"Flagged"_IORVOFF
+6 DO GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
+7 SET L1="Flagged by "_$EXTRACT(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
+8 SET LEN=80-$LENGTH(L1)
SET L1=L1_$EXTRACT(FLAG(52.41,ORD_",",35,"E"),1,LEN)
SET L2=$EXTRACT(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
+9 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L1
SET FLAGLINE(IEN)=7
+10 IF L2'=""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L2
+11 IF FLAG(52.41,ORD_",",36,"I")'=""
Begin DoDot:1
+12 SET L1="Unflagged by "_$EXTRACT(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
+13 SET LEN=80-$LENGTH(L1)
SET L1=L1_$EXTRACT(FLAG(52.41,ORD_",",38,"E"),1,LEN)
SET L2=$EXTRACT(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
+14 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L1
SET FLAGLINE(IEN)=9
+15 IF L2'=""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=L2
End DoDot:1
+16 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" "
+17 QUIT
+18 ;
CS ; Digitally Signed CS - PSO*7*391
+1 KILL DIR
+2 NEW PSOCSRT,PSOPARKX,RESULTS,Y
+3 SET DIR("A")="Route"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;B:BOTH;E:EXIT"
SET DIR("B")="BOTH"
+4 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+5 IF $GET(PSOPARKX(0))="YES"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;A:ALL;E:EXIT"
SET DIR("B")="ALL"
+6 DO ^DIR
+7 if $DATA(DIRUT)!(Y="E")
QUIT
+8 SET PSOCSRT=$SELECT(Y="A":1,Y="B":1,1:Y)
+9 WRITE !!,"Select a schedule(s)"
+10 KILL DIR
SET PSOSORT="DIGITALLY SIGNED"
+11 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
+12 DO ^DIR
if $DATA(DIRUT)!(Y="E")
GOTO EX
SET PSOSORT=PSOSORT_"^"_Y
SET PSRT=Y
+13 NEW SECSORT
SET SECSORT=$$DIR^PSOORFI6("CS:CONTROLLED SUBSTANCES",Y)
if SECSORT=U
QUIT
+14 NEW PDEA,OR0
SET LG=0
SET PATA=0
FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
if 'LG!($GET(POERR("QFLG")))
QUIT
FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
if 'PSOD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+15 if '$DATA(^PS(52.41,PSOD,0))
QUIT
+16 SET OR0=^PS(52.41,PSOD,0)
+17 ;PSO*7*505 - still quit if the order is flagged, but now only look for digital signature if the selection does not ask for non contolled substances
+18 IF $PIECE(OR0,"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+19 SET PDEA=0
DO PDEA
if 'PDEA!(PDEA'=PSRT)
QUIT
+20 ;PSO*7*505 moved digitally signed check after the DEA check (Disregards eRx Pending orders)
+21 IF PSRT<4
IF '$$ERXIEN^PSOERXUT(PSOD_"P")
IF '$PIECE(OR0,"^",24)
QUIT
+22 IF 'PSOCSRT
IF PSOCSRT'=$PIECE(OR0,"^",17)
QUIT
+23 if $GET(PAT($PIECE(OR0,"^",2)))=$PIECE(OR0,"^",2)
QUIT
SET PAT=$PIECE(OR0,"^",2)
+24 IF PAT'=PATA
KILL PSORX("DOSING OFF")
IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+25 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+26 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
SET PSOLK=1
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG,PSOQQ
QUIT
+27 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+28 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
QUIT
+29 if '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
QUIT
+30 DO SDFN
DO POST^PSOORFI1
IF $GET(PSOQFLG)!($GET(PSOQUIT))
if $GET(PSOQUIT)
SET POERR("QFLG")=1
if $GET(PSOQFLG)
SET PAT(PAT)=PAT
SET X=PAT
DO ULP
KILL PSOQFLG
QUIT
+31 SET PAT(PAT)=PAT
+32 FOR ORD=0:0
SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
if 'ORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
QUIT
Begin DoDot:2
+33 if '$DATA(^PS(52.41,ORD,0))
QUIT
+34 SET OR0=^PS(52.41,ORD,0)
+35 ;PSO*505 - Move the check for digitally signed, so non-cs substances will be shown if selected as sort criteria
+36 IF $PIECE(OR0,U,23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+37 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
QUIT
+38 IF 'PSOCSRT
IF PSOCSRT'=$PIECE(OR0,"^",17)
QUIT
+39 if $PIECE(OR0,"^",3)="DC"!($PIECE(OR0,"^",3)="DE")
QUIT
+40 SET PDEA=0
DO PDEA
if 'PDEA!(PDEA'=PSRT)
QUIT
+41 IF PSRT<4
IF '$$ERXIEN^PSOERXUT(ORD_"P")
IF '$PIECE(OR0,"^",24)
QUIT
+42 DO PP
DO LK1
DO ORD^PSOORFIN
End DoDot:2
+43 SET X=PAT
DO ULP
KILL PSOQQ
End DoDot:1
+44 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL^PSOORFIN
+45 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO ^PSOORFIN
+46 GOTO EX
+47 ;
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 ; PSO*7*505 - adding checks for new sort criteria
+4 ; PDEA=0 OR 2, covers non-cs and schedule 3-5
+5 IF (PDEA=0)!(PDEA=2)
IF PSRT=4
SET PDEA=4
QUIT
+6 IF PDEA=0
IF PSRT=5
SET PDEA=5
QUIT
+7 ; PSO*7*505 end
+8 IF PDEA
IF PSRT=3
SET PDEA=3
+9 QUIT
+10 ;
PRV(PROV,DRG,ORN) ;
+1 NEW DETN,DEA,I,LBL,VADD,SPC
+2 IF PROV=""
QUIT
+3 ;*545 - show DEA label only, get the stored DEA#
+4 if $LENGTH($GET(PSORX("RXDEA")))
SET DEA=PSORX("RXDEA")
+5 ;If renew, try to get DEA from the renewal from CPRS rather than the original RX, provider may have changed
+6 IF $GET(PSOORRNW)
IF $GET(ORN)
SET DEA=$$RXDEA^PSOUTIL(,ORN)
+7 IF '$LENGTH($GET(DEA))
SET DEA=$SELECT($GET(PSONEW("OIRXN")):$$RXDEA^PSOUTIL(PSONEW("OIRXN")),$GET(ORN):$$RXDEA^PSOUTIL(,ORN),1:$$DEA^XUSER(0,PROV))
if DEA]""
SET PSORX("RXDEA")=DEA
+8 if $LENGTH($GET(PSORX("DETX")))
SET DETN=PSORX("DETX")
+9 SET LBL="DEA#: "
IF $GET(ADDS)
SET LBL=" "_LBL
+10 IF DRG
IF $$DETOX^PSSOPKI(DRG)
IF '$LENGTH($GET(DETN))
SET DETN=$SELECT($GET(ORN):$$RXDETOX^PSOUTIL(,ORN),1:$$DETOX^XUSER(PROV))
+11 SET $PIECE(SPC," ",($SELECT($GET(ADDS):30,1:33)-$LENGTH(DEA)))=" "
+12 IF (DEA'="")!($GET(DETN)'="")
SET IEN=IEN+1
SET $EXTRACT(^TMP("PSOPO",$JOB,IEN,0),16)=LBL_DEA_$SELECT($GET(DETN)]"":SPC_"DETOX#: "_$GET(DETN),1:"")
+13 IF $GET(ORN)
DO PRVAD^PSOPKIV2
IF $GET(VADD(1))]""
Begin DoDot:1
+14 SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=$SELECT($GET(ADDS):" ",1:"")_" Site Address: "_VADD(1)
+15 if VADD(2)'=""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=$SELECT($GET(ADDS):" ",1:"")_" "_VADD(2)
if VADD(3)'=""
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=$SELECT($GET(ADDS):" ",1:"")_" "_VADD(3)
End DoDot:1
+16 QUIT
