PSJOE ;BIR/MLM - INPATIENT ORDER ENTRY ;Jan 14, 2021@10:49:31
;;5.0;INPATIENT MEDICATIONS;**7,26,29,33,42,50,56,72,58,85,95,80,110,111,133,140,151,149,181,252,281,315,256,344,327,319,411,364,399,407**;16 DEC 97;Build 26
;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 via DBIA 2191
; Reference to EN^VALM via DBIA 10118
; Reference to FULL^VALM1 via DBIA 10116
; Reference to PAUSE^VALM1 via DBIA 10116
; Reference to ^PSSLOCK via DBIA 2789
; Reference to ^DPT( via DBIA 10035
; Reference to ^ORCFLAG via DBIA #3620
; Reference to ^SDAMA203 via DBIA #4133
; Reference to ^TMP("PSODAOC" via DBIA 6071
;
;*364 - add Hazardous Handle & Dispose flags alert message.
;*407 - Prevent access to PSJ OE when IV Room isn't built properly
;
EN ; Start Inpatient LM OE
N PSJLK,PSJNEWOE,PSJLMCON,PSJPROT,XQORS,VALMEVL D ENCV^PSGSETU,^PSIVXU
; I $D(XQUIT) K XQUIT G DONE ; PSJ*407
I ($D(XQUIT)!$G(DONE)) K XQUIT G DONE ; PSJ*407
K PSGVBY,PSJPR S (PSJOL,PSJACOK,PSGOP,PSGNEF,PSGOEAV,PSGPXN)="" L +^PS(53.45,PSJSYSP):1 E D LOCKERR^PSJOE G DONE^PSJOE
F S (PSJLMCON,PSGPTMP)=0 D ^PSJP,HK Q:PSGP'>0 S PSJPROT=3,DFN=PSGP D ^PSJAC D I PSJLK D UL^PSSLOCK(PSGP)
.K ^TMP("PSJ",$J)
.S PSJLK=$$L^PSSLOCK(PSGP,1) I 'PSJLK W !,$C(7),$P(PSJLK,U,2) Q
.K PSJLMPRO D EN^VALM("PSJ LM BRIEF PATIENT INFO")
.N NXTPT S NXTPT=0 F Q:$G(NXTPT) D
..K PSGRDTX
..I $G(PSJLMCON)!$G(PSJNEWOE) D
...S PSJOL=$S(",S,L,"[(","_$G(PSJOL)_","):PSJOL,1:"S")
...S PSJLMPRO=1,PSJLMCON=1,PSJNEWOE=0 D EN^VALM("PSJ LM OE")
..I $G(PSJNEWOE)!($G(VALMBCK)="Q") S PSJNEWOE=0 Q
..I $G(PSJLMCON)&$G(PSJLMPRO)&'$D(^TMP("PSJ",$J)) D Q
...S PSJLMCON=0,PSJLMPRO=0 D EN^VALM("PSJ LM BRIEF PATIENT INFO")
...I $G(PSJNEWOE) S NXTPT=0 Q
...S NXTPT=1
..S NXTPT=1,PSJNEWOE=0
.S PSJOL="S"
.I $G(PSGPXN) I $P(PSJSYSW0,U,29)]""!($G(PSJCOM)) S PSGPXPT=PSGP D K PSGPXPT S PSGPXN=0
..N DFN,PSGP,PSJPXDP
..I $P(PSJSYSW0,U,29)="" S PSJPDXP=1 D
...;N IO,ION,IOS D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
...D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
..S (PSGP,DFN)=PSGPXPT D ^PSGPER S:$G(PSJPDXP) $P(PSJSYSW0,U,29)="" K PSJPDXP
.D ENCV^PSGSETU,^PSIVXU
K PSJLMPRO,^TMP("PSJPRO",$J),^TMP("PSJ",$J),^TMP("PSJON",$J)
DONE ;
; -- RTC 198753 - correct typo - r PSJALGSV w PSJAGYSV
K PSJAGYSV,PSJEXCPT,PSJOCER,^TMP($J,"PSJPRE"),^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
K AC,ACTION,D1,D2,MI,N,ON,P3,PNOW,PSIVAT,PSIVLN,PSIVSTR L -^PS(53.45,PSJSYSP)
K DA,DRG,NE,PSGCF,PSGCANFL,PSGNEDFD,PSGNEF,PSGNEFD,PSGNEPR,PSGNESD,PSJACOK,PSJOE,PSJOECNT,PSJOEPF,PSJORD,PSGOEA,PSGOEAV,PSGOL,PSGOS,PSGON,PSGOP,PSGORD,PSGS0XT,PSGS0Y,RCT,ST,WD,XREF,Z,PSJIVORF,PSJIVPCL
K PSGOEORF,PSIVREA,PSJOPC,PSJORL,PSJORPCL,PSJORTOI,RF,WSCHADM,PSJLM,PSJCT
K DIU,DRGI,FLAG,FQC,ND2,PRI,PSGOE,PSGPRI,PSGSDN,PSGOEDMR,PSGOEPR,PSGPTS,PSGTOL,PSGTOO,PSGUOW,PSJIVOF,PSJOCNT,PSJON,PSJORQF,PSJORTOU,PSJORVP
K PSIVENO,PSGRMV,PSGRMVT,PSGDUR,PSGRF,ND2P1 ;*315
G:$G(PSGPXN) ^PSGPER1 D ENIVKV^PSGSETU
Q
HK ; Housekeeping (a nice COBOL term)
I PSGOP,PSGOP'=PSGP D
.N PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR S DFN=PSGOP
.D INP^VADPT S PSJPWD=+VAIN(4) I PSJPWD S PSJACPF=10 D WP^PSJAC D:$P(PSJSYSL,"^",2)]"" ENQL^PSGLW
Q:PSGP<0
S (DFN,PSGOP)=PSGP,X=""
Q
SELECT ; Select order from list
;Variable PSJOCDSC is used in Complex order dosing checks
N PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),PSJSTARI,^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
K PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1 ;*315
S PSGONC=1,PSGLMT=^TMP("PSJPRO",$J,0) D ENASR^PSGON
I "^"[X S VALMQUIT=1 Q
S PSJLM=1,PSJSEL=0 F S PSJSEL=$O(PSGODDD(PSJSEL)) Q:'PSJSEL!($G(Y)<0) F PSJSEL1=1:1:$L(PSGODDD(PSJSEL),",")-1 D
.K PSJOCDSC
.S PSJORD=$G(^TMP("PSJON",$J,+$P(PSGODDD(PSJSEL),",",PSJSEL1))) D:PSJORD=+PSJORD SELECT^PSJOEA Q:PSJORD=""!($G(Y)<0) Q:PSJORD=+PSJORD D
..Q:('$$LS^PSSLOCK(PSGP,PSJORD))
..Q:PSJORD=+PSJORD
..S PSGORD=""
..D DISACTIO(PSGP,PSJORD,"") S:PSJORD["V" PSJORD=ON
..D UNL^PSSLOCK(PSGP,PSJORD) Q:$G(Y)<0
S VALMBCK="Q"
K PSJLM,PSJOCDSC
Q
DISACTIO(DFN,PSJORD,PSJPNV) ; Display UD order and allow actions.
; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
; PSJDSVFY - Flag if non-vf order was edited
; PSJENHOC=1 if DI,DT were display. This will be used by dosing OC to check if error messages should display or not
; PSJAGYSV=1 If UD was edited
;N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSJAGYSV
N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSIVENO,PSJBACK
K PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1 ;*315
K PSJEXCPT("PROSPECTIVE") ;*256
D OLDCOM^PSJOE0(DFN,PSJORD)
S PSGP=DFN D ENIV^PSJAC I PSJORD["V" D EN^PSJLIORD(DFN,PSJORD) Q
D GETUD^PSJLMGUD(DFN,PSJORD)
S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
S:$G(PSJTUD) PSGPD=$G(PSJCOI),PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
K PSGOENG I '$D(PSGPRF) D Q:$G(PSGOENG)
. I PSJORD["U" L +^PS(55,PSGP,5,+PSJORD):1 E S PSGOENG=1
. I PSJORD["P" L +^PS(53.1,+PSJORD):1 E S PSGOENG=1
. I $G(PSGOENG) W !,"This order is being edited by another terminal.",! S PSGOENG=1 K DIR S DIR(0)="E" D ^DIR K DIR Q
S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
I PSJORD["P" S PSJXX1=$G(^PS(53.1,+PSJORD,0)) I PSGP'=$P(PSJXX1,U,15)!(DFN'=$P(PSJXX1,U,15)) L -^PS(53.1,+PSJORD) Q
I PSJORD["P" D S PSJXX1=$P($G(^PS(53.1,+PSJORD,0)),U,9) I $S($G(PSJIVFLG):1,$G(Y)<0:1,"PADE"[PSJXX1:1,1:0) L -^PS(53.1,+PSJORD) Q
.K:$P($G(PSJXX1),U,4)="U" PSIVFLG ;p344
.I $P(PSJXX1,U,9)="N",($P(PSJXX1,U,4)'="U") D Q
.. S P("PON")=PSJORD,PSIVFLG=1
.. N ON S ON=PSJORD D VF^PSIVORC2
.I $P(PSJXX1,U,9)="P" D Q
..S:$G(PSJTUD) $P(PSJXX1,U,4)="U"
..I $P(PSJXX1,U,4)="U" D Q:$G(PSJIVFLG)
... N VAIP S CLINIC=$G(^PS(53.1,+PSJORD,"DSS")),APPT=$P(CLINIC,"^",2),CLINIC=$P(CLINIC,"^") I $$PATCH^XPDUTL("SD*5.3*285") S PSJBACK=$$SDIMO^SDAMA203(CLINIC,DFN) I PSJBACK'<-1 Q
... Q:'PSJPDD W !!,"Cannot process an Out-patient Unit Dose order for ",$P($G(^DPT(+PSGP,0)),U) D PAUSE^VALM1 S PSJIVFLG=1
..NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
..D REQDT^PSJLIVMD(PSJORD)
..I $P(PSJXX1,U,4)="U",($G(PSGSCH)="") W !!,"Invalid schedule, can't finish this order" D PAUSE^VALM1 Q
..I $P(PSJXX1,U,4)="U" N PSJLM,PSJOCFG S PSJLM=1,PSGORD=PSJORD,PSJOCFG="FN UD" D START^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD) S:$G(PSJTUD) PSJOCFG="FN UD" D @$S($G(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING EDIT"")") K PSJOCFG Q
..I $P(PSJXX1,U,4)'="U",PSGP=$P(PSJXX1,U,15),DFN=$P(PSJXX1,U,15) S PSJLYN=PSJORD,PSJOCFG="FN IV" D EN^PSJLIFN S PSJIVFLG=1 K PSJLYN,PSJMAI,PSJOCFG
I $G(PSIVFLG) K PSIVFLG Q
S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD),PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSJORD),ENSFE^PSGOEE0(PSGP,PSJORD),EN^VALM("PSJ LM UD ACTION")
I PSJORD["P" L -^PS(53.1,+PSJORD)
I PSJORD["U" L -^PS(55,PSGP,5,+PSJORD)
;Send SN to CPRS if auto-verify OFF and Order Set Entry and no 21st piece
S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
I $D(PSGOES),'PSGOEAV,$D(PSGORD),PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),"^",21)']"" D ORSET^PSGOETO1
I $G(PSGOEAV),($G(PSGOES)=1) D SETOC ;Store allergy for order set /w auto vf
I '$G(PSGOEAV),($G(PSJORD)["P"),$S($G(PSJAGYSV):1,($G(PSJOCFG)="NEW UD"):1,1:0) D SETOC
; -- RTC 236646
K ^TMP("PSODAOC",$J,"ALLERGY")
D UNL^PSSLOCK(PSGP,PSJORD)
Q
SETOC ;
;RTC 178789
S ^TMP("PSODAOC",$J,"IP IEN")=PSJORD
D SETOC^PSJNEWOC(PSJORD)
K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J),PSJAGYSV,PSJOCFG
Q
EDIT(PSGP,PSGORD,PROMPT) ;
N PSJOP,ANQX,PSGEDT
S (ANQX,PSJOP)=0,PSGEDT=1
S PSJOP=+Y(1)
S PSJOP=$S(PSJOP=9:0,PSJOP=11:0,1:1)
;/RBN Begin modification for NCC moved code to ACT^PSGOEE
I "DE"[$$GTSTATUS(PSGP,PSGORD) W !,"This order may not be edited." D PAUSE^VALM1 Q
I PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q
N PSJEDITO S PSJEDITO=1
S PSJAGYSV=1 ;Flag to store allergy data in 100.05.
S PSGNEDFD="" D HOLDHDR,@$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") I 'Y D ABORT^PSGOEE Q
I PSGORD["P" D ENF^PSGOEE Q
D ACT^PSGOEE
Q
RENEW(PSGP,PSGORD) ;
;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD using this flag to not display drug error.
;/RJS Begin modifications for PSJ*5.0*327
I $$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD) D Q
.W !,"Clozapine orders cannot be renewed."
.W !,"No order entered!"
.D PAUSE^VALM1
;/RJS End modifications for PSJ*5.0*327
NEW PSJOCFG
S PSJOCFG="RENEW UD"
D HOLDHDR
I 'PSJSYSU,$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,15),$P($G(^(4)),U,16) W !!,"This order is already marked for renewal!" D PAUSE^VALM1 S VALMBCK="R" Q
I 'PSGRRF D ^PSGOER K PSJOCFG Q
D ^PSGOERI
K PSJOCFG
Q
GTSTATUS(DFN,ON) ;
I ON["P" Q $P($G(^PS(53.1,+ON,0)),U,9)
I ON["U" Q $P($G(^PS(55,DFN,5,+ON,0)),U,9)
Q $P($G(^PS(55,DFN,"IV",+ON,0)),U,17)
DC(DFN,PSJORD) ; DC IV, UD, or pending orders.
D HOLDHDR
S X=$$GTSTATUS(DFN,PSJORD) I X="D"!(X="DE")!(X="R") W !,$S(X="R":"This order has a pending renewal and cannot be DISCONTINUED.",1:"This order has already been DISCONTINUED.") D PAUSE^VALM1 Q
D ENO^PSGOEC(DFN,PSJORD) ;,GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN,PSJORD) S VALMBCK="Q"
S VALMBCK="Q"
Q
HOLD(DFN,PSJORD) ; Change order's status from ACTIVE<->HOLD
D HOLDHDR
I PSJORD["V" D H^PSIVOPT(DFN,PSJORD,P(17),P(3))
I PSJORD'["V" D H^PSGOE1(DFN,PSJORD)
D GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN,PSJORD) S PSGACT=$$ENACTION^PSGOE1(DFN,PSJORD),VALMBCK="R"
Q
COPY(PSGP,PSGORD) ; Copy an order (does not discontinue original order)
N PSJOCFG
; PSJ*5*327 - disallow copy for clozapine
I $D(^PS(55,PSGP,5,+PSGORD,"SAND")) W !!,"You cannot copy a clozapine order." D PAUSE^VALM1 Q
I $D(PSGCOPY) W !!,"You cannot copy the order at this time" D PAUSE^VALM1 Q
I PSGORD["P" W !!,"You cannot copy this "_$S($G(PSGSTAT)]"":PSGSTAT,1:"PENDING IV")_" order." D PAUSE^VALM1 Q
I PSGORD["V" D Q
.I $G(PSIVCOPY) W !!,"You cannot copy the order at this time" D PAUSE^VALM1 Q
.S PSJOCFG="COPY IV"
.D COPY^PSIVOD(PSGP,PSGORD) K PSJOCFG Q
Q:'$$HIDDEN^PSJLMUTL("COPY")
D ^PSJHVARS
I $P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,4)="D",'$P($G(^(4)),"^",3) W !!,"Nurse verified orders with a priority of DONE may not be Copied." D PAUSE^VALM1 Q
S PSJOCFG="COPY UD"
S PSGOEAV=$P(PSJSYSP0,U,9)&PSJSYSU
S PSGCOPY=1,ANQX=0
D FULL^VALM1,^PSGOD
;/RBN Begin modifications PSJ*5.0*327
I $G(ANQX) K PSGCOPY Q
;/RBN End modifications PSJ*5.0*327
S VALMBCK="R"
K PSGCOPY,PSJOCFG
S PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD) ; resets PSGACT after copy
I $G(PSGPXN) N PSGTMPXN S PSGTMPXN=PSGPXN
D RESTORE^PSJHVARS I $G(PSGTMPXN) S PSGPXN=PSGTMPXN
Q
UPDATE ; Refresh array, actions, & display.
D GETUD^PSJLMGUD(DFN,ON),INIT^PSJLMUDE(DFN,ON) S VALMBCK="R"
Q
FINISH ;
D FINISH^PSGOEF,PAUSE^VALM1
Q
LOG(DFN,PSGORD) ;
D FULL^VALM1,ENLM^PSGOEL(DFN,PSGORD),PAUSE^VALM1 S VALMBCK="R"
Q
NEWSEL ;
N PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
K PSGRMVT,PSGRMV,PSGDUR,PSGRF,ND2P1,PSGOROE1
K PSGDRG,PSGDRGN ;*364
;; START NCC REMEDIATION >> 327*RJS ; Freeze header text while processing order actions
S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
;; END NCC REMEDIATION << 327*RJS
S X=$P(XQORNOD(0),"=",2)
S PSGONC=1,PSGLMT=^TMP("PSJPRO",$J,0)
D ENCHK^PSGON I '$O(PSGODDD(0)) S VALMQUIT=1 Q
S PSJLM=1,PSJSEL=0 F S PSJSEL=$O(PSGODDD(PSJSEL)) Q:'PSJSEL F PSJSEL1=1:1:$L(PSGODDD(PSJSEL),",")-1 D
.K PSJOCDSC,PSGDRG N PSGIND,PSGOIND ;*399-IND
.S PSJORD=$G(^TMP("PSJON",$J,+$P(PSGODDD(PSJSEL),",",PSJSEL1))) D:PSJORD=+PSJORD SELECT^PSJOEA
.Q:PSJORD=+PSJORD
.Q:PSJORD=""!($G(Y)<0) Q:('$$LS^PSSLOCK(PSGP,PSJORD)) D
..S PSGORD=""
..S ON=PSJORD
..D DISACTIO(PSGP,PSJORD,$G(PSJPNV)) S:PSJORD["V" PSJORD=ON
..D UNL^PSSLOCK(PSGP,PSJORD)
..I $G(PSJNOL) K PSJNOL I $D(ON),ON'=PSJORD D UNL^PSSLOCK(PSGP,ON)
..Q:$G(Y)<0
I '$G(PSGOEAV),($G(PSJORD)["P"),$G(PSJAGYSV) D
.;RTC 178789
.S ^TMP("PSODAOC",$J,"IP IEN")=PSJORD
.D SETOC^PSJNEWOC(PSJORD)
.K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J),PSJAGYSV
S VALMBCK="Q"
K PSJLM,PSJOCDSC
;*P319
K PSJCLAPP,P("APPT"),P("CLIN"),PSJCMO,PSJCM01,P("PON")
Q
HOLDHDR ; Freeze header text while processing order actions
I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
Q
LOCKERR ;
W !!,$C(7),"You are entering or editing an Inpatient Medication order in another session.",!,"Only one order entry/edit session is allowed for a user at a time.",!! N DIR S DIR(0)="E" D ^DIR
Q
FLAG(DFN,PSJORD) ;Flag order through CPRS entry point.
N ORIFN,NODE0
S NODE0=$S(PSJORD["V":$G(^PS(55,DFN,"IV",+PSJORD,0)),PSJORD["U":$G(^PS(55,DFN,5,+PSJORD,0)),1:^PS(53.1,+PSJORD,0))
S ORIFN=$P(NODE0,"^",21)
D EN1^ORCFLAG(ORIFN)
D PAUSE^VALM1
Q
COMPLEX(DFN,ON) ;
N NDP2,COM
S NDP2=$S(ON["P":$G(^PS(53.1,+ON,.2)),ON["U":$G(^PS(55,DFN,5,+ON,.2)),ON["V":$G(^PS(55,DFN,"IV",+ON,.2)),1:"")
S COM=$P(NDP2,"^",8) I COM Q 1
Q 0
CLOZSND ; SEND CLOZAPINE OVERRIDE MESSAGE AND ORDER TO HINES DB
; START NCC REMEDIATION >> 327*RJS
D PSJFILE^PSJCLOZ(DFN),INPSND^YSCLTST5
; END NCC REMEDIATION << 327*RJS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJOE 13327 printed Sep 23, 2025@19:44:15 Page 2
PSJOE ;BIR/MLM - INPATIENT ORDER ENTRY ;Jan 14, 2021@10:49:31
+1 ;;5.0;INPATIENT MEDICATIONS;**7,26,29,33,42,50,56,72,58,85,95,80,110,111,133,140,151,149,181,252,281,315,256,344,327,319,411,364,399,407**;16 DEC 97;Build 26
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 via DBIA 2191
+4 ; Reference to EN^VALM via DBIA 10118
+5 ; Reference to FULL^VALM1 via DBIA 10116
+6 ; Reference to PAUSE^VALM1 via DBIA 10116
+7 ; Reference to ^PSSLOCK via DBIA 2789
+8 ; Reference to ^DPT( via DBIA 10035
+9 ; Reference to ^ORCFLAG via DBIA #3620
+10 ; Reference to ^SDAMA203 via DBIA #4133
+11 ; Reference to ^TMP("PSODAOC" via DBIA 6071
+12 ;
+13 ;*364 - add Hazardous Handle & Dispose flags alert message.
+14 ;*407 - Prevent access to PSJ OE when IV Room isn't built properly
+15 ;
EN ; Start Inpatient LM OE
+1 NEW PSJLK,PSJNEWOE,PSJLMCON,PSJPROT,XQORS,VALMEVL
DO ENCV^PSGSETU
DO ^PSIVXU
+2 ; I $D(XQUIT) K XQUIT G DONE ; PSJ*407
+3 ; PSJ*407
IF ($DATA(XQUIT)!$GET(DONE))
KILL XQUIT
GOTO DONE
+4 KILL PSGVBY,PSJPR
SET (PSJOL,PSJACOK,PSGOP,PSGNEF,PSGOEAV,PSGPXN)=""
LOCK +^PS(53.45,PSJSYSP):1
IF '$TEST
DO LOCKERR^PSJOE
GOTO DONE^PSJOE
+5 FOR
SET (PSJLMCON,PSGPTMP)=0
DO ^PSJP
DO HK
if PSGP'>0
QUIT
SET PSJPROT=3
SET DFN=PSGP
DO ^PSJAC
Begin DoDot:1
+6 KILL ^TMP("PSJ",$JOB)
+7 SET PSJLK=$$L^PSSLOCK(PSGP,1)
IF 'PSJLK
WRITE !,$CHAR(7),$PIECE(PSJLK,U,2)
QUIT
+8 KILL PSJLMPRO
DO EN^VALM("PSJ LM BRIEF PATIENT INFO")
+9 NEW NXTPT
SET NXTPT=0
FOR
if $GET(NXTPT)
QUIT
Begin DoDot:2
+10 KILL PSGRDTX
+11 IF $GET(PSJLMCON)!$GET(PSJNEWOE)
Begin DoDot:3
+12 SET PSJOL=$SELECT(",S,L,"[(","_$GET(PSJOL)_","):PSJOL,1:"S")
+13 SET PSJLMPRO=1
SET PSJLMCON=1
SET PSJNEWOE=0
DO EN^VALM("PSJ LM OE")
End DoDot:3
+14 IF $GET(PSJNEWOE)!($GET(VALMBCK)="Q")
SET PSJNEWOE=0
QUIT
+15 IF $GET(PSJLMCON)&$GET(PSJLMPRO)&'$DATA(^TMP("PSJ",$JOB))
Begin DoDot:3
+16 SET PSJLMCON=0
SET PSJLMPRO=0
DO EN^VALM("PSJ LM BRIEF PATIENT INFO")
+17 IF $GET(PSJNEWOE)
SET NXTPT=0
QUIT
+18 SET NXTPT=1
End DoDot:3
QUIT
+19 SET NXTPT=1
SET PSJNEWOE=0
End DoDot:2
+20 SET PSJOL="S"
+21 IF $GET(PSGPXN)
IF $PIECE(PSJSYSW0,U,29)]""!($GET(PSJCOM))
SET PSGPXPT=PSGP
Begin DoDot:2
+22 NEW DFN,PSGP,PSJPXDP
+23 IF $PIECE(PSJSYSW0,U,29)=""
SET PSJPDXP=1
Begin DoDot:3
+24 ;N IO,ION,IOS D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
+25 DO HOME^%ZIS
SET $PIECE(PSJSYSW0,U,29)=+$GET(IOS)
End DoDot:3
+26 SET (PSGP,DFN)=PSGPXPT
DO ^PSGPER
if $GET(PSJPDXP)
SET $PIECE(PSJSYSW0,U,29)=""
KILL PSJPDXP
End DoDot:2
KILL PSGPXPT
SET PSGPXN=0
+27 DO ENCV^PSGSETU
DO ^PSIVXU
End DoDot:1
IF PSJLK
DO UL^PSSLOCK(PSGP)
+28 KILL PSJLMPRO,^TMP("PSJPRO",$JOB),^TMP("PSJ",$JOB),^TMP("PSJON",$JOB)
DONE ;
+1 ; -- RTC 198753 - correct typo - r PSJALGSV w PSJAGYSV
+2 KILL PSJAGYSV,PSJEXCPT,PSJOCER,^TMP($JOB,"PSJPRE"),^TMP("PSODAOC",$JOB),^TMP("PSJDAOC",$JOB)
+3 KILL AC,ACTION,D1,D2,MI,N,ON,P3,PNOW,PSIVAT,PSIVLN,PSIVSTR
LOCK -^PS(53.45,PSJSYSP)
+4 KILL DA,DRG,NE,PSGCF,PSGCANFL,PSGNEDFD,PSGNEF,PSGNEFD,PSGNEPR,PSGNESD,PSJACOK,PSJOE,PSJOECNT,PSJOEPF,PSJORD,PSGOEA,PSGOEAV,PSGOL,PSGOS,PSGON,PSGOP,PSGORD,PSGS0XT,PSGS0Y,RCT,ST,WD,XREF,Z,PSJIVORF,PSJIVPCL
+5 KILL PSGOEORF,PSIVREA,PSJOPC,PSJORL,PSJORPCL,PSJORTOI,RF,WSCHADM,PSJLM,PSJCT
+6 KILL DIU,DRGI,FLAG,FQC,ND2,PRI,PSGOE,PSGPRI,PSGSDN,PSGOEDMR,PSGOEPR,PSGPTS,PSGTOL,PSGTOO,PSGUOW,PSJIVOF,PSJOCNT,PSJON,PSJORQF,PSJORTOU,PSJORVP
+7 ;*315
KILL PSIVENO,PSGRMV,PSGRMVT,PSGDUR,PSGRF,ND2P1
+8 if $GET(PSGPXN)
GOTO ^PSGPER1
DO ENIVKV^PSGSETU
+9 QUIT
HK ; Housekeeping (a nice COBOL term)
+1 IF PSGOP
IF PSGOP'=PSGP
Begin DoDot:1
+2 NEW PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR
SET DFN=PSGOP
+3 DO INP^VADPT
SET PSJPWD=+VAIN(4)
IF PSJPWD
SET PSJACPF=10
DO WP^PSJAC
if $PIECE(PSJSYSL,"^",2)]""
DO ENQL^PSGLW
End DoDot:1
+4 if PSGP<0
QUIT
+5 SET (DFN,PSGOP)=PSGP
SET X=""
+6 QUIT
SELECT ; Select order from list
+1 ;Variable PSJOCDSC is used in Complex order dosing checks
+2 NEW PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV
KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB),PSJSTARI,^TMP("PSODAOC",$JOB),^TMP("PSJDAOC",$JOB)
+3 ;*315
KILL PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1
+4 SET PSGONC=1
SET PSGLMT=^TMP("PSJPRO",$JOB,0)
DO ENASR^PSGON
+5 IF "^"[X
SET VALMQUIT=1
QUIT
+6 SET PSJLM=1
SET PSJSEL=0
FOR
SET PSJSEL=$ORDER(PSGODDD(PSJSEL))
if 'PSJSEL!($GET(Y)<0)
QUIT
FOR PSJSEL1=1:1:$LENGTH(PSGODDD(PSJSEL),",")-1
Begin DoDot:1
+7 KILL PSJOCDSC
+8 SET PSJORD=$GET(^TMP("PSJON",$JOB,+$PIECE(PSGODDD(PSJSEL),",",PSJSEL1)))
if PSJORD=+PSJORD
DO SELECT^PSJOEA
if PSJORD=""!($GET(Y)<0)
QUIT
if PSJORD=+PSJORD
QUIT
Begin DoDot:2
+9 if ('$$LS^PSSLOCK(PSGP,PSJORD))
QUIT
+10 if PSJORD=+PSJORD
QUIT
+11 SET PSGORD=""
+12 DO DISACTIO(PSGP,PSJORD,"")
if PSJORD["V"
SET PSJORD=ON
+13 DO UNL^PSSLOCK(PSGP,PSJORD)
if $GET(Y)<0
QUIT
End DoDot:2
End DoDot:1
+14 SET VALMBCK="Q"
+15 KILL PSJLM,PSJOCDSC
+16 QUIT
DISACTIO(DFN,PSJORD,PSJPNV) ; Display UD order and allow actions.
+1 ; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
+2 ; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
+3 ; PSJDSVFY - Flag if non-vf order was edited
+4 ; PSJENHOC=1 if DI,DT were display. This will be used by dosing OC to check if error messages should display or not
+5 ; PSJAGYSV=1 If UD was edited
+6 ;N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSJAGYSV
+7 NEW PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSIVENO,PSJBACK
+8 ;*315
KILL PSGDUR,PSGRMVT,PSGRMV,PSGRF,ND2P1
+9 ;*256
KILL PSJEXCPT("PROSPECTIVE")
+10 DO OLDCOM^PSJOE0(DFN,PSJORD)
+11 SET PSGP=DFN
DO ENIV^PSJAC
IF PSJORD["V"
DO EN^PSJLIORD(DFN,PSJORD)
QUIT
+12 DO GETUD^PSJLMGUD(DFN,PSJORD)
+13 SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
+14 if $GET(PSJTUD)
SET PSGPD=$GET(PSJCOI)
SET PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
+15 KILL PSGOENG
IF '$DATA(PSGPRF)
Begin DoDot:1
+16 IF PSJORD["U"
LOCK +^PS(55,PSGP,5,+PSJORD):1
IF '$TEST
SET PSGOENG=1
+17 IF PSJORD["P"
LOCK +^PS(53.1,+PSJORD):1
IF '$TEST
SET PSGOENG=1
+18 IF $GET(PSGOENG)
WRITE !,"This order is being edited by another terminal.",!
SET PSGOENG=1
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
End DoDot:1
if $GET(PSGOENG)
QUIT
+19 SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
+20 IF PSJORD["P"
SET PSJXX1=$GET(^PS(53.1,+PSJORD,0))
IF PSGP'=$PIECE(PSJXX1,U,15)!(DFN'=$PIECE(PSJXX1,U,15))
LOCK -^PS(53.1,+PSJORD)
QUIT
+21 IF PSJORD["P"
Begin DoDot:1
+22 ;p344
if $PIECE($GET(PSJXX1),U,4)="U"
KILL PSIVFLG
+23 IF $PIECE(PSJXX1,U,9)="N"
IF ($PIECE(PSJXX1,U,4)'="U")
Begin DoDot:2
+24 SET P("PON")=PSJORD
SET PSIVFLG=1
+25 NEW ON
SET ON=PSJORD
DO VF^PSIVORC2
End DoDot:2
QUIT
+26 IF $PIECE(PSJXX1,U,9)="P"
Begin DoDot:2
+27 if $GET(PSJTUD)
SET $PIECE(PSJXX1,U,4)="U"
+28 IF $PIECE(PSJXX1,U,4)="U"
Begin DoDot:3
+29 NEW VAIP
SET CLINIC=$GET(^PS(53.1,+PSJORD,"DSS"))
SET APPT=$PIECE(CLINIC,"^",2)
SET CLINIC=$PIECE(CLINIC,"^")
IF $$PATCH^XPDUTL("SD*5.3*285")
SET PSJBACK=$$SDIMO^SDAMA203(CLINIC,DFN)
IF PSJBACK'<-1
QUIT
+30 if 'PSJPDD
QUIT
WRITE !!,"Cannot process an Out-patient Unit Dose order for ",$PIECE($GET(^DPT(+PSGP,0)),U)
DO PAUSE^VALM1
SET PSJIVFLG=1
End DoDot:3
if $GET(PSJIVFLG)
QUIT
+31 NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
+32 DO REQDT^PSJLIVMD(PSJORD)
+33 IF $PIECE(PSJXX1,U,4)="U"
IF ($GET(PSGSCH)="")
WRITE !!,"Invalid schedule, can't finish this order"
DO PAUSE^VALM1
QUIT
+34 IF $PIECE(PSJXX1,U,4)="U"
NEW PSJLM,PSJOCFG
SET PSJLM=1
SET PSGORD=PSJORD
SET PSJOCFG="FN UD"
DO START^PSGOEF
DO ENSFE^PSGOEE0(PSGP,PSGORD)
if $GET(PSJTUD)
SET PSJOCFG="FN UD"
DO @$SELECT($GET(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING EDIT"")")
KILL PSJOCFG
QUIT
+35 IF $PIECE(PSJXX1,U,4)'="U"
IF PSGP=$PIECE(PSJXX1,U,15)
IF DFN=$PIECE(PSJXX1,U,15)
SET PSJLYN=PSJORD
SET PSJOCFG="FN IV"
DO EN^PSJLIFN
SET PSJIVFLG=1
KILL PSJLYN,PSJMAI,PSJOCFG
End DoDot:2
QUIT
End DoDot:1
SET PSJXX1=$PIECE($GET(^PS(53.1,+PSJORD,0)),U,9)
IF $SELECT($GET(PSJIVFLG):1,$GET(Y)<0:1,"PADE"[PSJXX1:1,1:0)
LOCK -^PS(53.1,+PSJORD)
QUIT
+36 IF $GET(PSIVFLG)
KILL PSIVFLG
QUIT
+37 SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
SET PSGOEEF=0
DO GETUD^PSJLMGUD(PSGP,PSJORD)
DO ENSFE^PSGOEE0(PSGP,PSJORD)
DO EN^VALM("PSJ LM UD ACTION")
+38 IF PSJORD["P"
LOCK -^PS(53.1,+PSJORD)
+39 IF PSJORD["U"
LOCK -^PS(55,PSGP,5,+PSJORD)
+40 ;Send SN to CPRS if auto-verify OFF and Order Set Entry and no 21st piece
+41 SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
+42 IF $DATA(PSGOES)
IF 'PSGOEAV
IF $DATA(PSGORD)
IF PSGORD["P"
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",21)']""
DO ORSET^PSGOETO1
+43 ;Store allergy for order set /w auto vf
IF $GET(PSGOEAV)
IF ($GET(PSGOES)=1)
DO SETOC
+44 IF '$GET(PSGOEAV)
IF ($GET(PSJORD)["P")
IF $SELECT($GET(PSJAGYSV):1,($GET(PSJOCFG)="NEW UD"):1,1:0)
DO SETOC
+45 ; -- RTC 236646
+46 KILL ^TMP("PSODAOC",$JOB,"ALLERGY")
+47 DO UNL^PSSLOCK(PSGP,PSJORD)
+48 QUIT
SETOC ;
+1 ;RTC 178789
+2 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSJORD
+3 DO SETOC^PSJNEWOC(PSJORD)
+4 KILL ^TMP("PSODAOC",$JOB),^TMP("PSJDAOC",$JOB),PSJAGYSV,PSJOCFG
+5 QUIT
EDIT(PSGP,PSGORD,PROMPT) ;
+1 NEW PSJOP,ANQX,PSGEDT
+2 SET (ANQX,PSJOP)=0
SET PSGEDT=1
+3 SET PSJOP=+Y(1)
+4 SET PSJOP=$SELECT(PSJOP=9:0,PSJOP=11:0,1:1)
+5 ;/RBN Begin modification for NCC moved code to ACT^PSGOEE
+6 IF "DE"[$$GTSTATUS(PSGP,PSGORD)
WRITE !,"This order may not be edited."
DO PAUSE^VALM1
QUIT
+7 IF PSGACT'["E"
WRITE !,"This order may not be edited."
DO PAUSE^VALM1
QUIT
+8 NEW PSJEDITO
SET PSJEDITO=1
+9 ;Flag to store allergy data in 100.05.
SET PSJAGYSV=1
+10 SET PSGNEDFD=""
DO HOLDHDR
DO @$SELECT('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON")
IF 'Y
DO ABORT^PSGOEE
QUIT
+11 IF PSGORD["P"
DO ENF^PSGOEE
QUIT
+12 DO ACT^PSGOEE
+13 QUIT
RENEW(PSGP,PSGORD) ;
+1 ;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD using this flag to not display drug error.
+2 ;/RJS Begin modifications for PSJ*5.0*327
+3 IF $$ISCLOZ^PSJCLOZ(,,PSGP,+PSGORD)
Begin DoDot:1
+4 WRITE !,"Clozapine orders cannot be renewed."
+5 WRITE !,"No order entered!"
+6 DO PAUSE^VALM1
End DoDot:1
QUIT
+7 ;/RJS End modifications for PSJ*5.0*327
+8 NEW PSJOCFG
+9 SET PSJOCFG="RENEW UD"
+10 DO HOLDHDR
+11 IF 'PSJSYSU
IF $PIECE($GET(^PS(55,PSGP,5,+PSGORD,4)),U,15)
IF $PIECE($GET(^(4)),U,16)
WRITE !!,"This order is already marked for renewal!"
DO PAUSE^VALM1
SET VALMBCK="R"
QUIT
+12 IF 'PSGRRF
DO ^PSGOER
KILL PSJOCFG
QUIT
+13 DO ^PSGOERI
+14 KILL PSJOCFG
+15 QUIT
GTSTATUS(DFN,ON) ;
+1 IF ON["P"
QUIT $PIECE($GET(^PS(53.1,+ON,0)),U,9)
+2 IF ON["U"
QUIT $PIECE($GET(^PS(55,DFN,5,+ON,0)),U,9)
+3 QUIT $PIECE($GET(^PS(55,DFN,"IV",+ON,0)),U,17)
DC(DFN,PSJORD) ; DC IV, UD, or pending orders.
+1 DO HOLDHDR
+2 SET X=$$GTSTATUS(DFN,PSJORD)
IF X="D"!(X="DE")!(X="R")
WRITE !,$SELECT(X="R":"This order has a pending renewal and cannot be DISCONTINUED.",1:"This order has already been DISCONTINUED.")
DO PAUSE^VALM1
QUIT
+3 ;,GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN,PSJORD) S VALMBCK="Q"
DO ENO^PSGOEC(DFN,PSJORD)
+4 SET VALMBCK="Q"
+5 QUIT
HOLD(DFN,PSJORD) ; Change order's status from ACTIVE<->HOLD
+1 DO HOLDHDR
+2 IF PSJORD["V"
DO H^PSIVOPT(DFN,PSJORD,P(17),P(3))
+3 IF PSJORD'["V"
DO H^PSGOE1(DFN,PSJORD)
+4 DO GETUD^PSJLMGUD(DFN,PSJORD)
DO INIT^PSJLMUDE(DFN,PSJORD)
SET PSGACT=$$ENACTION^PSGOE1(DFN,PSJORD)
SET VALMBCK="R"
+5 QUIT
COPY(PSGP,PSGORD) ; Copy an order (does not discontinue original order)
+1 NEW PSJOCFG
+2 ; PSJ*5*327 - disallow copy for clozapine
+3 IF $DATA(^PS(55,PSGP,5,+PSGORD,"SAND"))
WRITE !!,"You cannot copy a clozapine order."
DO PAUSE^VALM1
QUIT
+4 IF $DATA(PSGCOPY)
WRITE !!,"You cannot copy the order at this time"
DO PAUSE^VALM1
QUIT
+5 IF PSGORD["P"
WRITE !!,"You cannot copy this "_$SELECT($GET(PSGSTAT)]"":PSGSTAT,1:"PENDING IV")_" order."
DO PAUSE^VALM1
QUIT
+6 IF PSGORD["V"
Begin DoDot:1
+7 IF $GET(PSIVCOPY)
WRITE !!,"You cannot copy the order at this time"
DO PAUSE^VALM1
QUIT
+8 SET PSJOCFG="COPY IV"
+9 DO COPY^PSIVOD(PSGP,PSGORD)
KILL PSJOCFG
QUIT
End DoDot:1
QUIT
+10 if '$$HIDDEN^PSJLMUTL("COPY")
QUIT
+11 DO ^PSJHVARS
+12 IF $PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),U,4)="D"
IF '$PIECE($GET(^(4)),"^",3)
WRITE !!,"Nurse verified orders with a priority of DONE may not be Copied."
DO PAUSE^VALM1
QUIT
+13 SET PSJOCFG="COPY UD"
+14 SET PSGOEAV=$PIECE(PSJSYSP0,U,9)&PSJSYSU
+15 SET PSGCOPY=1
SET ANQX=0
+16 DO FULL^VALM1
DO ^PSGOD
+17 ;/RBN Begin modifications PSJ*5.0*327
+18 IF $GET(ANQX)
KILL PSGCOPY
QUIT
+19 ;/RBN End modifications PSJ*5.0*327
+20 SET VALMBCK="R"
+21 KILL PSGCOPY,PSJOCFG
+22 ; resets PSGACT after copy
SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD)
+23 IF $GET(PSGPXN)
NEW PSGTMPXN
SET PSGTMPXN=PSGPXN
+24 DO RESTORE^PSJHVARS
IF $GET(PSGTMPXN)
SET PSGPXN=PSGTMPXN
+25 QUIT
UPDATE ; Refresh array, actions, & display.
+1 DO GETUD^PSJLMGUD(DFN,ON)
DO INIT^PSJLMUDE(DFN,ON)
SET VALMBCK="R"
+2 QUIT
FINISH ;
+1 DO FINISH^PSGOEF
DO PAUSE^VALM1
+2 QUIT
LOG(DFN,PSGORD) ;
+1 DO FULL^VALM1
DO ENLM^PSGOEL(DFN,PSGORD)
DO PAUSE^VALM1
SET VALMBCK="R"
+2 QUIT
NEWSEL ;
+1 NEW PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV
KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB),^TMP("PSODAOC",$JOB),^TMP("PSJDAOC",$JOB)
+2 KILL PSGRMVT,PSGRMV,PSGDUR,PSGRF,ND2P1,PSGOROE1
+3 ;*364
KILL PSGDRG,PSGDRGN
+4 ;; START NCC REMEDIATION >> 327*RJS ; Freeze header text while processing order actions
+5 SET IOTM=VALM("TM")
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+6 ;; END NCC REMEDIATION << 327*RJS
+7 SET X=$PIECE(XQORNOD(0),"=",2)
+8 SET PSGONC=1
SET PSGLMT=^TMP("PSJPRO",$JOB,0)
+9 DO ENCHK^PSGON
IF '$ORDER(PSGODDD(0))
SET VALMQUIT=1
QUIT
+10 SET PSJLM=1
SET PSJSEL=0
FOR
SET PSJSEL=$ORDER(PSGODDD(PSJSEL))
if 'PSJSEL
QUIT
FOR PSJSEL1=1:1:$LENGTH(PSGODDD(PSJSEL),",")-1
Begin DoDot:1
+11 ;*399-IND
KILL PSJOCDSC,PSGDRG
NEW PSGIND,PSGOIND
+12 SET PSJORD=$GET(^TMP("PSJON",$JOB,+$PIECE(PSGODDD(PSJSEL),",",PSJSEL1)))
if PSJORD=+PSJORD
DO SELECT^PSJOEA
+13 if PSJORD=+PSJORD
QUIT
+14 if PSJORD=""!($GET(Y)<0)
QUIT
if ('$$LS^PSSLOCK(PSGP,PSJORD))
QUIT
Begin DoDot:2
+15 SET PSGORD=""
+16 SET ON=PSJORD
+17 DO DISACTIO(PSGP,PSJORD,$GET(PSJPNV))
if PSJORD["V"
SET PSJORD=ON
+18 DO UNL^PSSLOCK(PSGP,PSJORD)
+19 IF $GET(PSJNOL)
KILL PSJNOL
IF $DATA(ON)
IF ON'=PSJORD
DO UNL^PSSLOCK(PSGP,ON)
+20 if $GET(Y)<0
QUIT
End DoDot:2
End DoDot:1
+21 IF '$GET(PSGOEAV)
IF ($GET(PSJORD)["P")
IF $GET(PSJAGYSV)
Begin DoDot:1
+22 ;RTC 178789
+23 SET ^TMP("PSODAOC",$JOB,"IP IEN")=PSJORD
+24 DO SETOC^PSJNEWOC(PSJORD)
+25 KILL ^TMP("PSODAOC",$JOB),^TMP("PSJDAOC",$JOB),PSJAGYSV
End DoDot:1
+26 SET VALMBCK="Q"
+27 KILL PSJLM,PSJOCDSC
+28 ;*P319
+29 KILL PSJCLAPP,P("APPT"),P("CLIN"),PSJCMO,PSJCM01,P("PON")
+30 QUIT
HOLDHDR ; Freeze header text while processing order actions
+1 IF $DATA(VALM("TM"))
SET IOTM=VALM("TM")
SET IOBM=IOSL
WRITE IOSC
WRITE @IOSTBM
WRITE IORC
+2 QUIT
LOCKERR ;
+1 WRITE !!,$CHAR(7),"You are entering or editing an Inpatient Medication order in another session.",!,"Only one order entry/edit session is allowed for a user at a time.",!!
NEW DIR
SET DIR(0)="E"
DO ^DIR
+2 QUIT
FLAG(DFN,PSJORD) ;Flag order through CPRS entry point.
+1 NEW ORIFN,NODE0
+2 SET NODE0=$SELECT(PSJORD["V":$GET(^PS(55,DFN,"IV",+PSJORD,0)),PSJORD["U":$GET(^PS(55,DFN,5,+PSJORD,0)),1:^PS(53.1,+PSJORD,0))
+3 SET ORIFN=$PIECE(NODE0,"^",21)
+4 DO EN1^ORCFLAG(ORIFN)
+5 DO PAUSE^VALM1
+6 QUIT
COMPLEX(DFN,ON) ;
+1 NEW NDP2,COM
+2 SET NDP2=$SELECT(ON["P":$GET(^PS(53.1,+ON,.2)),ON["U":$GET(^PS(55,DFN,5,+ON,.2)),ON["V":$GET(^PS(55,DFN,"IV",+ON,.2)),1:"")
+3 SET COM=$PIECE(NDP2,"^",8)
IF COM
QUIT 1
+4 QUIT 0
CLOZSND ; SEND CLOZAPINE OVERRIDE MESSAGE AND ORDER TO HINES DB
+1 ; START NCC REMEDIATION >> 327*RJS
+2 DO PSJFILE^PSJCLOZ(DFN)
DO INPSND^YSCLTST5
+3 ; END NCC REMEDIATION << 327*RJS
+4 QUIT
