PSJOEA2 ;BIR/MLM-INPATIENT ORDER ENTRY ;19-Feb-2014 16:01;DU
;;5.0; INPATIENT MEDICATIONS ;**127,133,1018**;16 DEC 97;Build 21
;
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ^PSSLOCK is supported by DBIA #2789.
;
; Modified - IHS/MSC/PLS - 02/19/2014 - CHK+17
CHK ;Check to be sure all the orders in the complex order series are completed, continued.
I 'PSJCOMV,'$G(COMQUIT) N PSJO S PSJO=0 F S PSJO=$O(^TMP("PSJCOM",$J,PSJO)) Q:'PSJO S PSGORD=+PSJO_"P",PSGND=$G(^PS(53.1,+PSJO,0)) D
.S PSGP=$P(PSGND,"^",15)
.I $P(PSGND,U,4)="U",$P(PSGND,U,9)="A",($P(PSGND,U,24)'="R") D ^PSGOT D Q
..M ^PS(55,PSGP,5,+PSGORD,4)=^PS(53.1,PSJO,4)
..N PSGND2P5 S PSGND2P5=$G(^PS(53.1,+PSJO,2.5)),DUR=$P(PSGND2P5,"^",2) I $G(DUR)]"" N DA,DR,DIE S DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP,DA=+PSGORD,DR="126////"_$G(DUR) D ^DIE
..D ACTLOG^PSJOEA(PSJO,PSGP,PSGORD)
..S VND4=$G(^PS(55,PSGP,5,+PSGORD,4))
..I PSJSYSL>1 S $P(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT S:$P(^(7),U,2)="" $P(^(7),U,2)="N"_$S($P(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"") S PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD D ENL^PSGVDS
..S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)&'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23) $P(VND4,"^",22)="" S $P(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)=VND4
..I '$P(VND4,U,10) S ^PS(55,"ANV",PSGP,+PSGORD)=""
..I $P(VND4,U,9) K ^PS(55,"APV",PSGP,+PSGORD)
..I $P(VND4,U,10) K ^PS(55,"ANV",PSGP,+PSGORD)
..S:+PSJSYSU=3 ^PS(55,"AUE",PSGP,+PSGORD)=""
..S PSJCOM=$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8) I PSJCOM]"" K ^PS(53.1,"ACX",PSJCOM,PSJO) S $P(^PS(55,PSGP,5,+PSGORD,4),"^",9)=1
..D EN1^PSJHL2(PSGP,$S(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"XX"),+PSGORD_"U") ; allow status change to be sent for pharmacists & nurses
..D:+PSJSYSU=1 EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U") L -^PS(55,PSGP,5,+PSGORD)
..;IHS/MSC/PLS - 02/19/2014
..;S PSJPREX=1 D CMPLX2^PSJCOM1(PSGP,PSJORD,PSGORD) K PSJPREX
..S PSJPREX=1 D CMPLX2^PSJCOM1(PSGP,PSJORD,PSGORD) D CALLBOP^PSGOEV K PSJPREX
.I $P(PSGND,U,4)'="U",$P(PSGND,U,9)="A" D GT531^PSIVORFA(PSGP,PSJO_"P") D Q
..S ON55="" I $P(PSGND,"^",24)="R" S ON55=$P(PSGND,"^",25) D
...N PND0,PSGORDR S PND0=^PS(53.1,+PSJO,0),PSGORDR=$P(PND0,U,25)
...Q:'$$LS^PSSLOCK(PSGP,PSGORDR)
...N OEORD,OOEORD,FILE55,FILE55N0,PNDP2 S PNDP2=^PS(53.1,+PSJO,.2),FILE55="^PS(55,"_DFN_",""IV"",",FILE55N0=FILE55_+PSGORDR_",0)"
...S OEORD=$P(PND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEORD'=OOEORD D EXPOE^PSGOER(DFN,+PSJO_"P",+$$LASTREN^PSJLMPRI(DFN,+PSJO_"P"))
...S PSGORDP=PSJO,DIE="^PS(53.1,",DA=+PSJO,DR="28////A;104////@" W "." D ^DIE
...Q:'$G(OEORD) K DA,DR,DIE S DA(1)=DFN,DA=+PSGORDR,DIE=FILE55,DR=110_"////"_+OEORD
...S:$P(PNDP2,U,8) DR=DR_";150////"_$P(PNDP2,U,8) D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OEORD
...D EN1^PSJHL2(DFN,"SC",PSGORDR),UNL^PSSLOCK(PSGP,PSGORDR)
..I 'ON55 D SETNEW^PSIVORFB
..S (P("NEWON"),ON)=ON55,PSGP=$P(PSGND,U,15)
..S VND4=$G(^TMP("PSJCOM",$J,+PSJO,4)) D
...N PSJRN,PSJRNDT,PSJRPH,PSJRPHD,PSJPVFL,PSJNVFL,DR,DIE,DA
...S (PSJPVFL,PSJNVFL)=""
...S PSJRN=$P(VND4,U,1),PSJRNDT=$P(VND4,U,2),PSJRPH=$P(VND4,U,3),PSJRPHD=$P(VND4,U,4),PSJPVFL=$P(VND4,U,16) S:PSJRN]"" PSJNVFL=1
...S DR="16////"_PSJRN_";17////"_PSJRNDT_";140////"_PSJRPH_";141////"_PSJRPHD_";142////"_PSJPVFL_";143////"_PSJNVFL
...S DA(1)=PSGP,DA=+ON55,DIE="^PS(55,"_PSGP_",""IV""," D ^DIE
..D:P("RES")="R" RUPDATE^PSIVOREN(PSGP,ON,P(2))
..I +PSJSYSU=3 K OD D ^PSIVORE1 ;LABEL STUFF
..I $G(P("PACT"))]"",+$P(P("PACT"),U,2),+$P(P("PACT"),U,3) D Q
...NEW DIC,DA,X,Y,XX D NAME^PSJBCMA1($P(P("PACT"),U,2),.XX)
...S DIC(0)="L",DA(1)=DFN,DA(2)=+ON55,X=1
...S DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A"","
...S DIC("DR")=".02////F;.03////"_XX_";.04////"_$P($G(^PS(53.3,+$P(P("PACT"),U,3),0)),U)_";.05////"_$P(P("PACT"),U)_";.06////"_$P(P("PACT"),U,2)
...K DO D FILE^DICN K DO
...N DIK,DA,PSIVACT S DIK="^PS(55,"_DFN_",""IV"",",DA=+ON,PSIVACT="" S:$G(DFN) DA(1)=DFN D IX^DIK K DIK,DA
...S PSJCOM=$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",8) I PSJCOM]"" K ^PS(53.1,"ACX",PSJCOM,PSJO)
...D EN1^PSJHL2(DFN,"SC",ON)
...D:+PSJSYSU=1 EN1^PSJHL2(DFN,"ZV",ON) L -^PS(55,DFN,"IV",+ON) I $G(ON55) L -^PS(55,DFN,"IV",+ON55)
..L -^PS(55,DFN,"IV",+ON) I $G(ON55) L -^PS(55,DFN,"IV",+ON55)
.I $P(PSGND,U,4)="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",9)="A",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)="U" S PSGP=$P(PSGND,U,15) D UD^PSJOEA
.I $P(PSGND,U,4)'="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",9)="A",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)="U" S PSGP=$P(PSGND,U,15) D UD^PSJOEA
.I $P(PSGND,U,4)'="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)'="U",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",17)="A" S DFN=$S($G(PSGP)]"":PSGP,1:$P(PSGND,U,15)) D IV^PSJOEA
.I $P(PSGND,U,4)="U",$P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),$P(^TMP("PSJCOM2",$J,PSJO,0),"^",4)'="U",$P(^TMP("PSJCOM2",$J,PSJO,0),"^",17)="A" S DFN=$S($G(PSGP)]"":PSGP,1:$P(PSGND,U,15)) D IV^PSJOEA
K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),PSJOWALL
Q
PSJOEA2 ;BIR/MLM-INPATIENT ORDER ENTRY ;19-Feb-2014 16:01;DU
+1 ;;5.0; INPATIENT MEDICATIONS ;**127,133,1018**;16 DEC 97;Build 21
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA #2191.
+4 ; Reference to ^PSSLOCK is supported by DBIA #2789.
+5 ;
+6 ; Modified - IHS/MSC/PLS - 02/19/2014 - CHK+17
CHK ;Check to be sure all the orders in the complex order series are completed, continued.
+1 IF 'PSJCOMV
IF '$GET(COMQUIT)
NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^TMP("PSJCOM",$JOB,PSJO))
IF 'PSJO
QUIT
SET PSGORD=+PSJO_"P"
SET PSGND=$GET(^PS(53.1,+PSJO,0))
Begin DoDot:1
+2 SET PSGP=$PIECE(PSGND,"^",15)
+3 IF $PIECE(PSGND,U,4)="U"
IF $PIECE(PSGND,U,9)="A"
IF ($PIECE(PSGND,U,24)'="R")
DO ^PSGOT
Begin DoDot:2
+4 MERGE ^PS(55,PSGP,5,+PSGORD,4)=^PS(53.1,PSJO,4)
+5 NEW PSGND2P5
SET PSGND2P5=$GET(^PS(53.1,+PSJO,2.5))
SET DUR=$PIECE(PSGND2P5,"^",2)
IF $GET(DUR)]""
NEW DA,DR,DIE
SET DIE="^PS(55,"_PSGP_",5,"
SET DA(1)=PSGP
SET DA=+PSGORD
SET DR="126////"_$GET(DUR)
DO ^DIE
+6 DO ACTLOG^PSJOEA(PSJO,PSGP,PSGORD)
+7 SET VND4=$GET(^PS(55,PSGP,5,+PSGORD,4))
+8 IF PSJSYSL>1
SET $PIECE(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT
IF $PIECE(^(7),U,2)=""
SET $PIECE(^(7),U,2)="N"_$SELECT($PIECE(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"")
SET PSGTOL=2
SET PSGUOW=DUZ
SET PSGTOO=1
SET DA=+PSGORD
DO ENL^PSGVDS
+9 IF $PIECE(VND4,"^",15)&'$PIECE(VND4,"^",16)
SET $PIECE(VND4,"^",15)=""
IF $PIECE(VND4,"^",18)&'$PIECE(VND4,"^",19)
SET $PIECE(VND4,"^",18)=""
IF $PIECE(VND4,"^",22)&'$PIECE(VND4,"^",23)
SET $PIECE(VND4,"^",22)=""
SET $PIECE(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT
SET ^PS(55,PSGP,5,+PSGORD,4)=VND4
+10 IF '$PIECE(VND4,U,10)
SET ^PS(55,"ANV",PSGP,+PSGORD)=""
+11 IF $PIECE(VND4,U,9)
KILL ^PS(55,"APV",PSGP,+PSGORD)
+12 IF $PIECE(VND4,U,10)
KILL ^PS(55,"ANV",PSGP,+PSGORD)
+13 IF +PSJSYSU=3
SET ^PS(55,"AUE",PSGP,+PSGORD)=""
+14 SET PSJCOM=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),"^",8)
IF PSJCOM]""
KILL ^PS(53.1,"ACX",PSJCOM,PSJO)
SET $PIECE(^PS(55,PSGP,5,+PSGORD,4),"^",9)=1
+15 ; allow status change to be sent for pharmacists & nurses
DO EN1^PSJHL2(PSGP,$SELECT(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"XX"),+PSGORD_"U")
+16 IF +PSJSYSU=1
DO EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U")
LOCK -^PS(55,PSGP,5,+PSGORD)
+17 ;IHS/MSC/PLS - 02/19/2014
+18 ;S PSJPREX=1 D CMPLX2^PSJCOM1(PSGP,PSJORD,PSGORD) K PSJPREX
+19 SET PSJPREX=1
DO CMPLX2^PSJCOM1(PSGP,PSJORD,PSGORD)
DO CALLBOP^PSGOEV
KILL PSJPREX
End DoDot:2
QUIT
+20 IF $PIECE(PSGND,U,4)'="U"
IF $PIECE(PSGND,U,9)="A"
DO GT531^PSIVORFA(PSGP,PSJO_"P")
Begin DoDot:2
+21 SET ON55=""
IF $PIECE(PSGND,"^",24)="R"
SET ON55=$PIECE(PSGND,"^",25)
Begin DoDot:3
+22 NEW PND0,PSGORDR
SET PND0=^PS(53.1,+PSJO,0)
SET PSGORDR=$PIECE(PND0,U,25)
+23 IF '$$LS^PSSLOCK(PSGP,PSGORDR)
QUIT
+24 NEW OEORD,OOEORD,FILE55,FILE55N0,PNDP2
SET PNDP2=^PS(53.1,+PSJO,.2)
SET FILE55="^PS(55,"_DFN_",""IV"","
SET FILE55N0=FILE55_+PSGORDR_",0)"
+25 SET OEORD=$PIECE(PND0,U,21)
IF PSGORDR
SET OOEORD=$PIECE(@FILE55N0,"^",21)
IF OEORD'=OOEORD
DO EXPOE^PSGOER(DFN,+PSJO_"P",+$$LASTREN^PSJLMPRI(DFN,+PSJO_"P"))
+26 SET PSGORDP=PSJO
SET DIE="^PS(53.1,"
SET DA=+PSJO
SET DR="28////A;104////@"
WRITE "."
DO ^DIE
+27 IF '$GET(OEORD)
QUIT
KILL DA,DR,DIE
SET DA(1)=DFN
SET DA=+PSGORDR
SET DIE=FILE55
SET DR=110_"////"_+OEORD
+28 IF $PIECE(PNDP2,U,8)
SET DR=DR_";150////"_$PIECE(PNDP2,U,8)
DO ^DIE
SET DIE=FILE55_+PSGORDR_",0)"
SET $PIECE(@DIE,U,21)=OEORD
+29 DO EN1^PSJHL2(DFN,"SC",PSGORDR)
DO UNL^PSSLOCK(PSGP,PSGORDR)
End DoDot:3
+30 IF 'ON55
DO SETNEW^PSIVORFB
+31 SET (P("NEWON"),ON)=ON55
SET PSGP=$PIECE(PSGND,U,15)
+32 SET VND4=$GET(^TMP("PSJCOM",$JOB,+PSJO,4))
Begin DoDot:3
+33 NEW PSJRN,PSJRNDT,PSJRPH,PSJRPHD,PSJPVFL,PSJNVFL,DR,DIE,DA
+34 SET (PSJPVFL,PSJNVFL)=""
+35 SET PSJRN=$PIECE(VND4,U,1)
SET PSJRNDT=$PIECE(VND4,U,2)
SET PSJRPH=$PIECE(VND4,U,3)
SET PSJRPHD=$PIECE(VND4,U,4)
SET PSJPVFL=$PIECE(VND4,U,16)
IF PSJRN]""
SET PSJNVFL=1
+36 SET DR="16////"_PSJRN_";17////"_PSJRNDT_";140////"_PSJRPH_";141////"_PSJRPHD_";142////"_PSJPVFL_";143////"_PSJNVFL
+37 SET DA(1)=PSGP
SET DA=+ON55
SET DIE="^PS(55,"_PSGP_",""IV"","
DO ^DIE
End DoDot:3
+38 IF P("RES")="R"
DO RUPDATE^PSIVOREN(PSGP,ON,P(2))
+39 ;LABEL STUFF
IF +PSJSYSU=3
KILL OD
DO ^PSIVORE1
+40 IF $GET(P("PACT"))]""
IF +$PIECE(P("PACT"),U,2)
IF +$PIECE(P("PACT"),U,3)
Begin DoDot:3
+41 NEW DIC,DA,X,Y,XX
DO NAME^PSJBCMA1($PIECE(P("PACT"),U,2),.XX)
+42 SET DIC(0)="L"
SET DA(1)=DFN
SET DA(2)=+ON55
SET X=1
+43 SET DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A"","
+44 SET DIC("DR")=".02////F;.03////"_XX_";.04////"_$PIECE($GET(^PS(53.3,+$PIECE(P("PACT"),U,3),0)),U)_";.05////"_$PIECE(P("PACT"),U)_";.06////"_$PIECE(P("PACT"),U,2)
+45 KILL DO
DO FILE^DICN
KILL DO
+46 NEW DIK,DA,PSIVACT
SET DIK="^PS(55,"_DFN_",""IV"","
SET DA=+ON
SET PSIVACT=""
IF $GET(DFN)
SET DA(1)=DFN
DO IX^DIK
KILL DIK,DA
+47 SET PSJCOM=$PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),"^",8)
IF PSJCOM]""
KILL ^PS(53.1,"ACX",PSJCOM,PSJO)
+48 DO EN1^PSJHL2(DFN,"SC",ON)
+49 IF +PSJSYSU=1
DO EN1^PSJHL2(DFN,"ZV",ON)
LOCK -^PS(55,DFN,"IV",+ON)
IF $GET(ON55)
LOCK -^PS(55,DFN,"IV",+ON55)
End DoDot:3
QUIT
+50 LOCK -^PS(55,DFN,"IV",+ON)
IF $GET(ON55)
LOCK -^PS(55,DFN,"IV",+ON55)
End DoDot:2
QUIT
+51 IF $PIECE(PSGND,U,4)="U"
IF $PIECE(PSGND,U,9)="DE"
IF $DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",9)="A"
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",4)="U"
SET PSGP=$PIECE(PSGND,U,15)
DO UD^PSJOEA
+52 IF $PIECE(PSGND,U,4)'="U"
IF $PIECE(PSGND,U,9)="DE"
IF $DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",9)="A"
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",4)="U"
SET PSGP=$PIECE(PSGND,U,15)
DO UD^PSJOEA
+53 IF $PIECE(PSGND,U,4)'="U"
IF $PIECE(PSGND,U,9)="DE"
IF $DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",4)'="U"
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",17)="A"
SET DFN=$SELECT($GET(PSGP)]"":PSGP,1:$PIECE(PSGND,U,15))
DO IV^PSJOEA
+54 IF $PIECE(PSGND,U,4)="U"
IF $PIECE(PSGND,U,9)="DE"
IF $DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",4)'="U"
IF $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",17)="A"
SET DFN=$SELECT($GET(PSGP)]"":PSGP,1:$PIECE(PSGND,U,15))
DO IV^PSJOEA
End DoDot:1
+55 KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB),PSJOWALL
+56 QUIT
