PSOORFIN ;BIR/SAB - finish cprs orders ;Dec 01, 2022@12:07:21
;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,225,315,266,338,391,372,416,446,505,508,557,628,441,710,770**;DEC 1997;Build 145
;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
;PSO*7*266 Change order of calling ^PSOBING1 and ^PSORXL
;
N ORD
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX
D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
K PSOBCK,MEDA,MEDP,SRT,DIR D KQ
S PSOCLIN=0,(PSOFIN,POERR)=1,PSOSORT="ROUTE"
; Workload Processing Key assigned to User
I $D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)) D G EX:$G(PSOIQUIT) G ALLPATS
. N DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: "
. I +$$GET1^DIQ(59,PSOSITE,10,"I") S DIC("B")=$$GET1^DIQ(44,+$$GET1^DIQ(59,PSOSITE,10,"I"),.01)
. S DIC("S")="I $$CHECKCLN^PSOORUT3(+$G(Y))"
. D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) S PSOIQUIT=1 Q
. S PSOCLIN=+Y,PSOCLINF=1
;
S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT"
S DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAGGED;CS:CONTROLLED SUBSTANCES;SU:SUPPLY;E:EXIT"
D ^DIR I $D(DIRUT)!(Y="E") G EX
K:Y="FL" ^TMP($J,"PSOFLPO") ;file not needed when selection="FL"
G:Y="PA" PAT G:Y="PR" PRI^PSOORFI5 G:Y="CL" ^PSOORFI3 G:Y="FL" FLG^PSOORFI5 G:Y="CS" CS^PSOORFI5 G:Y="SU" SUP^PSOORFI5
K DIR S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
N RESULTS,PSOPARKX
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 G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
N SECSORT S SECSORT=$$DIR^PSOORFI6("RT:ROUTE",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
.K PSONEW I PAT'=PATA D LBL
.I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
.D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
.;PSO*7*505
.I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) 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
.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
K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI,PRK D LBL ;441 PAPI
I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
EX D EX^PSOORFI1
Q
W D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1
Q:$G(POERR("QFLG")) I $G(MAIL) S ORD=0 D
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
.Q:$G(POERR("QFLG"))
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
.Q:$G(POERR("QFLG")) ;441 PAPI
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"P",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
Q
M D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1
Q:$G(POERR("QFLG")) I $G(WIN) S ORD=0 D
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
.Q:$G(POERR("QFLG"))
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
.Q:$G(POERR("QFLG")) ;441 PAPI
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"P",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
Q
C D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1
Q:$G(POERR("QFLG")) I $G(CLI) S ORD=0 D
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
.Q:$G(POERR("QFLG"))
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
.Q:$G(POERR("QFLG")) ;441 PAPI
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"P",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
Q
;441 PAPI TAG
P D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"P",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S PRK=1
Q:$G(POERR("QFLG")) I $G(PRK) S ORD=0 D
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
.Q:$G(POERR("QFLG"))
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
.Q:$G(POERR("QFLG"))
.D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
Q
PAT W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ 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 I $D(DIRUT)!(Y="E") G EX
I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT
ALLPATS ; All Patient Processing
S PSOSORT=PSOSORT_"^ALL",(MEDA,MEDP)=1 K POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT"
N PAT,PATA,SECSORT,WPT,WPPAT,WPPATS,DIR,DUOUT,DIROUT,DTOUT,DIRUT,PSOQUIT,ERXIEN,EPATLCK,EPATIEN
I '$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)) S SECSORT=$$DIR^PSOORFI6("PA:PATIENT",Y) I SECSORT="^" Q
I $D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)) D I $G(PSOQUIT) G EX
. W ! K DIR S DIR("A")="Process FLAGGED orders only? ",DIR(0)="YA",DIR("B")="NO"
. D ^DIR I $G(DUOUT)!$G(DIROUT)!$G(DTOUT)!$G(DIRUT) S PSOQUIT=1
. S SECSORT=0 I $G(Y) S SECSORT="FL^FLAGGED^FLAGGED"
;Cleaning up Workload Processing Patient List and setting 'tagged' patient to user
S WPPAT=0,WPT=0 F S WPT=$O(^XTMP("PSOORWP",PSOCLIN,WPT)) Q:'WPT D
. I '$$HASACTPO^PSOORUT3(WPT) K ^XTMP("PSOORWP",PSOCLIN,WPT) Q
. I $D(^XTMP("PSOORWP",PSOCLIN,WPT,DUZ)),'$D(WPPAT(PSOCLIN)) S WPPAT(PSOCLIN)=WPT
S (LG,PATA)=0
F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG D I $G(POERR("QFLG")) Q
. F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD D I $G(POERR("QFLG")) Q
. . Q:'$D(^PS(52.41,PSOD,0))
. . I '$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)),$P($G(^PS(52.41,PSOD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
. . I " DE DC"[$$GET1^DIQ(52.41,PSOD,2,"I") Q
. . Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2))) ; Patient already marked to be skipped
. . I $D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)),$G(PSOCLIN)'=$$GET1^DIQ(52.41,PSOD,1.1,"I") Q
. . S PAT=+$P(^PS(52.41,PSOD,0),"^",2)
. . ; Patient assigned/tagged to another user
. . I SECSORT'="FL^FLAGGED^FLAGGED",$D(^XTMP("PSOORWP",PSOCLIN,PAT)),'$D(^XTMP("PSOORWP",PSOCLIN,PAT,DUZ)) S PAT(PAT)=PAT Q
. . I SECSORT'="FL^FLAGGED^FLAGGED",$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)),'$$HASACTPO^PSOORUT3(PAT) S PAT(PAT)=PAT Q
. . ; MbM only: Checking whether the eRx Patient is locked on the eRx Holding Queue, if so, skip record
. . S ERXIEN=$$ERXIEN^PSOERXUT(PSOD_"P")
. . I $$GET1^DIQ(59.7,1,102,"I")="MBM",ERXIEN D I $G(EPATLCK) S PAT(PAT)=PAT Q
. . . S EPATLCK=0,EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I") I 'EPATIEN Q
. . . I $$L^PSOERX1A(EPATIEN,1,1) D
. . . . D UL^PSOERX1A(EPATIEN)
. . . E I +$G(^XTMP("PSOERXLOCK",EPATIEN))'=DUZ S EPATLCK=1 I $G(WPPAT(+PSOCLIN))=PAT K WPPAT(+PSOCLIN)
. . ;Secondary sort filter
. . I SECSORT'=0,'$$CHKFLTR^PSOORFI6(PSOD,SECSORT) Q
. . ;Workload Processing - Patient assigned to another Rph | Forced 'tagged' patient on User
. . I SECSORT'="FL^FLAGGED^FLAGGED",$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)),$G(WPPAT(+PSOCLIN)),WPPAT(PSOCLIN)'=PAT Q
. . I SECSORT'="FL^FLAGGED^FLAGGED",$G(WPPAT(+PSOCLIN)) S PAT=$G(WPPAT(+PSOCLIN))
. . ;PSO*7*266
. . I PAT'=PATA D LBL
. . D LK I $G(POERR("QFLG")),$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)),+$G(WPPAT(+PSOCLIN))=PAT K POERR("QFLG")
. . I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
. . S PSONOLCK=0 I $G(PSOERR("QFLG")) K POERR("QFLG") S PSONOLCK=1
. . 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 Q
. . . I SECSORT'="FL^FLAGGED^FLAGGED",$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)) S ^XTMP("PSOORWP",PSOCLIN,PAT,DUZ)=""
. . . D SPL D OERR^PSORX1
. . . S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL
. . . ;Forcing the Workload Processing user to the beginning of the Queue
. . . I SECSORT'="FL^FLAGGED^FLAGGED",$D(^XUSEC("PSO ERX WORKLOAD RPH",DUZ)) D
. . . . I $$HASACTPO^PSOORUT3(PAT) S POERR("QFLG")=1 Q
. . . . K WPPAT(+PSOCLIN) S (LG,PSOD)=0 K ^XTMP("PSOORWP",PSOCLIN,PAT,DUZ)
. . 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),$P(SECSORT,"^",1)'="FL" Q
. . . D PP,LK1,ORD
. . S X=PAT D ULP K PSOQQ
I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
G EX
;PSO*7*266 kill BINGCRT,BINGRTE when selecting pat.
SPAT ; Single Patient Selection
I $G(PSOJUMP) Q
K MEDA,MEDP,PSOQFLG,PSORX("FN"),BINGCRT,BINGRTE D KQ,KV^PSOVER1
S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT
G:$D(DIRUT) EX D KV^PSOVER1
S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y
SPAT2 D LK I $G(POERR("QFLG")) G SPAT
N SNGLPAT S SNGLPAT=1
; PSO*7*505 - SECONDARY SORT
N SECSORT S SECSORT=$S($G(PSOJUMP):0,1:$$DIR^PSOORFI6("PA:PATIENT",PSODFN)) I SECSORT'=0,$P(SECSORT,U,1)="CS" N PSRT S PSRT=$P(SECSORT,U,3)
Q:SECSORT=U
; PSO*7*505 - END
;PSO*7*266
I $G(PSOJUMP) S MEDP=1
E D:'$G(MEDA) PROFILE^PSOORFI2
S Y=PSOFINY
I $G(MEDP) D SPL D OERR^PSORX1 D LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT
D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG) G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
.S X=PAT D ULP
S ORD=0 F S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG"))) D
.I $P($G(^PS(52.41,ORD,0)),"^",23),$P(SECSORT,"^",1)'="FL" Q
.;PSO*7*505 - SECONDARY SORT
.I SECSORT'=0,'$$CHKFLTR^PSOORFI6(ORD,SECSORT) Q
.;PSO*7*505 - END
.D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
;PSO*7*266
D LBL
S PSOFIN=1,X=PAT D ULP G SPAT
ORD ; Entry point for processing an individual Pending Order
N PSONEW,PSORENW
I $G(PSOBCK) N LST,ORN
E S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD
K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0))
I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q
D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q
I '$D(^PS(52.41,ORD,0)) K PSOMSG Q
;628 Add below line
I $P($G(^PS(52.41,ORD,0)),"^",3)="DC"!($P($G(^PS(52.41,ORD,0)),"^",3)="DE") W !!,"This Order had been Discontinued.",$C(7),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG,PSOFOERR S OR0=^PS(52.41,ORD,0),PSOTITRF=$G(^PS(52.41,ORD,"TIT"))
I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE,PKID S PKI=0 D CER^PSOPKIV1 I PKI<1 D UL1^PSOORFI3 K OR0 Q
S (PSOFOERR,PSOFDR)=1,OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16)
I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F S T=$O(^PS(52.41,ORD,2,T)) Q:'T S PHI(T)=^PS(52.41,ORD,2,T,0)
I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0))
I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F S T=$O(^PS(52.41,ORD,3,T)) Q:'T S PRC(T)=^PS(52.41,ORD,3,T,0)
I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D G SUCC ;process renews
.K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR
I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3
SUCC ;
D UL1^PSOORFI3,FULL^VALM1
D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF")
.K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^")))
S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSOTITRF
K PSORX("SC"),PSORX("CLINIC"),PSORX("PROVIDER NAME"),PSODRUG,PSOFOERR
Q
;PSO*7*266 change order of bingo checks.
LBL I $O(PSORX("PSOL",0))!($D(RXRS)) S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS
D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX,PSORX("DOSING OFF"),PSOONOFC
Q
CHK ;
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX
D INST1^PSOORFI2
S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI S PSZCNT=PSZCNT+1
S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ S TC=TC+1
W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
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 ; Unlocking Patient
N PATIEN
S PATIEN=+$G(X)
K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
D CLEAN^PSOVER1
D UL^PSSLOCK(PATIEN)
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
SQR ;
K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT,VALMSG S POERR("DFLG")=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORFIN 15168 printed Sep 23, 2025@20:08:30 Page 2
PSOORFIN ;BIR/SAB - finish cprs orders ;Dec 01, 2022@12:07:21
+1 ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,225,315,266,338,391,372,416,446,505,508,557,628,441,710,770**;DEC 1997;Build 145
+2 ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
+3 ;PSO*7*266 Change order of calling ^PSOBING1 and ^PSORXL
+4 ;
+5 NEW ORD
+6 if '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
DO MSG^PSODPT
GOTO EX
+7 DO INST^PSOORFI2
IF $GET(PSOIQUIT)
KILL PSOIQUIT
GOTO EX
+8 IF $PIECE($GET(PSOPAR),"^",2)
IF '$DATA(^XUSEC("PSORPH",DUZ))
SET PSORX("VERIFY")=1
+9 KILL PSOBCK,MEDA,MEDP,SRT,DIR
DO KQ
+10 SET PSOCLIN=0
SET (PSOFIN,POERR)=1
SET PSOSORT="ROUTE"
+11 ; Workload Processing Key assigned to User
+12 IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
Begin DoDot:1
+13 NEW DIC
SET DIC="^SC("
SET DIC(0)="QEAMZ"
SET DIC("A")="Select CLINIC: "
+14 IF +$$GET1^DIQ(59,PSOSITE,10,"I")
SET DIC("B")=$$GET1^DIQ(44,+$$GET1^DIQ(59,PSOSITE,10,"I"),.01)
+15 SET DIC("S")="I $$CHECKCLN^PSOORUT3(+$G(Y))"
+16 DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
SET PSOIQUIT=1
QUIT
+17 SET PSOCLIN=+Y
SET PSOCLINF=1
End DoDot:1
if $GET(PSOIQUIT)
GOTO EX
GOTO ALLPATS
+18 ;
+19 SET DIR("?")="^D ST^PSOORFI1"
SET DIR("A")="Select By"
SET DIR("B")="PATIENT"
+20 SET DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAGGED;CS:CONTROLLED SUBSTANCES;SU:SUPPLY;E:EXIT"
+21 DO ^DIR
IF $DATA(DIRUT)!(Y="E")
GOTO EX
+22 ;file not needed when selection="FL"
if Y="FL"
KILL ^TMP($JOB,"PSOFLPO")
+23 if Y="PA"
GOTO PAT
if Y="PR"
GOTO PRI^PSOORFI5
if Y="CL"
GOTO ^PSOORFI3
if Y="FL"
GOTO FLG^PSOORFI5
if Y="CS"
GOTO CS^PSOORFI5
if Y="SU"
GOTO SUP^PSOORFI5
+24 KILL DIR
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"
+25 NEW RESULTS,PSOPARKX
+26 SET RESULTS="PSOPARKX"
DO GETPARK^PSORPC01()
+27 IF $GET(PSOPARKX(0))="YES"
SET DIR(0)="SBM^W:WINDOW;M:MAIL;P:PARK;C:CLINIC;E:EXIT"
+28 DO ^DIR
if $DATA(DIRUT)!(Y="E")
GOTO EX
SET PSOSORT=PSOSORT_"^"_Y
SET PSRT=Y
+29 NEW SECSORT
SET SECSORT=$$DIR^PSOORFI6("RT:ROUTE",Y)
if SECSORT=U
QUIT
+30 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
+31 IF $PIECE($GET(^PS(52.41,PSOD,0)),"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+32 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)
+33 ;PSO*7*266
+34 KILL PSONEW
IF PAT'=PATA
DO LBL
+35 IF '$ORDER(^PS(52.41,"AC",PAT,PSRT,0))
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+36 DO RTE^PSOORFI2
IF $GET(PSZFIN)
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+37 ;PSO*7*505
+38 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
QUIT
+39 DO LK
IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+40 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
+41 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+42 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
+43 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
+44 DO PP
SET ORD=0
DO @PSRT
SET PAT(PAT)=PAT
+45 SET X=PAT
DO ULP
End DoDot:1
+46 ;PSO*7*266
+47 ;441 PAPI
KILL POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI,PRK
DO LBL
+48 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO PSOORFIN
EX DO EX^PSOORFI1
+1 QUIT
W DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
SET MAIL=1
+1 if $GET(POERR("QFLG"))
QUIT
IF $GET(MAIL)
SET ORD=0
Begin DoDot:1
+2 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
+5 ;441 PAPI
if $GET(POERR("QFLG"))
QUIT
+6 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"P",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
End DoDot:1
+7 QUIT
M DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
SET WIN=1
+1 if $GET(POERR("QFLG"))
QUIT
IF $GET(WIN)
SET ORD=0
Begin DoDot:1
+2 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
+5 ;441 PAPI
if $GET(POERR("QFLG"))
QUIT
+6 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"P",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
End DoDot:1
+7 QUIT
C DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
SET CLI=1
+1 if $GET(POERR("QFLG"))
QUIT
IF $GET(CLI)
SET ORD=0
Begin DoDot:1
+2 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
+5 ;441 PAPI
if $GET(POERR("QFLG"))
QUIT
+6 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"P",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
End DoDot:1
+7 QUIT
+8 ;441 PAPI TAG
P DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"P",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
SET PRK=1
+1 if $GET(POERR("QFLG"))
QUIT
IF $GET(PRK)
SET ORD=0
Begin DoDot:1
+2 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LK1
DO ORD
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
+5 if $GET(POERR("QFLG"))
QUIT
+6 DO KQ
FOR
SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
DO LK1
DO ORD
End DoDot:1
+7 QUIT
PAT WRITE !
KILL MEDP,MEDA,POERR("DFLG"),DIR
DO KQ
SET PSOSORT="PATIENT"
+1 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"
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y="E")
GOTO EX
+3 IF Y="S"
SET PSOSORT=PSOSORT_"^"_"SINGLE"
GOTO SPAT
ALLPATS ; All Patient Processing
+1 SET PSOSORT=PSOSORT_"^ALL"
SET (MEDA,MEDP)=1
KILL POERR("DFLG"),DIR
DO KQ
SET PSOSORT="PATIENT"
+2 NEW PAT,PATA,SECSORT,WPT,WPPAT,WPPATS,DIR,DUOUT,DIROUT,DTOUT,DIRUT,PSOQUIT,ERXIEN,EPATLCK,EPATIEN
+3 IF '$DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
SET SECSORT=$$DIR^PSOORFI6("PA:PATIENT",Y)
IF SECSORT="^"
QUIT
+4 IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
Begin DoDot:1
+5 WRITE !
KILL DIR
SET DIR("A")="Process FLAGGED orders only? "
SET DIR(0)="YA"
SET DIR("B")="NO"
+6 DO ^DIR
IF $GET(DUOUT)!$GET(DIROUT)!$GET(DTOUT)!$GET(DIRUT)
SET PSOQUIT=1
+7 SET SECSORT=0
IF $GET(Y)
SET SECSORT="FL^FLAGGED^FLAGGED"
End DoDot:1
IF $GET(PSOQUIT)
GOTO EX
+8 ;Cleaning up Workload Processing Patient List and setting 'tagged' patient to user
+9 SET WPPAT=0
SET WPT=0
FOR
SET WPT=$ORDER(^XTMP("PSOORWP",PSOCLIN,WPT))
if 'WPT
QUIT
Begin DoDot:1
+10 IF '$$HASACTPO^PSOORUT3(WPT)
KILL ^XTMP("PSOORWP",PSOCLIN,WPT)
QUIT
+11 IF $DATA(^XTMP("PSOORWP",PSOCLIN,WPT,DUZ))
IF '$DATA(WPPAT(PSOCLIN))
SET WPPAT(PSOCLIN)=WPT
End DoDot:1
+12 SET (LG,PATA)=0
+13 FOR
SET LG=$ORDER(^PS(52.41,"AD",LG))
if 'LG
QUIT
Begin DoDot:1
+14 FOR PSOD=0:0
SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
if 'PSOD
QUIT
Begin DoDot:2
+15 if '$DATA(^PS(52.41,PSOD,0))
QUIT
+16 IF '$DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
IF $PIECE($GET(^PS(52.41,PSOD,0)),"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+17 IF " DE DC"[$$GET1^DIQ(52.41,PSOD,2,"I")
QUIT
+18 ; Patient already marked to be skipped
if $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))
QUIT
+19 IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
IF $GET(PSOCLIN)'=$$GET1^DIQ(52.41,PSOD,1.1,"I")
QUIT
+20 SET PAT=+$PIECE(^PS(52.41,PSOD,0),"^",2)
+21 ; Patient assigned/tagged to another user
+22 IF SECSORT'="FL^FLAGGED^FLAGGED"
IF $DATA(^XTMP("PSOORWP",PSOCLIN,PAT))
IF '$DATA(^XTMP("PSOORWP",PSOCLIN,PAT,DUZ))
SET PAT(PAT)=PAT
QUIT
+23 IF SECSORT'="FL^FLAGGED^FLAGGED"
IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
IF '$$HASACTPO^PSOORUT3(PAT)
SET PAT(PAT)=PAT
QUIT
+24 ; MbM only: Checking whether the eRx Patient is locked on the eRx Holding Queue, if so, skip record
+25 SET ERXIEN=$$ERXIEN^PSOERXUT(PSOD_"P")
+26 IF $$GET1^DIQ(59.7,1,102,"I")="MBM"
IF ERXIEN
Begin DoDot:3
+27 SET EPATLCK=0
SET EPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
IF 'EPATIEN
QUIT
+28 IF $$L^PSOERX1A(EPATIEN,1,1)
Begin DoDot:4
+29 DO UL^PSOERX1A(EPATIEN)
End DoDot:4
+30 IF '$TEST
IF +$GET(^XTMP("PSOERXLOCK",EPATIEN))'=DUZ
SET EPATLCK=1
IF $GET(WPPAT(+PSOCLIN))=PAT
KILL WPPAT(+PSOCLIN)
End DoDot:3
IF $GET(EPATLCK)
SET PAT(PAT)=PAT
QUIT
+31 ;Secondary sort filter
+32 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(PSOD,SECSORT)
QUIT
+33 ;Workload Processing - Patient assigned to another Rph | Forced 'tagged' patient on User
+34 IF SECSORT'="FL^FLAGGED^FLAGGED"
IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
IF $GET(WPPAT(+PSOCLIN))
IF WPPAT(PSOCLIN)'=PAT
QUIT
+35 IF SECSORT'="FL^FLAGGED^FLAGGED"
IF $GET(WPPAT(+PSOCLIN))
SET PAT=$GET(WPPAT(+PSOCLIN))
+36 ;PSO*7*266
+37 IF PAT'=PATA
DO LBL
+38 DO LK
IF $GET(POERR("QFLG"))
IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
IF +$GET(WPPAT(+PSOCLIN))=PAT
KILL POERR("QFLG")
+39 IF $GET(POERR("QFLG"))
KILL POERR("QFLG")
SET PSOLK=1
SET PAT(PAT)=PAT
QUIT
+40 SET PSONOLCK=0
IF $GET(PSOERR("QFLG"))
KILL POERR("QFLG")
SET PSONOLCK=1
+41 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
+42 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
SET PATA=PAT
+43 if '$GET(MEDA)
DO PROFILE^PSOORFI2
SET Y=PSODFN
+44 IF $GET(MEDP)
Begin DoDot:3
+45 IF SECSORT'="FL^FLAGGED^FLAGGED"
IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
SET ^XTMP("PSOORWP",PSOCLIN,PAT,DUZ)=""
+46 DO SPL
DO OERR^PSORX1
+47 SET PSOFIN=1
DO QU
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
+48 ;Forcing the Workload Processing user to the beginning of the Queue
+49 IF SECSORT'="FL^FLAGGED^FLAGGED"
IF $DATA(^XUSEC("PSO ERX WORKLOAD RPH",DUZ))
Begin DoDot:4
+50 IF $$HASACTPO^PSOORUT3(PAT)
SET POERR("QFLG")=1
QUIT
+51 KILL WPPAT(+PSOCLIN)
SET (LG,PSOD)=0
KILL ^XTMP("PSOORWP",PSOCLIN,PAT,DUZ)
End DoDot:4
End DoDot:3
QUIT
+52 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
+53 SET PAT(PAT)=PAT
+54 FOR ORD=0:0
SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
if 'ORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
QUIT
Begin DoDot:3
+55 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
QUIT
+56 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+57 DO PP
DO LK1
DO ORD
End DoDot:3
+58 SET X=PAT
DO ULP
KILL PSOQQ
End DoDot:2
IF $GET(POERR("QFLG"))
QUIT
End DoDot:1
IF $GET(POERR("QFLG"))
QUIT
+59 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
DO LBL
+60 IF $GET(PSOQUIT)
KILL PSOQUIT
DO EX
GOTO PSOORFIN
+61 GOTO EX
+62 ;PSO*7*266 kill BINGCRT,BINGRTE when selecting pat.
SPAT ; Single Patient Selection
+1 IF $GET(PSOJUMP)
QUIT
+2 KILL MEDA,MEDP,PSOQFLG,PSORX("FN"),BINGCRT,BINGRTE
DO KQ
DO KV^PSOVER1
+3 SET DIR(0)="FO^2:30"
SET DIR("A")="Select Patient"
SET DIR("?")="^D HELP^PSOORFI2"
DO ^DIR
IF $EXTRACT(X)="?"
GOTO SPAT
+4 if $DATA(DIRUT)
GOTO EX
DO KV^PSOVER1
+5 SET DIC(0)="EQM"
SET DIC=2
SET DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
+6 DO ^DIC
KILL DIC
if "^"[X
GOTO EX
if Y=-1
GOTO SPAT
SET (PSODFN,PAT)=+Y
SET PSOFINY=Y
SPAT2 DO LK
IF $GET(POERR("QFLG"))
GOTO SPAT
+1 NEW SNGLPAT
SET SNGLPAT=1
+2 ; PSO*7*505 - SECONDARY SORT
+3 NEW SECSORT
SET SECSORT=$SELECT($GET(PSOJUMP):0,1:$$DIR^PSOORFI6("PA:PATIENT",PSODFN))
IF SECSORT'=0
IF $PIECE(SECSORT,U,1)="CS"
NEW PSRT
SET PSRT=$PIECE(SECSORT,U,3)
+4 if SECSORT=U
QUIT
+5 ; PSO*7*505 - END
+6 ;PSO*7*266
+7 IF $GET(PSOJUMP)
SET MEDP=1
+8 IF '$TEST
if '$GET(MEDA)
DO PROFILE^PSOORFI2
+9 SET Y=PSOFINY
+10 IF $GET(MEDP)
DO SPL
DO OERR^PSORX1
DO LBL
SET PSOFIN=1
SET X=PSOPTLOK
DO KLLP
DO ULP
DO KLL
GOTO SPAT
+11 DO PP
DO SDFN
DO POST^PSOORFI1
if $GET(PSOQFLG)
Begin DoDot:1
+12 SET X=PAT
DO ULP
End DoDot:1
if $GET(PSOQFLG)
GOTO EX
IF $GET(PSOQUIT)
if $GET(PSOQUIT)
SET POERR("QFLG")=1
SET X=PAT
DO ULP
GOTO SPAT
+13 SET ORD=0
FOR
SET ORD=$ORDER(^PS(52.41,"P",PAT,ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
Begin DoDot:1
+14 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
IF $PIECE(SECSORT,"^",1)'="FL"
QUIT
+15 ;PSO*7*505 - SECONDARY SORT
+16 IF SECSORT'=0
IF '$$CHKFLTR^PSOORFI6(ORD,SECSORT)
QUIT
+17 ;PSO*7*505 - END
+18 if $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")&($PIECE(^(0),"^",3)'="HD")
DO LK1
DO ORD
End DoDot:1
+19 ;PSO*7*266
+20 DO LBL
+21 SET PSOFIN=1
SET X=PAT
DO ULP
GOTO SPAT
ORD ; Entry point for processing an individual Pending Order
+1 NEW PSONEW,PSORENW
+2 IF $GET(PSOBCK)
NEW LST,ORN
+3 IF '$TEST
SET PSOLOUD=1
if $PIECE($GET(^PS(55,PAT,0)),"^",6)'=2
DO EN^PSOHLUP(PAT)
KILL PSOLOUD
+4 KILL DRET,SIG,^TMP("PSORXDC",$JOB)
if '$DATA(^PS(52.41,ORD,0))
QUIT
+5 IF $GET(PSOFIN)
IF $PIECE($GET(^PS(52.41,ORD,"INI")),"^")'=$GET(PSOPINST)
QUIT
+6 DO L1^PSOORFI3
IF '$GET(PSOMSG)
KILL PSOMSG
QUIT
+7 IF '$DATA(^PS(52.41,ORD,0))
KILL PSOMSG
QUIT
+8 ;628 Add below line
+9 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",3)="DC"!($PIECE($GET(^PS(52.41,ORD,0)),"^",3)="DE")
WRITE !!,"This Order had been Discontinued.",$CHAR(7),!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR
QUIT
+10 KILL DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG,PSOFOERR
SET OR0=^PS(52.41,ORD,0)
SET PSOTITRF=$GET(^PS(52.41,ORD,"TIT"))
+11 IF $PIECE(OR0,"^",24)
IF ($PIECE(OR0,"^",3)="RNW"!($PIECE(OR0,"^",3)="NW"))
NEW PKI,PKI1,PKIR,PKIE,PKID
SET PKI=0
DO CER^PSOPKIV1
IF PKI<1
DO UL1^PSOORFI3
KILL OR0
QUIT
+12 SET (PSOFOERR,PSOFDR)=1
SET OI=$PIECE(OR0,"^",8)
SET PSORX("SC")=$PIECE(OR0,"^",16)
+13 IF $ORDER(^PS(52.41,ORD,2,0))
SET PHI=^PS(52.41,ORD,2,0)
SET T=0
FOR
SET T=$ORDER(^PS(52.41,ORD,2,T))
if 'T
QUIT
SET PHI(T)=^PS(52.41,ORD,2,T,0)
+14 IF $PIECE($GET(^PS(52.41,ORD,"EXT")),"^")'=""
KILL PHI
IF $ORDER(^PS(52.41,ORD,"SIG",0))
SET PHI=$GET(^PS(52.41,ORD,"SIG",0))
SET T=0
FOR
SET T=$ORDER(^PS(52.41,ORD,"SIG",T))
if 'T
QUIT
SET PHI(T)=$GET(^PS(52.41,ORD,"SIG",T,0))
+15 IF $ORDER(^PS(52.41,ORD,3,0))
SET PRC=^PS(52.41,ORD,3,0)
SET T=0
FOR
SET T=$ORDER(^PS(52.41,ORD,3,T))
if 'T
QUIT
SET PRC(T)=^PS(52.41,ORD,3,T,0)
+16 ;process renews
IF $PIECE(OR0,"^",3)="RNW"
IF $DATA(^PSRX(+$PIECE(OR0,"^",21),0))
Begin DoDot:1
+17 KILL PSOREEDT
SET (PSOORRNW,PSOFDR)=1
SET PSORENW("OIRXN")=$PIECE(OR0,"^",21)
SET PSOOPT=3
SET (PSORENW("DFLG"),PSORENW("QFLG"))=0
DO ^PSOORRNW
DO SQR
End DoDot:1
GOTO SUCC
+18 IF $PIECE(OR0,"^",3)="RF"
IF $DATA(^PSRX(+$PIECE(OR0,"^",19),0))
DO RF^PSOORFI2
GOTO SUCC
+19 NEW PSODRUG,PSONEW
SET PSOFROM="PENDING"
if '$GET(PSOTPBFG)
DO DSPL^PSOTPCAN(ORD)
DO DSPL^PSOORFI1
DO SQN^PSOORFI3
SUCC ;
+1 DO UL1^PSOORFI3
DO FULL^VALM1
+2 if $PIECE($GET(^PS(52.41,+$GET(ORD),0)),"^",3)'="NW"&($PIECE($GET(^(0)),"^",3)'="RNW")&($PIECE($GET(^(0)),"^",3)'="HD")&($PIECE($GET(^(0)),"^",3)'="RF")
Begin DoDot:1
+3 KILL PSOSD("PENDING",$SELECT('$GET(OID):$PIECE(^PS(50.7,$PIECE(OR0,"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(OR0,"^",8),0),"^",2),0),"^"),1:$PIECE(^PSDRUG($PIECE(OR0,"^",9),0),"^")))
End DoDot:1
+4 if $GET(POERR("DFLG"))
SET POERR("QFLG")=1
KILL POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSOTITRF
+5 KILL PSORX("SC"),PSORX("CLINIC"),PSORX("PROVIDER NAME"),PSODRUG,PSOFOERR
+6 QUIT
+7 ;PSO*7*266 change order of bingo checks.
LBL IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
SET PSOFROM="NEW"
DO ^PSORXL
KILL PSORX("PSOL"),PPL,RXRS
+1 if $DATA(BINGCRT)&($DATA(BINGRTE)&($DATA(DISGROUP)))
DO ^PSOBING1
KILL BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX,PSORX("DOSING OFF"),PSOONOFC
+2 QUIT
CHK ;
+1 if '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE !,$CHAR(7),"Outpatient Division MUST be selected!",!
GOTO EX
+2 DO INST1^PSOORFI2
+3 SET PSZCNT=0
FOR PSZZI=0:0
SET PSZZI=$ORDER(^PS(59,PSZZI))
if 'PSZZI
QUIT
SET PSZCNT=PSZCNT+1
+4 SET TC=0
FOR TO=0:0
SET TO=$ORDER(^PS(52.41,"AOR",TO))
if 'TO
QUIT
FOR TZ=0:0
SET TZ=$ORDER(^PS(52.41,"AOR",TO,TZ))
if 'TZ
QUIT
FOR PSTZ=0:0
SET PSTZ=$ORDER(^PS(52.41,"AOR",TO,TZ,PSTZ))
if 'PSTZ
QUIT
SET TC=TC+1
+5 WRITE !!?10,$CHAR(7),"Orders to be completed"_$SELECT(PSZCNT=1:": ",1:" for all divisions: ")_TC,!
if 'TC
QUIT
+6 DO SUMM^PSOORNE1
KILL PSZZI,PSZCNT,PSTZ
+7 QUIT
+8 ;
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 ; Unlocking Patient
+1 NEW PATIEN
+2 SET PATIEN=+$GET(X)
+3 KILL PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
+4 DO CLEAN^PSOVER1
+5 DO UL^PSSLOCK(PATIEN)
+6 QUIT
KLL KILL PSOPTLOK
QUIT
KLLP KILL PSONOLCK
QUIT
SPL DO SPL^PSOORFI4
QUIT
SDFN SET PSODFN=+$GET(PSODFN)
QUIT
PP DO PP^PSOORFI4
QUIT
KQ KILL PSOQUIT,POERR("QFLG")
QUIT
SQR ;
+1 KILL PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT,VALMSG
SET POERR("DFLG")=0
+2 QUIT
