- 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 Jan 18, 2025@03:09:20 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