PSJOEA ;BIR/MLM-INPATIENT ORDER ENTRY ;12 June 2019 09:31:53
;;5.0;INPATIENT MEDICATIONS;**110,127,133,167,171,254,315,367,327**;16 DEC 97;Build 114
;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 ^PSSLOCK via DBIA #2789
; Reference to ^DPT via DBIA #10035
; Reference to SDIMO^SDAMA203 via DBIA #4133
;
LOCK(DFN,PSJORD) ; Check if the order is locked
N Q S Q=0
I PSJORD=+PSJORD N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO S Q=$$LS^PSSLOCK(DFN,PSJO_"P") I 'Q Q
I Q Q 1
Q 0
;
SELECT ;
N PSJCLIN,O
Q:PSJORD=""!($G(Y)<0) Q:('$$LOCK^PSJOEA(PSGP,PSJORD))
N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO D
.S PSGORD="" S ON=PSJO_"P"
.D DISACTIO(PSGP,PSJO_"P",$G(PSJPNV)) S:$G(PSJO)["V" O=ON
K PSGCOMP,PSGFLG ; CLEAN UP VARIABLE FOR COMPLEX ORDER MESSAGE RJS*327
I $D(^TMP("PSJCOM",$J)) D CHK^PSJOEA1
S:'$G(PSGP) PSGP=$G(DFN)
N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO D
.L -^PS(53.1,PSJO) ; p367
.D UNL^PSSLOCK(PSGP,PSJO_"P") ; Q:$G(Y)<0 p367 commented quit out
; p367 Unlock complex orders (file 100) after verification of all child orders in the complex order.
N PSJO S PSJO=0 F S PSJO=$O(^TMP("PSJCVFY",$J,PSJO)) Q:'PSJO D
.N PSJIDX S PSJIDX=$G(^TMP("PSJCVFY",$J,PSJO))
.D UNL^PSSLOCK(PSGP,PSJIDX) K ^TMP("PSJCVFY",$J,PSJO),PSJIDX
D DONE
Q
;
DISACTIO(DFN,PSJORD,PSJPNV) ; Display UD order and allow actions.
; DFN - Patient IEN
; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJAPPT
Q:PSJORD'["P"
Q:$G(PSJCLIN)=-2
S PSGP=DFN D ENIV^PSJAC
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["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)) Q ;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) Q ;L -^PS(53.1,+PSJORD) Q
.I $P(PSJXX1,U,9)="N",($P(PSJXX1,U,4)'="U") D Q
.. S P("PON")=PSJORD,PSIVFLG=1
.. D GT531^PSIVORFA(+PSGP,PSJORD),VF^PSIVORC2
.I $P(PSJXX1,U,9)="P" D Q
..S:$G(PSJTUD) $P(PSJXX1,U,4)="U"
..N VAIP S PSJCLIN=$G(^PS(53.1,+PSJORD,"DSS")),PSJAPPT=$P(PSJCLIN,"^",2),PSJCLIN=$P(PSJCLIN,"^")
..I $P(PSJXX1,U,4)="U",(+PSJPDD) D Q:(PSJCLIN=-2)
...I $$PATCH^XPDUTL("SD*5.3*285"),($$SDIMO^SDAMA203(PSJCLIN,DFN)>-1) Q
...W !!,"Cannot process an Out-patient Unit Dose order for ",$P($G(^DPT(+PSGP,0)),U) D PAUSE^VALM1 S PSJIVFLG=1,PSJCLIN=-2
..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 S PSJLM=1,PSGORD=PSJORD D START^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),@$S($G(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING EDIT"")") D Q
...K ^TMP("PSJINTER",$J),PSJOVR
..I $P(PSJXX1,U,4)'="U",PSGP=$P(PSJXX1,U,15),DFN=$P(PSJXX1,U,15) S PSJLYN=PSJORD D EN^PSJLIFN S PSJIVFLG=1 K PSJLYN,PSJMAI
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")
;Send SN to CPRS if autoverify OFF and Order Set Entry and no 21st piece
I $D(PSGOES),'PSGOEAV,$D(PSGORD),PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),"^",21)']"" D ORSET^PSGOETO1
Q
;
ACTLOG(PSGORDP,DFN,PSGORD) ;Store 53.1 activity log in local array to be moved to 55
;PSGORDP: IEN from 53.1
;PSGORD : IEN from 55
NEW PSGX,PSGXDA,PSGAL531,Q,QQ
F PSGX=0:0 S PSGX=$O(^PS(53.1,+PSGORDP,"A",PSGX)) Q:'PSGX D
. S PSGAL531=$G(^PS(53.1,+PSGORDP,"A",PSGX,0))
. S QQ=$G(^PS(55,DFN,5,+PSGORD,9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,U,3)+1:1 I '$D(^(Q)) S $P(QQ,U,3,4)=Q_U_Q,^(0)=QQ,PSGXDA=Q Q
. S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
Q
;
UD ;
N DA,DR,DIE,PSJCMPDA D ENGNA^PSGOETO S $P(^TMP("PSJCOM",$J,PSJO,0),"^",26)=DA_"U",$P(^TMP("PSJCOM2",$J,PSJO,0),"^")=DA,$P(^(0),"^",18)=DA S PSJCMPDA=DA
M ^PS(55,PSGP,5,DA)=^TMP("PSJCOM2",$J,+PSJO) M ^PS(53.1,+PSJO)=^TMP("PSJCOM",$J,+PSJO) D EN1^PSJHL2(PSGP,"OD",+PSJO_"P") S PSJNOO=$P(^TMP("PSJCOM2",$J,+PSJO,.2),U,3) D EN1^PSJHL2(PSGP,"SN",+PSJCMPDA_"U")
N PSGPDRG,PSGST,PSGNESD,PSGNEFD,ND2,ND2P1
S PSGPDRG=$P($G(^PS(55,PSGP,5,PSJCMPDA,.2)),"^"),PSGST=$P($G(^PS(55,PSGP,5,PSJCMPDA,0)),"^",7)
S ND2=$G(^PS(55,PSGP,5,PSJCMPDA,2)),PSGNESD=$P(ND2,"^",2),PSGNEFD=$P(ND2,"^",4) D CRA^PSGOETO
S ND2P1=$G(^PS(55,PSGP,5,PSJCMPDA,2)),PSGRMVT=$P(ND2P1,"^",2) ;*315
K ^PS(53.1,"ACX",PSJORD,PSJO) K PSJPREX
I $G(PSJCMPDA) D CMPLX2^PSJCOM1(PSGP,PSJORD,+PSJCMPDA_"U") I $G(PSGPXN) S PSJPREX=1
Q
IV ;
K ON55 I $P($G(^PS(53.1,+PSJO,0)),"^",24)="R",$P($G(^PS(53.1,+PSJO,0)),"^",25) S ON55=$P(^PS(53.1,+PSJO,0),"^",25)
I '$G(ON55) D NEW55^PSIVORFB
S $P(^TMP("PSJCOM",$J,PSJO,0),"^",26)=ON55,$P(^TMP("PSJCOM2",$J,PSJO,0),"^")=+ON55
S $P(^TMP("PSJCOM2",$J,PSJO,2),U,5)=PSJO_"P",$P(^TMP("PSJCOM",$J,PSJO,0),U,26)=ON55
M ^PS(55,DFN,"IV",+ON55)=^TMP("PSJCOM2",$J,+PSJO) M ^PS(53.1,+PSJO)=^TMP("PSJCOM",$J,+PSJO) D EN1^PSJHL2(PSGP,"OD",+PSJO_"P") S P("NAT")=$P(^TMP("PSJCOM2",$J,+PSJO,.2),U,5) D EN1^PSJHL2(PSGP,"SN",ON55)
K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK K DA,DIK
K ^PS(53.1,"ACX",PSJORD,PSJO)
Q
;
DONE ; Clean up
K PSGPD,PSGPDN,PSGSCH,PSIVACT,PSJNOO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJOEA 5881 printed Sep 23, 2025@19:44:17 Page 2
PSJOEA ;BIR/MLM-INPATIENT ORDER ENTRY ;12 June 2019 09:31:53
+1 ;;5.0;INPATIENT MEDICATIONS;**110,127,133,167,171,254,315,367,327**;16 DEC 97;Build 114
+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 ^PSSLOCK via DBIA #2789
+6 ; Reference to ^DPT via DBIA #10035
+7 ; Reference to SDIMO^SDAMA203 via DBIA #4133
+8 ;
LOCK(DFN,PSJORD) ; Check if the order is locked
+1 NEW Q
SET Q=0
+2 IF PSJORD=+PSJORD
NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
if 'PSJO
QUIT
SET Q=$$LS^PSSLOCK(DFN,PSJO_"P")
IF 'Q
QUIT
+3 IF Q
QUIT 1
+4 QUIT 0
+5 ;
SELECT ;
+1 NEW PSJCLIN,O
+2 if PSJORD=""!($GET(Y)<0)
QUIT
if ('$$LOCK^PSJOEA(PSGP,PSJORD))
QUIT
+3 NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
if 'PSJO
QUIT
Begin DoDot:1
+4 SET PSGORD=""
SET ON=PSJO_"P"
+5 DO DISACTIO(PSGP,PSJO_"P",$GET(PSJPNV))
if $GET(PSJO)["V"
SET O=ON
End DoDot:1
+6 ; CLEAN UP VARIABLE FOR COMPLEX ORDER MESSAGE RJS*327
KILL PSGCOMP,PSGFLG
+7 IF $DATA(^TMP("PSJCOM",$JOB))
DO CHK^PSJOEA1
+8 if '$GET(PSGP)
SET PSGP=$GET(DFN)
+9 NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
if 'PSJO
QUIT
Begin DoDot:1
+10 ; p367
LOCK -^PS(53.1,PSJO)
+11 ; Q:$G(Y)<0 p367 commented quit out
DO UNL^PSSLOCK(PSGP,PSJO_"P")
End DoDot:1
+12 ; p367 Unlock complex orders (file 100) after verification of all child orders in the complex order.
+13 NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^TMP("PSJCVFY",$JOB,PSJO))
if 'PSJO
QUIT
Begin DoDot:1
+14 NEW PSJIDX
SET PSJIDX=$GET(^TMP("PSJCVFY",$JOB,PSJO))
+15 DO UNL^PSSLOCK(PSGP,PSJIDX)
KILL ^TMP("PSJCVFY",$JOB,PSJO),PSJIDX
End DoDot:1
+16 DO DONE
+17 QUIT
+18 ;
DISACTIO(DFN,PSJORD,PSJPNV) ; Display UD order and allow actions.
+1 ; DFN - Patient IEN
+2 ; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
+3 ; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
+4 NEW PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJAPPT
+5 if PSJORD'["P"
QUIT
+6 if $GET(PSJCLIN)=-2
QUIT
+7 SET PSGP=DFN
DO ENIV^PSJAC
+8 DO GETUD^PSJLMGUD(DFN,PSJORD)
+9 SET PSGOEAV=$PIECE(PSJSYSP0,"^",9)&PSJSYSU
+10 if $GET(PSJTUD)
SET PSGPD=$GET(PSJCOI)
SET PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
+11 KILL PSGOENG
IF '$DATA(PSGPRF)
Begin DoDot:1
+12 IF PSJORD["P"
LOCK +^PS(53.1,+PSJORD):1
IF '$TEST
SET PSGOENG=1
+13 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
+14 SET PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
+15 ;L -^PS(53.1,+PSJORD) Q
IF PSJORD["P"
SET PSJXX1=$GET(^PS(53.1,+PSJORD,0))
IF PSGP'=$PIECE(PSJXX1,U,15)!(DFN'=$PIECE(PSJXX1,U,15))
QUIT
+16 ;L -^PS(53.1,+PSJORD) Q
IF PSJORD["P"
Begin DoDot:1
+17 IF $PIECE(PSJXX1,U,9)="N"
IF ($PIECE(PSJXX1,U,4)'="U")
Begin DoDot:2
+18 SET P("PON")=PSJORD
SET PSIVFLG=1
+19 DO GT531^PSIVORFA(+PSGP,PSJORD)
DO VF^PSIVORC2
End DoDot:2
QUIT
+20 IF $PIECE(PSJXX1,U,9)="P"
Begin DoDot:2
+21 if $GET(PSJTUD)
SET $PIECE(PSJXX1,U,4)="U"
+22 NEW VAIP
SET PSJCLIN=$GET(^PS(53.1,+PSJORD,"DSS"))
SET PSJAPPT=$PIECE(PSJCLIN,"^",2)
SET PSJCLIN=$PIECE(PSJCLIN,"^")
+23 IF $PIECE(PSJXX1,U,4)="U"
IF (+PSJPDD)
Begin DoDot:3
+24 IF $$PATCH^XPDUTL("SD*5.3*285")
IF ($$SDIMO^SDAMA203(PSJCLIN,DFN)>-1)
QUIT
+25 WRITE !!,"Cannot process an Out-patient Unit Dose order for ",$PIECE($GET(^DPT(+PSGP,0)),U)
DO PAUSE^VALM1
SET PSJIVFLG=1
SET PSJCLIN=-2
End DoDot:3
if (PSJCLIN=-2)
QUIT
+26 NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
+27 DO REQDT^PSJLIVMD(PSJORD)
+28 IF $PIECE(PSJXX1,U,4)="U"
IF ($GET(PSGSCH)="")
WRITE !!,"Invalid schedule, can't finish this order"
DO PAUSE^VALM1
QUIT
+29 IF $PIECE(PSJXX1,U,4)="U"
NEW PSJLM
SET PSJLM=1
SET PSGORD=PSJORD
DO START^PSGOEF
DO ENSFE^PSGOEE0(PSGP,PSGORD)
DO @$SELECT($GET(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING EDIT"")")
Begin DoDot:3
+30 KILL ^TMP("PSJINTER",$JOB),PSJOVR
End DoDot:3
QUIT
+31 IF $PIECE(PSJXX1,U,4)'="U"
IF PSGP=$PIECE(PSJXX1,U,15)
IF DFN=$PIECE(PSJXX1,U,15)
SET PSJLYN=PSJORD
DO EN^PSJLIFN
SET PSJIVFLG=1
KILL PSJLYN,PSJMAI
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)
QUIT
+32 IF $GET(PSIVFLG)
KILL PSIVFLG
QUIT
+33 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")
+34 ;Send SN to CPRS if autoverify OFF and Order Set Entry and no 21st piece
+35 IF $DATA(PSGOES)
IF 'PSGOEAV
IF $DATA(PSGORD)
IF PSGORD["P"
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",21)']""
DO ORSET^PSGOETO1
+36 QUIT
+37 ;
ACTLOG(PSGORDP,DFN,PSGORD) ;Store 53.1 activity log in local array to be moved to 55
+1 ;PSGORDP: IEN from 53.1
+2 ;PSGORD : IEN from 55
+3 NEW PSGX,PSGXDA,PSGAL531,Q,QQ
+4 FOR PSGX=0:0
SET PSGX=$ORDER(^PS(53.1,+PSGORDP,"A",PSGX))
if 'PSGX
QUIT
Begin DoDot:1
+5 SET PSGAL531=$GET(^PS(53.1,+PSGORDP,"A",PSGX,0))
+6 SET QQ=$GET(^PS(55,DFN,5,+PSGORD,9,0))
if QQ=""
SET QQ="^55.09D"
FOR Q=$PIECE(QQ,U,3)+1:1
IF '$DATA(^(Q))
SET $PIECE(QQ,U,3,4)=Q_U_Q
SET ^(0)=QQ
SET PSGXDA=Q
QUIT
+7 SET ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
End DoDot:1
+8 QUIT
+9 ;
UD ;
+1 NEW DA,DR,DIE,PSJCMPDA
DO ENGNA^PSGOETO
SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",26)=DA_"U"
SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^")=DA
SET $PIECE(^(0),"^",18)=DA
SET PSJCMPDA=DA
+2 MERGE ^PS(55,PSGP,5,DA)=^TMP("PSJCOM2",$JOB,+PSJO)
MERGE ^PS(53.1,+PSJO)=^TMP("PSJCOM",$JOB,+PSJO)
DO EN1^PSJHL2(PSGP,"OD",+PSJO_"P")
SET PSJNOO=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,.2),U,3)
DO EN1^PSJHL2(PSGP,"SN",+PSJCMPDA_"U")
+3 NEW PSGPDRG,PSGST,PSGNESD,PSGNEFD,ND2,ND2P1
+4 SET PSGPDRG=$PIECE($GET(^PS(55,PSGP,5,PSJCMPDA,.2)),"^")
SET PSGST=$PIECE($GET(^PS(55,PSGP,5,PSJCMPDA,0)),"^",7)
+5 SET ND2=$GET(^PS(55,PSGP,5,PSJCMPDA,2))
SET PSGNESD=$PIECE(ND2,"^",2)
SET PSGNEFD=$PIECE(ND2,"^",4)
DO CRA^PSGOETO
+6 ;*315
SET ND2P1=$GET(^PS(55,PSGP,5,PSJCMPDA,2))
SET PSGRMVT=$PIECE(ND2P1,"^",2)
+7 KILL ^PS(53.1,"ACX",PSJORD,PSJO)
KILL PSJPREX
+8 IF $GET(PSJCMPDA)
DO CMPLX2^PSJCOM1(PSGP,PSJORD,+PSJCMPDA_"U")
IF $GET(PSGPXN)
SET PSJPREX=1
+9 QUIT
IV ;
+1 KILL ON55
IF $PIECE($GET(^PS(53.1,+PSJO,0)),"^",24)="R"
IF $PIECE($GET(^PS(53.1,+PSJO,0)),"^",25)
SET ON55=$PIECE(^PS(53.1,+PSJO,0),"^",25)
+2 IF '$GET(ON55)
DO NEW55^PSIVORFB
+3 SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",26)=ON55
SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^")=+ON55
+4 SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,2),U,5)=PSJO_"P"
SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),U,26)=ON55
+5 MERGE ^PS(55,DFN,"IV",+ON55)=^TMP("PSJCOM2",$JOB,+PSJO)
MERGE ^PS(53.1,+PSJO)=^TMP("PSJCOM",$JOB,+PSJO)
DO EN1^PSJHL2(PSGP,"OD",+PSJO_"P")
SET P("NAT")=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,.2),U,5)
DO EN1^PSJHL2(PSGP,"SN",ON55)
+6 KILL DA,DIK
SET DA(1)=DFN
SET DA=+ON55
SET DIK="^PS(55,"_DA(1)_",""IV"","
SET PSIVACT=1
DO IX^DIK
KILL DA,DIK
+7 KILL ^PS(53.1,"ACX",PSJORD,PSJO)
+8 QUIT
+9 ;
DONE ; Clean up
+1 KILL PSGPD,PSGPDN,PSGSCH,PSIVACT,PSJNOO
+2 QUIT
