PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;Oct 20, 2022@15:19
;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206,313,444,422,457,649,441,545,753**;DEC 1997;Build 53
;External reference ^PS(55 supported by DBIA 2228
;External reference ^PS(50.7 supported by DBIA 2223
;
;*244 call to remove DC'd Rx's from Rx ien strings
;
EN(PSORENW) ;
N LST,ORD,ORN K VALMBCK,PSORX("FN") S PSOAC=1,(PSORX("QFLG"),PSORX("DFLG"))=0 ;D DREN^PSOORNW2,INIT
D INIT
D @$S($P(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN")
I '$D(PSONEW("RX #")),'$P(PSOPAR,"^",7) D PAUSE^VALM1 K VALMSG,PSONEW("QFLG") S VALMBCK="Q" Q
I '$D(PSONEW("RX #")) K VALMSG D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" Q
S PSORENW("RX #")=PSONEW("RX #") I '$P(PSOPAR,"^",7) D Q:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG")))
.S PSOX=PSORENW("RX #") D CHECK^PSONRXN
I $G(PSONEW("DFLG"))!$G(PSONEW("QFLG")) D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" K PSORENW Q
D EN^PSOORNE1(.PSORENW) I '$G(PSORX("FN")) D:$P($G(PSOPAR),"^",7)=1 S VALMBCK="Q" Q
.S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")),PSOX=PSONEW("OLD LAST RX#",PSOY)
.L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
.S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
.D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY)
.I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #"))
.K PSOX,PSOY Q
Q:$G(COPY)
TRY S $P(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15,DA=PSORENW("OIRXN")
S $P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA)
D RMP^PSOCAN3 ;*244
;cancel/discontinue action
S PHARM="",STAT="RP",COMM="Prescription discontinued due to editing." D EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR) K STAT,PHARM,COMM
S ACOM="Discontinued due to editing. New Rx created "_$P(^PSRX(PSORENW("IRXN"),0),"^")_"."
I $G(^PSRX(DA,"H"))]"" D
.I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D
..S DIE=52,DR="22///"_$P(^PSRX(DA,3),"^") D ^DIE S ACOM="Discontinued due to editing while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA)
..S ^PSRX(DA,"H")=""
S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",RXDA,0)) D:DA
.S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
.S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued due to editing while suspended."
.I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
.S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D
.S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB
.S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
.D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$G(ACOM)
.I $G(PSOOIFLG),'$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited."
.I '$G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited."
.I $G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited."
.S REA="C" D EXP^PSOHELP1
I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
Q
INS K X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($J,"INS1")
I '$O(^PSRX(PSORXED("IRXN"),6,0)),'$O(PSORXED("DOSE",0)) D UPMI Q:$G(QUIT) ;G INS1
I $G(^PSRX(PSORXED("IRXN"),"INS"))]"" S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS") K UPMI G INS1
K DD,GG F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S DD=$G(DD)+1
I $G(DD)=1 S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$O(^PSRX(PSORXED("IRXN"),"INS1",0)),0) K UPMI,DD G INS1
I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D G INSX
.F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S ^TMP($J,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0)
.S ^TMP($J,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0)
.S DIC="^TMP($J,""INS1"",",DWPK=2,DWLW=80 D EN^DIWE I $G(X)="^" K ^TMP($J,"INS1") Q
.I '$O(^TMP($J,"INS1",0)) S INSDEL=1
.S D=0 F S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S (PSORXED("SIG",D),PSORXED("INS",D))=^PSRX(PSORXED("IRXN"),"INS1",D,0)
INS1 K Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X
I $G(PSORXED("IRXN")) S:'$D(PSOOEINS) PSOOEINS=$G(^PSRX(PSORXED("IRXN"),"INS")) S:'$D(PSOOSINS) PSOOSINS=$G(^PSRX(PSORXED("IRXN"),"INSS")) ;*422
I $G(UPMI) K UPMI I $G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS")
S:$G(PSORXED("FLD",114))]"" DIR("B")=PSORXED("FLD",114)
S DIR("?")="Enter Quick codes or Free Text",DIR(0)="52,114" D ^DIR
I $D(DTOUT)!($D(DUOUT)) K PSORXED("FLD",114),PSORXED("FLD",114.1) S (PSORXED("INS"),PSORXED("SIG",1))=$G(PSOOEINS) S:$P($G(^PS(55,PSODFN,"LAN")),"^") PSORXED("SINS")=$G(PSOOSINS) D EN^PSOFSIG(.PSORXED,1) G INSQX ;*422
I $G(PSORXED("DFLG")) S (PSORXED("SIG"),PSORXED("INS"))=$G(PSOOEINS),PSORXED("SINS")=$G(PSOOSINS) K PSORXED("SIG") D EN^PSOFSIG(.PSONEW,1) G INSQX ;*422
S PSODELINS=0 I X="@" S PSODELINS=1 D DELINS^PSOHELP3 ;*422
I '$G(PSODELINS),($G(X)="@"!($G(X)="")) S (X,INS1,PSORXED("INS"))=$G(PSOOEINS) ;*422
I $G(PSODELINS) S (INS1,PSORXED("FLD",114),PSORXED("FLD",114.1))="" K PSORXED("INS"),PSORXED("SIG"),PSORXED("SINS") ;*422
I X'="",X'="@" D SIG^PSOHELP G INS1:'$D(X)
I $G(INS1)]"" W " ("_$E(INS1,2,9999999)_")"
S:$G(INS1)]"" (PSORXED("INS"),PSORXED("SIG",1),PSORXED("FLD",114))=$E(INS1,2,9999999) D EN^PSOFSIG(.PSORXED)
I $G(PSODELINS) G INSQ
INSX I '$P($G(^PS(55,PSODFN,"LAN")),"^") G INSQ
K DIR
I $G(^PSRX(PSORXED("IRXN"),"INSS"))]"" S PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
D SINS^PSODIR(.PSORXED) ;*422
I $G(PSORXED("DFLG")) K PSORXED("FLD",114) S PSORXED("INS")=$G(PSOOEINS) S:$P($G(^PS(55,PSODFN,"LAN")),"^") PSORXED("SINS")=$G(PSOOSINS) D EN^PSOFSIG(.PSORXED,1) G INSQ ;*422
S:$G(PSORXED("SINS"))]"" PSORXED("FLD",114.1)=$G(PSORXED("SINS")) ;*422
S PSOINSCH=$$INSCHK^PSOHELP3(.PSORXED) ;*422
G:PSOINSCH INS ;*422
INSQ ;
;441-IND
I '$P($G(^PS(55,PSODFN,"LAN")),"^") D
. S (PSORXED("IND"),PSORXED("FLD",128))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),(PSORXED("INDF"),PSORXED("FLD",129))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
. D INDICAT^PSODIR(.PSORXED)
. I $D(DTOUT)!($D(DUOUT)) K PSORXED("FLD",128),PSORXED("FLD",129) Q
. D EN^PSOFSIG(.PSORXED)
I $P($G(^PS(55,PSODFN,"LAN")),"^") D
. S (PSORXED("IND"),PSORXED("FLD",128))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^"),(PSORXED("INDF"),PSORXED("FLD",129))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
. S (PSORXED("INDO"),PSORXED("FLD",130))=$P($G(^PSRX(PSORXED("IRXN"),"IND")),"^",3)
. D SIND^PSODIR(.PSORXED)
INSQX ;
K DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK,PSOOEINS,PSOOSINS,PSODELINS
Q
INIT ;setup psorenw array
S PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN"))
S PSORENW("RX7")=$G(^PSRX(PSORENW("IRXN"),7)) ;p753
I $G(PSOSIGFL),$G(PSORX("SIG"))]"" S PSORENW("SIG")=PSORX("SIG"),SIGOK=0
E D
.S PSORENW("IND")=$P($G(^("IND")),"^"),PSORENW("INDF")=$P($G(^("IND")),"^",2) ;*441-IND
.I '$P($G(^PSRX(PSORENW("IRXN"),"SIG")),"^",2) S PSORENW("SIG")=$P($G(^("SIG")),"^")
.E D
..S SIGOK=1 Q:$O(SIG(0))
..S D=0 F I=0:0 S D=D+1,I=$O(^PSRX(PSORENW("IRXN"),"SIG1",I)) Q:'I S SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0)
..K PSOX1,D
S PSORENW("OIRXN")=PSORENW("IRXN")
S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4))
S (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^")
;*545 get dea#
S PSORENW("DEA")=$S($L($G(PSORXED("DEACOPY"))):$G(PSORXED("DEACOPY")),1:$$RXDEA^PSOUTIL(PSORENW("IRXN")))
I $P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8)
S PSORENW("CLINIC")=$S($G(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$P(PSORENW("RX0"),"^",5))
S PSORENW("REMARKS")="New Order Created by "_$S($G(COPY)&('$G(PSOEDIT)):"copying",1:"editing")_" Rx # "_$P(PSORENW("RX0"),"^")_"."
S PSORENW("MAIL EXEMPTION")=$P(PSORENW("RX7"),"^",2) ;p753
;
; - Maintenance Dose Rx Remarks field
I $G(PSOMTFLG) S PSORENW("REMARKS")="Maintenance Rx created from Titration Rx# "_$P(PSORENW("RX0"),"^")_"."
;
S PSORENW("COSIGNER")=$S($G(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$P(PSORENW("RX3"),"^",3):$P(PSORENW("RX3"),"^",3),1:"")
K:PSORENW("COSIGNER")="" PSORENW("COSIGNER")
S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2)
S PSORENW("ORX #")=$P(PSORENW("RX0"),"^")
S:$G(PSODRUG("IEN")) PSORENW("DRUG IEN")=PSODRUG("IEN")
;; START NCC REMEDIATION >> 457*RJS - ADJUST MAX DAYS SUPPLY FOR 4 DAY SUPPLY
I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1",$P(PSORENW("RX0"),"^",8)<5 S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8)
;; END NCC REMEDIATION << 457*RJS
;*545 get detox #
I $$DETOX^PSSOPKI($G(PSORENW("DRUG IEN"))) S PSORENW("DETX")=$$PRVDETOX^PSOUTIL(PSORENW("PROVIDER"))
I $G(PSORENW("DAYS SUPPLY")) G QTY
S PSORENW("DAYS SUPPLY")=$S($D(CLOZPAT):7,1:$P(PSORENW("RX0"),"^",8))
QTY S PSORENW("QTY")=$S($G(PSORENW("QTY")):PSORENW("QTY"),1:$P(PSORENW("RX0"),"^",7))
RFN S PSORENW("# OF REFILLS")=$S($D(CLOZPAT):0,$G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9))
S (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT
;
; - Titration to Maintenance Rx
I $G(PSOMTFLG) D
. ; Copying ISSUE DATE from Titatrion Rx
. S (PSOID,PSORENW("ISSUE DATE"))=$P(PSORENW("RX0"),"^",13)
. ; Fill Date is set with Next Possible Fill from Titration Rx
. I $P($G(PSORENW("RX3")),"^",2)>DT S PSORENW("FILL DATE")=$P(PSORENW("RX3"),"^",2)
;
S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(+PSORENW("CLINIC"),0),"^")
S PSORENW("PATIENT STATUS")=$S($G(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$P(PSORENW("RX0"),"^",3):$G(^PS(55,PSORENW("PSODFN"),"PS")),1:$P(PSORENW("RX0"),"^",3))
S PSORENW("PTST NODE")=$G(^PS(53,PSORENW("PATIENT STATUS"),0))
S PSDAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$P(PSORENW("RX0"),"^",8):$P(PSORENW("PTST NODE"),"^",3),1:$P(PSORENW("RX0"),"^",8))
I $G(PSODRUG("IEN")) S DREN=PSODRUG("IEN"),POERR=1 D DRG^PSOORDRG K POERR
D:$G(PSORENW("# OF REFILLS"))']"" RF
;
; - Maintenance Rx # of Refills adjustment
I $G(PSOMTFLG),$G(PSORENW("# OF REFILLS"))>0 S PSORENW("# OF REFILLS")=PSORENW("# OF REFILLS")-1
;
S PSORENW("MAIL/WINDOW")=$S($G(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$P(PSORENW("RX0"),"^",11))
I PSORENW("MAIL/WINDOW")="P",$G(PSODRUG("DEA"))["D" S PSORENW("MAIL/WINDOW")="W" ;PAPI 441 - Make sure not Parked if DEA contains "D"
S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="W":"WINDOW",PSORENW("MAIL/WINDOW")="P":"PARK",1:"MAIL") ;PAPI 441
S PSORENW("COPIES")=$S($G(PSORENW("COPIES")):PSORENW("COPIES"),$P(PSORENW("RX0"),"^",18):$P(PSORENW("RX0"),"^",18),1:1)
S PSORENW("CLERK CODE")=DUZ
S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^")
Q:$D(COPY) S PSORENW("ENT")=0
K PSORENW("ENT") F I=0:0 S I=$O(PSORENW("DOSE",I)) Q:'I S PSORENW("ENT")=$G(PSORENW("ENT"))+1
I $O(^TMP($J,"INS1",0)) D
.K PSORXED("SIG"),DD
.F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I S PSORENW("SIG",I)=^TMP($J,"INS1",I,0)
.K ^TMP($J,"INS1")
I $G(^PSRX(PSORENW("IRXN"),"INS"))]"" S PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS")
I $G(^PSRX(PSORENW("IRXN"),"INSS"))]"" S PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS")
I '$G(PSORENW("ENT")),'$G(PSOSIGFL) D DOLST1^PSOORED3(.PSORENW) S PSORENW("ENT")=+$G(OLENT)
Q
RF ;# of refills
; Retrieving the Maximum Number of Refills allowed
S PSORENW("# OF REFILLS")=$$MAXNUMRF^PSOUTIL(+$G(PSODRUG("IEN")),PSDAYS,+$G(PSORENW("PATIENT STATUS")),.CLOZPAT)
Q
UPMI ;add dosing data for pre-poe rxs
W !! K PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them"
D ^DIR I 'Y!($D(DIRUT)) S QUIT=1 K DIR,DIRUT,DUOT,DUOUT Q
S UPMI=1,EDTHLD=$G(PSORX("EDIT")) K PSORX("EDIT")
D DOSE1^PSOORED5(.PSORXED) S (PSORXED,PSORX("EDIT"))=EDTHLD K EDTHLD I $G(PSONEW("DFLG")) S QUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORED1 12205 printed Sep 23, 2025@20:08:16 Page 2
PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;Oct 20, 2022@15:19
+1 ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206,313,444,422,457,649,441,545,753**;DEC 1997;Build 53
+2 ;External reference ^PS(55 supported by DBIA 2228
+3 ;External reference ^PS(50.7 supported by DBIA 2223
+4 ;
+5 ;*244 call to remove DC'd Rx's from Rx ien strings
+6 ;
EN(PSORENW) ;
+1 ;D DREN^PSOORNW2,INIT
NEW LST,ORD,ORN
KILL VALMBCK,PSORX("FN")
SET PSOAC=1
SET (PSORX("QFLG"),PSORX("DFLG"))=0
+2 DO INIT
+3 DO @$SELECT($PIECE(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN")
+4 IF '$DATA(PSONEW("RX #"))
IF '$PIECE(PSOPAR,"^",7)
DO PAUSE^VALM1
KILL VALMSG,PSONEW("QFLG")
SET VALMBCK="Q"
QUIT
+5 IF '$DATA(PSONEW("RX #"))
KILL VALMSG
DO DEL^PSONEW
DO PAUSE^VALM1
SET VALMBCK="Q"
QUIT
+6 SET PSORENW("RX #")=PSONEW("RX #")
IF '$PIECE(PSOPAR,"^",7)
Begin DoDot:1
+7 SET PSOX=PSORENW("RX #")
DO CHECK^PSONRXN
End DoDot:1
if $GET(PSONEW("DFLG"))!($GET(PSONEW("QFLG")))
QUIT
+8 IF $GET(PSONEW("DFLG"))!$GET(PSONEW("QFLG"))
DO DEL^PSONEW
DO PAUSE^VALM1
SET VALMBCK="Q"
KILL PSORENW
QUIT
+9 DO EN^PSOORNE1(.PSORENW)
IF '$GET(PSORX("FN"))
if $PIECE($GET(PSOPAR),"^",7)=1
Begin DoDot:1
+10 SET DIE="^PS(59,"
SET DA=PSOSITE
SET PSOY=$ORDER(PSONEW("OLD LAST RX#",""))
SET PSOX=PSONEW("OLD LAST RX#",PSOY)
+11 LOCK +^PS(59,+PSOSITE,PSOY):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+12 SET DR=$SELECT(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
+13 if PSOX<$PIECE(^PS(59,+PSOSITE,PSOY),"^",3)
DO ^DIE
KILL DIE,X,Y
LOCK -^PS(59,+PSOSITE,PSOY)
+14 IF $DATA(PSONEW("RX #"))
LOCK -^PSRX("B",PSONEW("RX #"))
+15 KILL PSOX,PSOY
QUIT
End DoDot:1
SET VALMBCK="Q"
QUIT
+16 if $GET(COPY)
QUIT
TRY SET $PIECE(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15
SET DA=PSORENW("OIRXN")
+1 SET $PIECE(^PSRX(DA,3),"^",5)=DT
SET $PIECE(^PSRX(DA,3),"^",10)=$PIECE(^PSRX(DA,3),"^")
+2 DO REVERSE^PSOBPSU1(DA,,"DC",7)
DO CAN^PSOTPCAN(DA)
+3 ;*244
DO RMP^PSOCAN3
+4 ;cancel/discontinue action
+5 SET PHARM=""
SET STAT="RP"
SET COMM="Prescription discontinued due to editing."
DO EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR)
KILL STAT,PHARM,COMM
+6 SET ACOM="Discontinued due to editing. New Rx created "_$PIECE(^PSRX(PSORENW("IRXN"),0),"^")_"."
+7 IF $GET(^PSRX(DA,"H"))]""
Begin DoDot:1
+8 IF $PIECE(^PSRX(DA,"STA"),"^")=3!($PIECE(^("STA"),"^")=16)
Begin DoDot:2
+9 SET DIE=52
SET DR="22///"_$PIECE(^PSRX(DA,3),"^")
DO ^DIE
SET ACOM="Discontinued due to editing while on hold. "
if $PIECE(^PSRX(DA,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(DA,"H"),"^"),DA)
+10 SET ^PSRX(DA,"H")=""
End DoDot:2
End DoDot:1
+11 SET RXDA=DA
SET (DA,SUSDA)=$ORDER(^PS(52.5,"B",RXDA,0))
if DA
Begin DoDot:1
+12 SET SUSD=$PIECE($GET(^PS(52.5,DA,0)),"^",2)
+13 if +$GET(^PS(52.5,DA,"P"))'=1
SET ACOM="Discontinued due to editing while suspended."
+14 IF $ORDER(^PSRX(RXDA,1,0))
SET DA=RXDA
if '$GET(^PS(52.5,+SUSDA,"P"))
DO REF^PSOCAN2
+15 SET DA=SUSDA
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
End DoDot:1
+16 KILL SUSD,SUSDA
SET DA=RXDA
SET RXREF=0
SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
Begin DoDot:1
+17 SET ACNT=0
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(DA,"A",SUB))
if 'SUB
QUIT
SET ACNT=SUB
+18 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(DA,1,RF))
if 'RF
QUIT
SET RFCNT=RF
if RF>5
SET RFCNT=RF+1
+19 DO NOW^%DTC
SET ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1)
SET ^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$GET(ACOM)
+20 IF $GET(PSOOIFLG)
IF '$GET(PSOMRFLG)
SET $PIECE(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited."
+21 IF '$GET(PSOOIFLG)
IF $GET(PSOMRFLG)
SET $PIECE(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited."
+22 IF $GET(PSOOIFLG)
IF $GET(PSOMRFLG)
SET $PIECE(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited."
+23 SET REA="C"
DO EXP^PSOHELP1
End DoDot:1
+24 IF $GET(^PS(52.4,DA,0))]""
SET PSCDA=DA
SET DIK="^PS(52.4,"
DO ^DIK
SET DA=PSCDA
KILL DIK,PSCDA
+25 QUIT
INS KILL X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($JOB,"INS1")
+1 ;G INS1
IF '$ORDER(^PSRX(PSORXED("IRXN"),6,0))
IF '$ORDER(PSORXED("DOSE",0))
DO UPMI
if $GET(QUIT)
QUIT
+2 IF $GET(^PSRX(PSORXED("IRXN"),"INS"))]""
SET PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS")
KILL UPMI
GOTO INS1
+3 KILL DD,GG
FOR I=0:0
SET I=$ORDER(^PSRX(PSORXED("IRXN"),"INS1",I))
if 'I
QUIT
SET DD=$GET(DD)+1
+4 IF $GET(DD)=1
SET PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$ORDER(^PSRX(PSORXED("IRXN"),"INS1",0)),0)
KILL UPMI,DD
GOTO INS1
+5 IF $ORDER(^PSRX(PSORXED("IRXN"),"INS1",0))
Begin DoDot:1
+6 FOR I=0:0
SET I=$ORDER(^PSRX(PSORXED("IRXN"),"INS1",I))
if 'I
QUIT
SET ^TMP($JOB,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0)
+7 SET ^TMP($JOB,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0)
+8 SET DIC="^TMP($J,""INS1"","
SET DWPK=2
SET DWLW=80
DO EN^DIWE
IF $GET(X)="^"
KILL ^TMP($JOB,"INS1")
QUIT
+9 IF '$ORDER(^TMP($JOB,"INS1",0))
SET INSDEL=1
+10 SET D=0
FOR
SET D=$ORDER(^PSRX(PSORXED("IRXN"),"INS1",D))
if 'D
QUIT
SET (PSORXED("SIG",D),PSORXED("INS",D))=^PSRX(PSORXED("IRXN"),"INS1",D,0)
End DoDot:1
GOTO INSX
INS1 KILL Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X
+1 ;*422
IF $GET(PSORXED("IRXN"))
if '$DATA(PSOOEINS)
SET PSOOEINS=$GET(^PSRX(PSORXED("IRXN"),"INS"))
if '$DATA(PSOOSINS)
SET PSOOSINS=$GET(^PSRX(PSORXED("IRXN"),"INSS"))
+2 IF $GET(UPMI)
KILL UPMI
IF $GET(^PS(50.7,PSODRUG("OI"),"INS"))]""
SET PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS")
+3 if $GET(PSORXED("FLD",114))]""
SET DIR("B")=PSORXED("FLD",114)
+4 SET DIR("?")="Enter Quick codes or Free Text"
SET DIR(0)="52,114"
DO ^DIR
+5 ;*422
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL PSORXED("FLD",114),PSORXED("FLD",114.1)
SET (PSORXED("INS"),PSORXED("SIG",1))=$GET(PSOOEINS)
if $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET PSORXED("SINS")=$GET(PSOOSINS)
DO EN^PSOFSIG(.PSORXED,1)
GOTO INSQX
+6 ;*422
IF $GET(PSORXED("DFLG"))
SET (PSORXED("SIG"),PSORXED("INS"))=$GET(PSOOEINS)
SET PSORXED("SINS")=$GET(PSOOSINS)
KILL PSORXED("SIG")
DO EN^PSOFSIG(.PSONEW,1)
GOTO INSQX
+7 ;*422
SET PSODELINS=0
IF X="@"
SET PSODELINS=1
DO DELINS^PSOHELP3
+8 ;*422
IF '$GET(PSODELINS)
IF ($GET(X)="@"!($GET(X)=""))
SET (X,INS1,PSORXED("INS"))=$GET(PSOOEINS)
+9 ;*422
IF $GET(PSODELINS)
SET (INS1,PSORXED("FLD",114),PSORXED("FLD",114.1))=""
KILL PSORXED("INS"),PSORXED("SIG"),PSORXED("SINS")
+10 IF X'=""
IF X'="@"
DO SIG^PSOHELP
if '$DATA(X)
GOTO INS1
+11 IF $GET(INS1)]""
WRITE " ("_$EXTRACT(INS1,2,9999999)_")"
+12 if $GET(INS1)]""
SET (PSORXED("INS"),PSORXED("SIG",1),PSORXED("FLD",114))=$EXTRACT(INS1,2,9999999)
DO EN^PSOFSIG(.PSORXED)
+13 IF $GET(PSODELINS)
GOTO INSQ
INSX IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
GOTO INSQ
+1 KILL DIR
+2 IF $GET(^PSRX(PSORXED("IRXN"),"INSS"))]""
SET PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS")
+3 ;*422
DO SINS^PSODIR(.PSORXED)
+4 ;*422
IF $GET(PSORXED("DFLG"))
KILL PSORXED("FLD",114)
SET PSORXED("INS")=$GET(PSOOEINS)
if $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET PSORXED("SINS")=$GET(PSOOSINS)
DO EN^PSOFSIG(.PSORXED,1)
GOTO INSQ
+5 ;*422
if $GET(PSORXED("SINS"))]""
SET PSORXED("FLD",114.1)=$GET(PSORXED("SINS"))
+6 ;*422
SET PSOINSCH=$$INSCHK^PSOHELP3(.PSORXED)
+7 ;*422
if PSOINSCH
GOTO INS
INSQ ;
+1 ;441-IND
+2 IF '$PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
Begin DoDot:1
+3 SET (PSORXED("IND"),PSORXED("FLD",128))=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^")
SET (PSORXED("INDF"),PSORXED("FLD",129))=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
+4 DO INDICAT^PSODIR(.PSORXED)
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
KILL PSORXED("FLD",128),PSORXED("FLD",129)
QUIT
+6 DO EN^PSOFSIG(.PSORXED)
End DoDot:1
+7 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
Begin DoDot:1
+8 SET (PSORXED("IND"),PSORXED("FLD",128))=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^")
SET (PSORXED("INDF"),PSORXED("FLD",129))=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^",2)
+9 SET (PSORXED("INDO"),PSORXED("FLD",130))=$PIECE($GET(^PSRX(PSORXED("IRXN"),"IND")),"^",3)
+10 DO SIND^PSODIR(.PSORXED)
End DoDot:1
INSQX ;
+1 KILL DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK,PSOOEINS,PSOOSINS,PSODELINS
+2 QUIT
INIT ;setup psorenw array
+1 SET PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0)
SET PSORENW("RX2")=^(2)
SET PSORENW("RX3")=^(3)
SET PSORENW("STA")=^("STA")
SET PSORENW("TN")=$GET(^("TN"))
+2 ;p753
SET PSORENW("RX7")=$GET(^PSRX(PSORENW("IRXN"),7))
+3 IF $GET(PSOSIGFL)
IF $GET(PSORX("SIG"))]""
SET PSORENW("SIG")=PSORX("SIG")
SET SIGOK=0
+4 IF '$TEST
Begin DoDot:1
+5 ;*441-IND
SET PSORENW("IND")=$PIECE($GET(^("IND")),"^")
SET PSORENW("INDF")=$PIECE($GET(^("IND")),"^",2)
+6 IF '$PIECE($GET(^PSRX(PSORENW("IRXN"),"SIG")),"^",2)
SET PSORENW("SIG")=$PIECE($GET(^("SIG")),"^")
+7 IF '$TEST
Begin DoDot:2
+8 SET SIGOK=1
if $ORDER(SIG(0))
QUIT
+9 SET D=0
FOR I=0:0
SET D=D+1
SET I=$ORDER(^PSRX(PSORENW("IRXN"),"SIG1",I))
if 'I
QUIT
SET SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0)
+10 KILL PSOX1,D
End DoDot:2
End DoDot:1
+11 SET PSORENW("OIRXN")=PSORENW("IRXN")
+12 SET PSORENW("PROVIDER")=$SELECT($GET(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$PIECE(PSORENW("RX0"),"^",4))
+13 SET (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$PIECE($GET(^VA(200,PSORENW("PROVIDER"),0)),"^")
+14 ;*545 get dea#
+15 SET PSORENW("DEA")=$SELECT($LENGTH($GET(PSORXED("DEACOPY"))):$GET(PSORXED("DEACOPY")),1:$$RXDEA^PSOUTIL(PSORENW("IRXN")))
+16 IF $PIECE($GET(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7)
IF $PIECE($GET(^("PS")),"^",8)
SET PSORENW("COSIGNING PROVIDER")=$PIECE($GET(^("PS")),"^",8)
+17 SET PSORENW("CLINIC")=$SELECT($GET(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$PIECE(PSORENW("RX0"),"^",5))
+18 SET PSORENW("REMARKS")="New Order Created by "_$SELECT($GET(COPY)&('$GET(PSOEDIT)):"copying",1:"editing")_" Rx # "_$PIECE(PSORENW("RX0"),"^")_"."
+19 ;p753
SET PSORENW("MAIL EXEMPTION")=$PIECE(PSORENW("RX7"),"^",2)
+20 ;
+21 ; - Maintenance Dose Rx Remarks field
+22 IF $GET(PSOMTFLG)
SET PSORENW("REMARKS")="Maintenance Rx created from Titration Rx# "_$PIECE(PSORENW("RX0"),"^")_"."
+23 ;
+24 SET PSORENW("COSIGNER")=$SELECT($GET(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$PIECE(PSORENW("RX3"),"^",3):$PIECE(PSORENW("RX3"),"^",3),1:"")
+25 if PSORENW("COSIGNER")=""
KILL PSORENW("COSIGNER")
+26 SET PSORENW("PSODFN")=$PIECE(PSORENW("RX0"),"^",2)
+27 SET PSORENW("ORX #")=$PIECE(PSORENW("RX0"),"^")
+28 if $GET(PSODRUG("IEN"))
SET PSORENW("DRUG IEN")=PSODRUG("IEN")
+29 ;; START NCC REMEDIATION >> 457*RJS - ADJUST MAX DAYS SUPPLY FOR 4 DAY SUPPLY
+30 IF $$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)="PSOCLO1"
IF $PIECE(PSORENW("RX0"),"^",8)<5
SET PSORENW("DAYS SUPPLY")=$PIECE(PSORENW("RX0"),"^",8)
+31 ;; END NCC REMEDIATION << 457*RJS
+32 ;*545 get detox #
+33 IF $$DETOX^PSSOPKI($GET(PSORENW("DRUG IEN")))
SET PSORENW("DETX")=$$PRVDETOX^PSOUTIL(PSORENW("PROVIDER"))
+34 IF $GET(PSORENW("DAYS SUPPLY"))
GOTO QTY
+35 SET PSORENW("DAYS SUPPLY")=$SELECT($DATA(CLOZPAT):7,1:$PIECE(PSORENW("RX0"),"^",8))
QTY SET PSORENW("QTY")=$SELECT($GET(PSORENW("QTY")):PSORENW("QTY"),1:$PIECE(PSORENW("RX0"),"^",7))
RFN SET PSORENW("# OF REFILLS")=$SELECT($DATA(CLOZPAT):0,$GET(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$PIECE(PSORENW("RX0"),"^",9))
+1 SET (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT
+2 ;
+3 ; - Titration to Maintenance Rx
+4 IF $GET(PSOMTFLG)
Begin DoDot:1
+5 ; Copying ISSUE DATE from Titatrion Rx
+6 SET (PSOID,PSORENW("ISSUE DATE"))=$PIECE(PSORENW("RX0"),"^",13)
+7 ; Fill Date is set with Next Possible Fill from Titration Rx
+8 IF $PIECE($GET(PSORENW("RX3")),"^",2)>DT
SET PSORENW("FILL DATE")=$PIECE(PSORENW("RX3"),"^",2)
End DoDot:1
+9 ;
+10 if PSORENW("CLINIC")
SET PSORX("CLINIC")=$PIECE(^SC(+PSORENW("CLINIC"),0),"^")
+11 SET PSORENW("PATIENT STATUS")=$SELECT($GET(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$PIECE(PSORENW("RX0"),"^",3):$GET(^PS(55,PSORENW("PSODFN"),"PS")),1:$PIECE(PSORENW("RX0"),"^",3))
+12 SET PSORENW("PTST NODE")=$GET(^PS(53,PSORENW("PATIENT STATUS"),0))
+13 SET PSDAYS=$SELECT($GET(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$PIECE(PSORENW("RX0"),"^",8):$PIECE(PSORENW("PTST NODE"),"^",3),1:$PIECE(PSORENW("RX0"),"^",8))
+14 IF $GET(PSODRUG("IEN"))
SET DREN=PSODRUG("IEN")
SET POERR=1
DO DRG^PSOORDRG
KILL POERR
+15 if $GET(PSORENW("# OF REFILLS"))']""
DO RF
+16 ;
+17 ; - Maintenance Rx # of Refills adjustment
+18 IF $GET(PSOMTFLG)
IF $GET(PSORENW("# OF REFILLS"))>0
SET PSORENW("# OF REFILLS")=PSORENW("# OF REFILLS")-1
+19 ;
+20 SET PSORENW("MAIL/WINDOW")=$SELECT($GET(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$PIECE(PSORENW("RX0"),"^",11))
+21 ;PAPI 441 - Make sure not Parked if DEA contains "D"
IF PSORENW("MAIL/WINDOW")="P"
IF $GET(PSODRUG("DEA"))["D"
SET PSORENW("MAIL/WINDOW")="W"
+22 ;PAPI 441
SET PSORX("MAIL/WINDOW")=$SELECT(PSORENW("MAIL/WINDOW")="W":"WINDOW",PSORENW("MAIL/WINDOW")="P":"PARK",1:"MAIL")
+23 SET PSORENW("COPIES")=$SELECT($GET(PSORENW("COPIES")):PSORENW("COPIES"),$PIECE(PSORENW("RX0"),"^",18):$PIECE(PSORENW("RX0"),"^",18),1:1)
+24 SET PSORENW("CLERK CODE")=DUZ
+25 if $GET(PSORX("CLERK CODE"))']""
SET PSORX("CLERK CODE")=$PIECE($GET(^VA(200,DUZ,0)),"^")
+26 if $DATA(COPY)
QUIT
SET PSORENW("ENT")=0
+27 KILL PSORENW("ENT")
FOR I=0:0
SET I=$ORDER(PSORENW("DOSE",I))
if 'I
QUIT
SET PSORENW("ENT")=$GET(PSORENW("ENT"))+1
+28 IF $ORDER(^TMP($JOB,"INS1",0))
Begin DoDot:1
+29 KILL PSORXED("SIG"),DD
+30 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"INS1",I))
if 'I
QUIT
SET PSORENW("SIG",I)=^TMP($JOB,"INS1",I,0)
+31 KILL ^TMP($JOB,"INS1")
End DoDot:1
+32 IF $GET(^PSRX(PSORENW("IRXN"),"INS"))]""
SET PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS")
+33 IF $GET(^PSRX(PSORENW("IRXN"),"INSS"))]""
SET PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS")
+34 IF '$GET(PSORENW("ENT"))
IF '$GET(PSOSIGFL)
DO DOLST1^PSOORED3(.PSORENW)
SET PSORENW("ENT")=+$GET(OLENT)
+35 QUIT
RF ;# of refills
+1 ; Retrieving the Maximum Number of Refills allowed
+2 SET PSORENW("# OF REFILLS")=$$MAXNUMRF^PSOUTIL(+$GET(PSODRUG("IEN")),PSDAYS,+$GET(PSORENW("PATIENT STATUS")),.CLOZPAT)
+3 QUIT
UPMI ;add dosing data for pre-poe rxs
+1 WRITE !!
KILL PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them"
+2 DO ^DIR
IF 'Y!($DATA(DIRUT))
SET QUIT=1
KILL DIR,DIRUT,DUOT,DUOUT
QUIT
+3 SET UPMI=1
SET EDTHLD=$GET(PSORX("EDIT"))
KILL PSORX("EDIT")
+4 DO DOSE1^PSOORED5(.PSORXED)
SET (PSORXED,PSORX("EDIT"))=EDTHLD
KILL EDTHLD
IF $GET(PSONEW("DFLG"))
SET QUIT=1
+5 QUIT
