- 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
