PSOORNE1 ;BIR/SAB - Display new orders from backdoor ;Jun 09, 2021@15:24:21
;;7.0;OUTPATIENT PHARMACY;**11,21,27,32,37,46,71,94,104,117,133,148,279,251,372,313,422,441,787**;DEC 1997;Build 3
;External reference to ^PS(55 is supported by DBIA 2228
EN(PSONEW) D DSPL^PSOORNE3,^PSOLMPO2
Q
EDT N FLD,FIELDLST K DIR,DUOUT,DIRUT S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:14" D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DTOUT S VALMBCK="" Q
EDTSEL S:'$G(COPY) PSOEDIT=1 S (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
I +Y S FIELDLST=Y D HLDHDR^PSOLMUTL D Q:$G(PSORX("DFLG"))!($G(PSORX("QFLG"))) S VALMBCK="R" G DSPL^PSOORNE3
.F FLD=1:1:$L(FIELDLST,",") Q:$P(FIELDLST,",",FLD)']"" D @(+$P(FIELDLST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
E S VALMBCK="" D FULL^VALM1
D RDSPL G DSPL^PSOORNE3
Q
ACP K VALMSG,DIR,PSORX("DFLG") D VER I $G(PSONEW2("QFLG"))!($G(PSORX("DFLG"))) S VALMBCK="Q" K PSONEW2 Q
N PSONOBCK S PSONOBCK=$S($G(PSOSIGFL):1,1:0)
D NOOR^PSONEW I $D(DIRUT) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q
D RXNCHK,RDSPL
I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q
D DISPLAY^PSONEW2
D ^PSONEWG I $G(PSOCPZ("DFLG")) S PSONEW("DFLG")=1 K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT,PSOCPZ("DFLG"),PSOANSQD Q
K PSOCPZ("DFLG")
K DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this correct" D ^DIR
I $D(DIRUT) S PSONEW("DFLG")=1 K PSOANSQ,PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT Q
I 'Y S VALMBCK="R" K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT D DSPL^PSOORNE3 Q
W "..." K PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT D DCORD^PSONEW2
I $G(NCPDPFLG) D NCPDP^PSOORED6
K:$G(COPY)!($G(PSOSIGFL)) PRC,PHI
S:'$G(PSOID) PSOID=DT S (PSORX("FN"),PSONEW("POE"))=1 D EN^PSON52(.PSONEW) ; Files entry in File 52
;
; - Possible Titration prescription
I $G(PSONEW("IRXN")) D MARK^PSOOTMRX(PSONEW("IRXN"),0)
;
I $G(PSOBEDT) D
.I '$D(^TMP("PSOBEDT",$J,PSODFN,0)) S ^TMP("PSOBEDT",$J,PSODFN,0)=PSORXED("IRXN") S:$G(PSONEW("MAIL/WINDOW"))["W" ^TMP("PSOBEDT",$J,PSODFN,1)=1 Q
.S ^TMP("PSOBEDT",$J,PSODFN,0)=^TMP("PSOBEDT",$J,PSODFN,0)_","_PSORXED("IRXN")
.I $G(PSONEW("MAIL/WINDOW"))["W" S ^TMP("PSOBEDT",$J,PSODFN,1)=1
D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
D ^PSOBUILD S VALMBCK="Q"
K PSONEW("# OF REFILLS"),PSONEW("DAYS SUPPLY"),SDA,SEG1,SSN1,STA,Z4,ZDA
Q:$G(COPY) S PSONEW("DFLG")=0
Q
VER I $G(PSOAC),$G(PSODRUG("NAME"))']"" D FULL^VALM1,2^PSOORNW1
I $G(PSODRUG("NAME"))']"" S VALMSG="A Dispense Drug Must be Chosen!" S PSONEW2("QFLG")=1 Q
I '$G(PSONEW("ENT")) W !,"Dosing Instruction Missing!!",! D I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q
.S PSOORRNW=1
.K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME")
.I $O(SIG(0)) F I=1:1 Q:$G(SIG(I))']"" W !,SIG(I)
.E I $G(^PSRX(PSONEW("OIRXN"),"SIG"))]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250)
.W ! D 5 K PSOORRNW I PSONEW("DFLG")=1 D M3 Q
.D 6 D:PSONEW("DFLG")=1 M3
D:$G(COPY) PROV^PSOUTIL(.PSORENW) I $G(PSONEW("DFLG"))=1 S PSONEW2("QFLG")=1 Q
N PSODOSD D FULL^VALM1,POST^PSODRG:'$G(PSOSIGFL)
I $G(POERR("DFLG"))=1 S (PSONEW("DFLG"),PSONEW2("QFLG"))=1 Q
I $G(PSODOSD) S (PSONEW("DFLG"),PSONEW2("QFLG"))=1 Q
D:'$G(PSORX("DFLG")) DOSCK^PSODOSUT("N") K PSONOOR I $G(PSORX("DFLG")) S VALMBCK="Q" Q
I +$G(PSEXDT) D
.D FULL^VALM1 S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT="Y",BINGRTE="W"
.D:+$G(PSEXDT)
..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"."
.S PSONEW2("QFLG")=1,VALMBCK="R" D PAUSE^VALM1
Q
1 I $G(PSOSIGFL)!$G(PSOMTFLG) D Q
. S PSOAC=1 D 2^PSOORNW1 D:'$G(PSORX("DFLG")) 10^PSOBKDED,MW K PSOAC Q:$G(PSORX("DFLG")) D RDSPL D DSPL^PSOORNE3
. I $G(PSOMTFLG),$G(PSORXED("DRUG IEN"))'=$G(PSODRUG("IEN")) D
. . I FIELDLST'["5," D 5 Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
. . I FIELDLST'["6," D 6 Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
. . I FIELDLST'["8," D 8 Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG")))
;
D 6^PSOBKDED,MW
D RDSPL G DSPL^PSOORNE3 Q
;
MW I PSONEW("MAIL/WINDOW")="P",$G(PSODRUG("DEA"))["D" D
.W !!,"This drug cannot be Parked! You must select a different routing!"
.D 12^PSOBKDED
Q
;
2 D 3^PSOBKDED Q
;
3 D 1^PSOBKDED Q
;
4 D 2^PSOBKDED Q
;
5 I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q
;PSO787 only go into 10^PSOBKDED if editing field 5
I FIELDLST["5," W !!,"Drug: "_PSODRUG("NAME") D 10^PSOBKDED Q
Q
;
6 ;D INS^PSOBKDED Q:$G(PSONEW("DFLG")) I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW) ;*422
N PSOINSCH,PSODELINS
S:'$D(PSOOEINS) PSOOEINS=$G(PSONEW("INS")) S:'$D(PSOOSINS) PSOOSINS=$G(PSONEW("SINS")) S:'$D(PSOOEIND) PSOOEIND=$G(PSONEW("IND")) S:'$D(PSOOINDF) PSOOEINDF=$G(PSONEW("INDF"))
I '$P($G(^PS(55,PSODFN,"LAN")),"^") D INS^PSOBKDED Q:$G(PSONEW("DFLG"))
I $P($G(^PS(55,PSODFN,"LAN")),"^") D
.N PSODONE S (PSODONE,PSODELINS)=0
.F D I PSODONE Q:$G(PSONEW("DFLG")) D SIND^PSODIR(.PSONEW) Q
..K PSONEW("DFLG")
..D INS^PSOBKDED
..I '$G(PSONEW("DFLG")),'PSODONE,'$G(PSODELINS) D SINS^PSODIR(.PSONEW)
..;POSS NOT NEEDED;I $G(PSONEW("DFLG")) S PSODONE=1,(PSONEW("SIG"),PSONEW("INS"))=$G(PSOOEINS),PSONEW("SINS")=$G(PSOOSINS) K PSONEW("SIG") D EN^PSOFSIG(.PSONEW,1) Q
..I $G(PSONEW("DFLG")) S (X,Y)=$G(PSONEW("INS")) D SIG^PSOHELP S (PSONEW("SIG",1),PSONEW("SIG"))=$E($G(INS1),2,9999999) K X,Y S PSODONE=1 Q
..S PSOINSCH=$$INSCHK^PSOHELP3(.PSONEW)
..I '$G(PSOINSCH) S PSODONE=1
;
K PSOOEINS,PSOOSINS,PSOOEIND,PSOOEINDF
Q
;
7 D 8^PSOBKDED Q
;
8 D 7^PSOBKDED Q
;
9 D 9^PSOBKDED Q
;
10 D 12^PSOBKDED Q
;
11 D 5^PSOBKDED Q
;
12 D 4^PSOBKDED Q
;
13 D 11^PSOBKDED Q
;
14 D 13^PSOBKDED Q
;
15 Q
;D 14^PSOBKDED Q
;
SUMM ;print break down of orders to be finished
K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),PAT,RT,DIR,DUOUT,DIRUT,PSZLQUIT
S DIR("A")="Do you want an Order Summary",DIR(0)="Y",DIR("B")="No"
D ^DIR K DIR I 'Y!($D(DIRUT)) K Y,X,DIRUT Q
K PSOINPRT,DIQ,^UTILITY("DIQ1",$J) I $G(PSOPINST) S DA=PSOPINST,DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRT=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
I $D(^PS(52.41,"ACL")) N PSOCLSUM D SUMMCL I $G(PSOCLSUM) K PSOINPRT Q
F PSI=0:0 S PSI=$O(^PS(52.41,"AOR",PSI)) Q:'PSI F PSID=0:0 S PSID=$O(^PS(52.41,"AOR",PSI,PSID)) Q:'PSID F PIN=0:0 S PIN=$O(^PS(52.41,"AOR",PSI,PSID,PIN)) Q:'PIN D
.I '$D(^TMP($J,"PSOCZT",PSID,"PAT")) F PZA="PAT","WIN","MAIL","CLIN","PARK" S ^TMP($J,"PSOCZT",PSID,PZA)=0 ;441 PAPI
.I '$D(^TMP($J,"PSODPAT",PSID,PSI)) S ^TMP($J,"PSODPAT",PSID,PSI)=1,^TMP($J,"PSOCZT",PSID,"PAT")=^TMP($J,"PSOCZT",PSID,"PAT")+1
.;441 PAPI
.S PZROUT=$P($G(^PS(52.41,PIN,0)),"^",17) I PZROUT'="" S ^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",PZROUT="P":"PARK",1:"WIN"))=^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",PZROUT="P":"PARK",1:"WIN"))+1
W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",!
F PSOINL=0:0 S PSOINL=$O(^TMP($J,"PSOCZT",PSOINL)) Q:'PSOINL!($G(PSZLQUIT)) D
.I ($Y+6)>IOSL K DIR S DIR(0)="E" D ^DIR K DIR D:$G(Y) I '$G(Y) S PSZLQUIT=1 W ! Q
..W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",!
.K ^UTILITY("DIQ1",$J),DIQ,PSOINPRX S DA=$G(PSOINL),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRX=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
.;PSO*7*279 Change division to Institution
.W !,"Institution: ",$G(PSOINPRX)
.W !,"Patients: "_$G(^TMP($J,"PSOCZT",PSOINL,"PAT"))_" Window: "_$G(^("WIN"))_" Mail: "_$G(^("MAIL"))_" Clinic: "_$G(^("CLIN"))_" Park: "_$G(^("PARK")),! ;441 PAPI
K DIR S DIR(0)="E",(DIR("A"),DIR("?"))="Press Return to Continue" D ^DIR K DIR
K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),RT,PSOINPRT,PSOINPRX,PSI,PSID,PIN,PZA,PZROUT,PSOINL,PSZLQUIT
Q
SUMMCL ;
;PSO*7*279 Change Division to Institution
W ! K DIR S DIR(0)="SMB^I:INSTITUTION;C:CLINIC",DIR("A")="Do you want the summary by Institution or Clinic",DIR("B")="Institution",DIR("?")=" "
S DIR("?",1)="Enter 'I' to see the summary by Institution, and within Institution the orders",DIR("?",2)="shown by Mail, Window, or Administered in Clinic.",DIR("?",3)="Enter 'C' to see the summary by Clinic, along with Clinic Sort Groups."
D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSOCLSUM=1 Q
Q:$G(Y)="I"
S PSOCLSUM=1
K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") N PSCX,PSCXL,PSLX,PSCIN,PSCPT,PSCNDE,PSNCL,PSNPAT,PSCLOUT,PSCSFLAG,PCCNT,PSOCAG
F PSCX=0:0 S PSCX=$O(^PS(52.41,"ACL",PSCX)) Q:'PSCX F PSLX=0:0 S PSLX=$O(^PS(52.41,"ACL",PSCX,PSLX)) Q:'PSLX F PSCIN=0:0 S PSCIN=$O(^PS(52.41,"ACL",PSCX,PSLX,PSCIN)) Q:'PSCIN S PSCPT=+$P($G(^PS(52.41,PSCIN,0)),"^",2) D:PSCPT
.S PSCNDE=$G(^PS(52.41,PSCIN,0))
.I $P(PSCNDE,"^",3)'="NW",$P(PSCNDE,"^",3)'="RNW",$P(PSCNDE,"^",3)'="RF" Q
.I $P(PSCNDE,"^",13)="" Q
.S PSNCL=+$P(PSCNDE,"^",13),PSNPAT=+$P(PSCNDE,"^",2)
.I '$D(^TMP($J,"PSOLOC",PSNCL)) S ^TMP($J,"PSOLOC",PSNCL)="1^1",^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" Q
.S $P(^TMP($J,"PSOLOC",PSNCL),"^",2)=$P(^TMP($J,"PSOLOC",PSNCL),"^",2)+1
.I '$D(^TMP($J,"PSOLOCP",PSNCL,PSNPAT)) S $P(^TMP($J,"PSOLOC",PSNCL),"^")=$P(^TMP($J,"PSOLOC",PSNCL),"^")+1
.S ^TMP($J,"PSOLOCP",PSNCL,PSNPAT)=""
I '$O(^TMP($J,"PSOLOC",0)) G SUMMQ
W @IOF W !?20,"Pending Outpatient Medication Orders" I $G(PSZCNT)>1 W !?20,"(signed in under "_$G(PSOINPRT)_")"
F PSCXL=0:0 S PSCXL=$O(^TMP($J,"PSOLOC",PSCXL)) Q:'PSCXL!($G(PSCLOUT)) D
.I ($Y+7)>IOSL D CLDIR Q:$G(PSCLOUT)
.W !!,"Clinic: ",$P($G(^SC(+PSCXL,0)),"^")
.W !,"Patients: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^"),?16,"Orders: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^",2)
.W !,"In Sort Groups:"
.S (PCCNT,PSCSFLAG)=0 F PSCSORT=0:0 S PSCSORT=$O(^PS(59.8,PSCSORT)) Q:'PSCSORT!($G(PSCLOUT)) I $D(^PS(59.8,PSCSORT,1,"B",PSCXL)) S PSOCAG=0 D
..S PSCSFLAG=1 S:($Y+5)>IOSL&(PCCNT) PSOCAG=1 D:($Y+5)>IOSL&(PCCNT) CLDIR Q:$G(PSCLOUT) W:$G(PSOCAG) !,"Clinic: "_$P($G(^SC(PSCXL,0)),"^")_" cont." W:$G(PCCNT)>0 ! W ?16,$P($G(^PS(59.8,PSCSORT,0)),"^") S PCCNT=1
.I '$G(PSCSFLAG) W ?16,"*** NO CLINIC SORT GROUPS ***"
I '$G(PSCLOUT) K DIR S DIR(0)="E",(DIR("A"),DIR("?"))="Press Return to continue" D ^DIR K DIR
SUMMQ K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP")
Q
CLDIR K DIR S DIR(0)="E",(DIR("A"),DIR("?"))="Press Return to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSCLOUT=1 Q
W @IOF
Q
RXNCHK I $G(PSONEW("RX #"))']"" D RXNCHK^PSOORNE5
Q
RDSPL D RDSPL^PSOORNE5
Q
M3 D M3^PSOOREDX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORNE1 10710 printed Sep 23, 2025@20:08:32 Page 2
PSOORNE1 ;BIR/SAB - Display new orders from backdoor ;Jun 09, 2021@15:24:21
+1 ;;7.0;OUTPATIENT PHARMACY;**11,21,27,32,37,46,71,94,104,117,133,148,279,251,372,313,422,441,787**;DEC 1997;Build 3
+2 ;External reference to ^PS(55 is supported by DBIA 2228
EN(PSONEW) DO DSPL^PSOORNE3
DO ^PSOLMPO2
+1 QUIT
EDT NEW FLD,FIELDLST
KILL DIR,DUOUT,DIRUT
SET DIR("A")="Select Field to Edit by number"
SET DIR(0)="LO^1:14"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DTOUT
SET VALMBCK=""
QUIT
EDTSEL if '$GET(COPY)
SET PSOEDIT=1
SET (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0
+1 IF +Y
SET FIELDLST=Y
DO HLDHDR^PSOLMUTL
Begin DoDot:1
+2 FOR FLD=1:1:$LENGTH(FIELDLST,",")
if $PIECE(FIELDLST,",",FLD)']""
QUIT
DO @(+$PIECE(FIELDLST,",",FLD))
if $GET(PSODIR("DFLG"))!($GET(PSODIR("QFLG")))
QUIT
End DoDot:1
if $GET(PSORX("DFLG"))!($GET(PSORX("QFLG")))
QUIT
SET VALMBCK="R"
GOTO DSPL^PSOORNE3
+3 IF '$TEST
SET VALMBCK=""
DO FULL^VALM1
+4 DO RDSPL
GOTO DSPL^PSOORNE3
+5 QUIT
ACP KILL VALMSG,DIR,PSORX("DFLG")
DO VER
IF $GET(PSONEW2("QFLG"))!($GET(PSORX("DFLG")))
SET VALMBCK="Q"
KILL PSONEW2
QUIT
+1 NEW PSONOBCK
SET PSONOBCK=$SELECT($GET(PSOSIGFL):1,1:0)
+2 DO NOOR^PSONEW
IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
KILL DIR,X,Y,DIRUT,DUOUT,DTOUT
QUIT
+3 DO RXNCHK
DO RDSPL
+4 IF $GET(PSONEW("QFLG"))
SET PSONEW("DFLG")=1
KILL DIR,X,Y,DIRUT,DUOUT,DTOUT
QUIT
+5 DO DISPLAY^PSONEW2
+6 DO ^PSONEWG
IF $GET(PSOCPZ("DFLG"))
SET PSONEW("DFLG")=1
KILL PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT,PSOCPZ("DFLG"),PSOANSQD
QUIT
+7 KILL PSOCPZ("DFLG")
+8 KILL DIR,DIRUT,X,Y
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this correct"
DO ^DIR
+9 IF $DATA(DIRUT)
SET PSONEW("DFLG")=1
KILL PSOANSQ,PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT
QUIT
+10 IF 'Y
SET VALMBCK="R"
KILL PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT
DO DSPL^PSOORNE3
QUIT
+11 WRITE "..."
KILL PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT
DO DCORD^PSONEW2
+12 IF $GET(NCPDPFLG)
DO NCPDP^PSOORED6
+13 if $GET(COPY)!($GET(PSOSIGFL))
KILL PRC,PHI
+14 ; Files entry in File 52
if '$GET(PSOID)
SET PSOID=DT
SET (PSORX("FN"),PSONEW("POE"))=1
DO EN^PSON52(.PSONEW)
+15 ;
+16 ; - Possible Titration prescription
+17 IF $GET(PSONEW("IRXN"))
DO MARK^PSOOTMRX(PSONEW("IRXN"),0)
+18 ;
+19 IF $GET(PSOBEDT)
Begin DoDot:1
+20 IF '$DATA(^TMP("PSOBEDT",$JOB,PSODFN,0))
SET ^TMP("PSOBEDT",$JOB,PSODFN,0)=PSORXED("IRXN")
if $GET(PSONEW("MAIL/WINDOW"))["W"
SET ^TMP("PSOBEDT",$JOB,PSODFN,1)=1
QUIT
+21 SET ^TMP("PSOBEDT",$JOB,PSODFN,0)=^TMP("PSOBEDT",$JOB,PSODFN,0)_","_PSORXED("IRXN")
+22 IF $GET(PSONEW("MAIL/WINDOW"))["W"
SET ^TMP("PSOBEDT",$JOB,PSODFN,1)=1
End DoDot:1
+23 ; Adds newly added rx to PSOSD array
DO NPSOSD^PSOUTIL(.PSONEW)
+24 DO ^PSOBUILD
SET VALMBCK="Q"
+25 KILL PSONEW("# OF REFILLS"),PSONEW("DAYS SUPPLY"),SDA,SEG1,SSN1,STA,Z4,ZDA
+26 if $GET(COPY)
QUIT
SET PSONEW("DFLG")=0
+27 QUIT
VER IF $GET(PSOAC)
IF $GET(PSODRUG("NAME"))']""
DO FULL^VALM1
DO 2^PSOORNW1
+1 IF $GET(PSODRUG("NAME"))']""
SET VALMSG="A Dispense Drug Must be Chosen!"
SET PSONEW2("QFLG")=1
QUIT
+2 IF '$GET(PSONEW("ENT"))
WRITE !,"Dosing Instruction Missing!!",!
Begin DoDot:1
+3 SET PSOORRNW=1
+4 KILL VALMSG
DO FULL^VALM1
WRITE !,"Drug: "_PSODRUG("NAME")
+5 IF $ORDER(SIG(0))
FOR I=1:1
if $GET(SIG(I))']""
QUIT
WRITE !,SIG(I)
+6 IF '$TEST
IF $GET(^PSRX(PSONEW("OIRXN"),"SIG"))]""
SET X=$PIECE(^PSRX(PSONEW("OIRXN"),"SIG"),"^")
DO SIGONE^PSOHELP
WRITE !,$EXTRACT($GET(INS1),2,250)
+7 WRITE !
DO 5
KILL PSOORRNW
IF PSONEW("DFLG")=1
DO M3
QUIT
+8 DO 6
if PSONEW("DFLG")=1
DO M3
End DoDot:1
IF PSONEW("DFLG")=1
SET PSONEW2("QFLG")=1
QUIT
+9 if $GET(COPY)
DO PROV^PSOUTIL(.PSORENW)
IF $GET(PSONEW("DFLG"))=1
SET PSONEW2("QFLG")=1
QUIT
+10 NEW PSODOSD
DO FULL^VALM1
if '$GET(PSOSIGFL)
DO POST^PSODRG
+11 IF $GET(POERR("DFLG"))=1
SET (PSONEW("DFLG"),PSONEW2("QFLG"))=1
QUIT
+12 IF $GET(PSODOSD)
SET (PSONEW("DFLG"),PSONEW2("QFLG"))=1
QUIT
+13 if '$GET(PSORX("DFLG"))
DO DOSCK^PSODOSUT("N")
KILL PSONOOR
IF $GET(PSORX("DFLG"))
SET VALMBCK="Q"
QUIT
+14 IF +$GET(PSEXDT)
Begin DoDot:1
+15 DO FULL^VALM1
if $GET(PSONEW("MAIL/WINDOW"))["W"
SET BINGCRT="Y"
SET BINGRTE="W"
+16 if +$GET(PSEXDT)
Begin DoDot:2
+17 SET Y=PSONEW("FILL DATE")
XECUTE ^DD("DD")
WRITE !!,$CHAR(7),Y_" fill date is greater than possible expiration date of "
SET Y=$PIECE(PSEXDT,"^",2)
XECUTE ^DD("DD")
WRITE Y_"."
End DoDot:2
+18 SET PSONEW2("QFLG")=1
SET VALMBCK="R"
DO PAUSE^VALM1
End DoDot:1
+19 QUIT
1 IF $GET(PSOSIGFL)!$GET(PSOMTFLG)
Begin DoDot:1
+1 SET PSOAC=1
DO 2^PSOORNW1
if '$GET(PSORX("DFLG"))
DO 10^PSOBKDED
DO MW
KILL PSOAC
if $GET(PSORX("DFLG"))
QUIT
DO RDSPL
DO DSPL^PSOORNE3
+2 IF $GET(PSOMTFLG)
IF $GET(PSORXED("DRUG IEN"))'=$GET(PSODRUG("IEN"))
Begin DoDot:2
+3 IF FIELDLST'["5,"
DO 5
if $GET(PSODIR("DFLG"))!($GET(PSODIR("QFLG")))
QUIT
+4 IF FIELDLST'["6,"
DO 6
if $GET(PSODIR("DFLG"))!($GET(PSODIR("QFLG")))
QUIT
+5 IF FIELDLST'["8,"
DO 8
if $GET(PSODIR("DFLG"))!($GET(PSODIR("QFLG")))
QUIT
End DoDot:2
End DoDot:1
QUIT
+6 ;
+7 DO 6^PSOBKDED
DO MW
+8 DO RDSPL
GOTO DSPL^PSOORNE3
QUIT
+9 ;
MW IF PSONEW("MAIL/WINDOW")="P"
IF $GET(PSODRUG("DEA"))["D"
Begin DoDot:1
+1 WRITE !!,"This drug cannot be Parked! You must select a different routing!"
+2 DO 12^PSOBKDED
End DoDot:1
+3 QUIT
+4 ;
2 DO 3^PSOBKDED
QUIT
+1 ;
3 DO 1^PSOBKDED
QUIT
+1 ;
4 DO 2^PSOBKDED
QUIT
+1 ;
5 IF '$GET(PSODRUG("IEN"))
WRITE !,"DRUG NAME REQUIRED!"
DO 2^PSOORNW1
IF '$GET(PSODRUG("IEN"))
SET VALMSG="No Dispense Drug Selected"
QUIT
+1 ;PSO787 only go into 10^PSOBKDED if editing field 5
+2 IF FIELDLST["5,"
WRITE !!,"Drug: "_PSODRUG("NAME")
DO 10^PSOBKDED
QUIT
+3 QUIT
+4 ;
6 ;D INS^PSOBKDED Q:$G(PSONEW("DFLG")) I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW) ;*422
+1 NEW PSOINSCH,PSODELINS
+2 if '$DATA(PSOOEINS)
SET PSOOEINS=$GET(PSONEW("INS"))
if '$DATA(PSOOSINS)
SET PSOOSINS=$GET(PSONEW("SINS"))
if '$DATA(PSOOEIND)
SET PSOOEIND=$GET(PSONEW("IND"))
if '$DATA(PSOOINDF)
SET PSOOEINDF=$GET(PSONEW("INDF"))
+3 IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
DO INS^PSOBKDED
if $GET(PSONEW("DFLG"))
QUIT
+4 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
Begin DoDot:1
+5 NEW PSODONE
SET (PSODONE,PSODELINS)=0
+6 FOR
Begin DoDot:2
+7 KILL PSONEW("DFLG")
+8 DO INS^PSOBKDED
+9 IF '$GET(PSONEW("DFLG"))
IF 'PSODONE
IF '$GET(PSODELINS)
DO SINS^PSODIR(.PSONEW)
+10 ;POSS NOT NEEDED;I $G(PSONEW("DFLG")) S PSODONE=1,(PSONEW("SIG"),PSONEW("INS"))=$G(PSOOEINS),PSONEW("SINS")=$G(PSOOSINS) K PSONEW("SIG") D EN^PSOFSIG(.PSONEW,1) Q
+11 IF $GET(PSONEW("DFLG"))
SET (X,Y)=$GET(PSONEW("INS"))
DO SIG^PSOHELP
SET (PSONEW("SIG",1),PSONEW("SIG"))=$EXTRACT($GET(INS1),2,9999999)
KILL X,Y
SET PSODONE=1
QUIT
+12 SET PSOINSCH=$$INSCHK^PSOHELP3(.PSONEW)
+13 IF '$GET(PSOINSCH)
SET PSODONE=1
End DoDot:2
IF PSODONE
if $GET(PSONEW("DFLG"))
QUIT
DO SIND^PSODIR(.PSONEW)
QUIT
End DoDot:1
+14 ;
+15 KILL PSOOEINS,PSOOSINS,PSOOEIND,PSOOEINDF
+16 QUIT
+17 ;
7 DO 8^PSOBKDED
QUIT
+1 ;
8 DO 7^PSOBKDED
QUIT
+1 ;
9 DO 9^PSOBKDED
QUIT
+1 ;
10 DO 12^PSOBKDED
QUIT
+1 ;
11 DO 5^PSOBKDED
QUIT
+1 ;
12 DO 4^PSOBKDED
QUIT
+1 ;
13 DO 11^PSOBKDED
QUIT
+1 ;
14 DO 13^PSOBKDED
QUIT
+1 ;
15 QUIT
+1 ;D 14^PSOBKDED Q
+2 ;
SUMM ;print break down of orders to be finished
+1 KILL ^TMP($JOB,"PSOCZT"),^TMP($JOB,"PSODPAT"),PAT,RT,DIR,DUOUT,DIRUT,PSZLQUIT
+2 SET DIR("A")="Do you want an Order Summary"
SET DIR(0)="Y"
SET DIR("B")="No"
+3 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))
KILL Y,X,DIRUT
QUIT
+4 KILL PSOINPRT,DIQ,^UTILITY("DIQ1",$JOB)
IF $GET(PSOPINST)
SET DA=PSOPINST
SET DIC=4
SET DIQ(0)="E"
SET DR=".01"
DO EN^DIQ1
SET PSOINPRT=$GET(^UTILITY("DIQ1",$JOB,4,DA,.01,"E"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC,DIQ
+5 IF $DATA(^PS(52.41,"ACL"))
NEW PSOCLSUM
DO SUMMCL
IF $GET(PSOCLSUM)
KILL PSOINPRT
QUIT
+6 FOR PSI=0:0
SET PSI=$ORDER(^PS(52.41,"AOR",PSI))
if 'PSI
QUIT
FOR PSID=0:0
SET PSID=$ORDER(^PS(52.41,"AOR",PSI,PSID))
if 'PSID
QUIT
FOR PIN=0:0
SET PIN=$ORDER(^PS(52.41,"AOR",PSI,PSID,PIN))
if 'PIN
QUIT
Begin DoDot:1
+7 ;441 PAPI
IF '$DATA(^TMP($JOB,"PSOCZT",PSID,"PAT"))
FOR PZA="PAT","WIN","MAIL","CLIN","PARK"
SET ^TMP($JOB,"PSOCZT",PSID,PZA)=0
+8 IF '$DATA(^TMP($JOB,"PSODPAT",PSID,PSI))
SET ^TMP($JOB,"PSODPAT",PSID,PSI)=1
SET ^TMP($JOB,"PSOCZT",PSID,"PAT")=^TMP($JOB,"PSOCZT",PSID,"PAT")+1
+9 ;441 PAPI
+10 SET PZROUT=$PIECE($GET(^PS(52.41,PIN,0)),"^",17)
IF PZROUT'=""
SET ^TMP($JOB,"PSOCZT",PSID,$SELECT(PZROUT="C":"CLIN",PZROUT="M":"MAIL",PZROUT="P":"PARK",1:"WIN"))=^TMP($JOB,"PSOCZT",PSID,$SELECT(PZROUT="C":"CLIN",PZROUT="M":"MAIL",PZROUT="P":"PARK",1:"WIN"))+1
End DoDot:1
+11 WRITE @IOF
WRITE !?20,"Pending Outpatient Medication Orders",!
IF $GET(PSZCNT)>1
WRITE ?20,"(signed in under "_$GET(PSOINPRT)_")",!
+12 FOR PSOINL=0:0
SET PSOINL=$ORDER(^TMP($JOB,"PSOCZT",PSOINL))
if 'PSOINL!($GET(PSZLQUIT))
QUIT
Begin DoDot:1
+13 IF ($Y+6)>IOSL
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $GET(Y)
Begin DoDot:2
+14 WRITE @IOF
WRITE !?20,"Pending Outpatient Medication Orders",!
IF $GET(PSZCNT)>1
WRITE ?20,"(signed in under "_$GET(PSOINPRT)_")",!
End DoDot:2
IF '$GET(Y)
SET PSZLQUIT=1
WRITE !
QUIT
+15 KILL ^UTILITY("DIQ1",$JOB),DIQ,PSOINPRX
SET DA=$GET(PSOINL)
SET DIC=4
SET DIQ(0)="E"
SET DR=".01"
DO EN^DIQ1
SET PSOINPRX=$GET(^UTILITY("DIQ1",$JOB,4,DA,.01,"E"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC,DIQ
+16 ;PSO*7*279 Change division to Institution
+17 WRITE !,"Institution: ",$GET(PSOINPRX)
+18 ;441 PAPI
WRITE !,"Patients: "_$GET(^TMP($JOB,"PSOCZT",PSOINL,"PAT"))_" Window: "_$GET(^("WIN"))_" Mail: "_$GET(^("MAIL"))_" Clinic: "_$GET(^("CLIN"))_" Park: "_$GET(^("PARK")),!
End DoDot:1
+19 KILL DIR
SET DIR(0)="E"
SET (DIR("A"),DIR("?"))="Press Return to Continue"
DO ^DIR
KILL DIR
+20 KILL ^TMP($JOB,"PSOCZT"),^TMP($JOB,"PSODPAT"),RT,PSOINPRT,PSOINPRX,PSI,PSID,PIN,PZA,PZROUT,PSOINL,PSZLQUIT
+21 QUIT
SUMMCL ;
+1 ;PSO*7*279 Change Division to Institution
+2 WRITE !
KILL DIR
SET DIR(0)="SMB^I:INSTITUTION;C:CLINIC"
SET DIR("A")="Do you want the summary by Institution or Clinic"
SET DIR("B")="Institution"
SET DIR("?")=" "
+3 SET DIR("?",1)="Enter 'I' to see the summary by Institution, and within Institution the orders"
SET DIR("?",2)="shown by Mail, Window, or Administered in Clinic."
SET DIR("?",3)="Enter 'C' to see the summary by Clinic, along with Clinic Sort Groups."
+4 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSOCLSUM=1
QUIT
+5 if $GET(Y)="I"
QUIT
+6 SET PSOCLSUM=1
+7 KILL ^TMP($JOB,"PSOLOC"),^TMP($JOB,"PSOLOCP")
NEW PSCX,PSCXL,PSLX,PSCIN,PSCPT,PSCNDE,PSNCL,PSNPAT,PSCLOUT,PSCSFLAG,PCCNT,PSOCAG
+8 FOR PSCX=0:0
SET PSCX=$ORDER(^PS(52.41,"ACL",PSCX))
if 'PSCX
QUIT
FOR PSLX=0:0
SET PSLX=$ORDER(^PS(52.41,"ACL",PSCX,PSLX))
if 'PSLX
QUIT
FOR PSCIN=0:0
SET PSCIN=$ORDER(^PS(52.41,"ACL",PSCX,PSLX,PSCIN))
if 'PSCIN
QUIT
SET PSCPT=+$PIECE($GET(^PS(52.41,PSCIN,0)),"^",2)
if PSCPT
Begin DoDot:1
+9 SET PSCNDE=$GET(^PS(52.41,PSCIN,0))
+10 IF $PIECE(PSCNDE,"^",3)'="NW"
IF $PIECE(PSCNDE,"^",3)'="RNW"
IF $PIECE(PSCNDE,"^",3)'="RF"
QUIT
+11 IF $PIECE(PSCNDE,"^",13)=""
QUIT
+12 SET PSNCL=+$PIECE(PSCNDE,"^",13)
SET PSNPAT=+$PIECE(PSCNDE,"^",2)
+13 IF '$DATA(^TMP($JOB,"PSOLOC",PSNCL))
SET ^TMP($JOB,"PSOLOC",PSNCL)="1^1"
SET ^TMP($JOB,"PSOLOCP",PSNCL,PSNPAT)=""
QUIT
+14 SET $PIECE(^TMP($JOB,"PSOLOC",PSNCL),"^",2)=$PIECE(^TMP($JOB,"PSOLOC",PSNCL),"^",2)+1
+15 IF '$DATA(^TMP($JOB,"PSOLOCP",PSNCL,PSNPAT))
SET $PIECE(^TMP($JOB,"PSOLOC",PSNCL),"^")=$PIECE(^TMP($JOB,"PSOLOC",PSNCL),"^")+1
+16 SET ^TMP($JOB,"PSOLOCP",PSNCL,PSNPAT)=""
End DoDot:1
+17 IF '$ORDER(^TMP($JOB,"PSOLOC",0))
GOTO SUMMQ
+18 WRITE @IOF
WRITE !?20,"Pending Outpatient Medication Orders"
IF $GET(PSZCNT)>1
WRITE !?20,"(signed in under "_$GET(PSOINPRT)_")"
+19 FOR PSCXL=0:0
SET PSCXL=$ORDER(^TMP($JOB,"PSOLOC",PSCXL))
if 'PSCXL!($GET(PSCLOUT))
QUIT
Begin DoDot:1
+20 IF ($Y+7)>IOSL
DO CLDIR
if $GET(PSCLOUT)
QUIT
+21 WRITE !!,"Clinic: ",$PIECE($GET(^SC(+PSCXL,0)),"^")
+22 WRITE !,"Patients: ",$PIECE($GET(^TMP($JOB,"PSOLOC",PSCXL)),"^"),?16,"Orders: ",$PIECE($GET(^TMP($JOB,"PSOLOC",PSCXL)),"^",2)
+23 WRITE !,"In Sort Groups:"
+24 SET (PCCNT,PSCSFLAG)=0
FOR PSCSORT=0:0
SET PSCSORT=$ORDER(^PS(59.8,PSCSORT))
if 'PSCSORT!($GET(PSCLOUT))
QUIT
IF $DATA(^PS(59.8,PSCSORT,1,"B",PSCXL))
SET PSOCAG=0
Begin DoDot:2
+25 SET PSCSFLAG=1
if ($Y+5)>IOSL&(PCCNT)
SET PSOCAG=1
if ($Y+5)>IOSL&(PCCNT)
DO CLDIR
if $GET(PSCLOUT)
QUIT
if $GET(PSOCAG)
WRITE !,"Clinic: "_$PIECE($GET(^SC(PSCXL,0)),"^")_" cont."
if $GET(PCCNT)>0
WRITE !
WRITE ?16,$PIECE($GET(^PS(59.8,PSCSORT,0)),"^")
SET PCCNT=1
End DoDot:2
+26 IF '$GET(PSCSFLAG)
WRITE ?16,"*** NO CLINIC SORT GROUPS ***"
End DoDot:1
+27 IF '$GET(PSCLOUT)
KILL DIR
SET DIR(0)="E"
SET (DIR("A"),DIR("?"))="Press Return to continue"
DO ^DIR
KILL DIR
SUMMQ KILL ^TMP($JOB,"PSOLOC"),^TMP($JOB,"PSOLOCP")
+1 QUIT
CLDIR KILL DIR
SET DIR(0)="E"
SET (DIR("A"),DIR("?"))="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF Y'=1
SET PSCLOUT=1
QUIT
+1 WRITE @IOF
+2 QUIT
RXNCHK IF $GET(PSONEW("RX #"))']""
DO RXNCHK^PSOORNE5
+1 QUIT
RDSPL DO RDSPL^PSOORNE5
+1 QUIT
M3 DO M3^PSOOREDX
+1 QUIT
