PSJOEA1 ;BIR/MLM-INPATIENT ORDER ENTRY ;23 Jun 98 / 1:46 PM
;;5.0; INPATIENT MEDICATIONS ;**110,127,133,171**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ^PSSLOCK is supported by DBIA #2789.
;
CHK ;Check to be sure all the orders in the complex order series are completed.
N COMQUIT,PSJCOMV,PSJOT,PSJSTAT,PSJSTAT2,PSGND2P5,DUR,ND14,PSJPREX S (PSJCOMV,COMQUIT)=0,PSJSTAT2=""
I '$D(^TMP("PSJCOM",$J)) Q
N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO Q:COMQUIT S PSJOT=$P(^PS(53.1,PSJO,0),"^",4) D
. I '$D(^TMP("PSJCOM",$J,PSJO,0)) M ^TMP("PSJCOM",$J,PSJO)=^PS(53.1,PSJO) I '$D(^TMP("PSJCOM",$J,PSJO,0)) S COMQUIT=2 Q:COMQUIT
. S PSJSTAT=$P(^TMP("PSJCOM",$J,PSJO,0),"^",9)
. I PSJSTAT="DE" S PSJSTAT=$P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",9) I PSJSTAT="" S COMQUIT=1 Q
. S:PSJSTAT2="" PSJSTAT2=PSJSTAT S:PSJSTAT'=PSJSTAT2 COMQUIT=2 Q:COMQUIT S PSJSTAT2=PSJSTAT
I COMQUIT,PSJOT="U",$G(^TMP("PSJCOM",$J))'="A" S:$G(PSJOWALL)]"" $P(^PS(55,PSGP,5.1),U)=PSJOWALL
I (COMQUIT=2)!(COMQUIT&($G(^TMP("PSJCOM",$J))'="A")) D Q
.K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J)
.W !,"By not finishing all the orders, none of the orders will be updated." D PAUSE^VALM1
I 'COMQUIT N PSJO S PSJO=0 F S PSJO=$O(^TMP("PSJCOM",$J,PSJO)) Q:'PSJO D
.S PSGS0Y=$P($G(^TMP("PSJCOM",$J,+PSJO,2)),"^",5),PSGS0XT=$P($G(^TMP("PSJCOM",$J,+PSJO,2)),"^",6)
.N EDITS0Y,EDITS0XT S EDITS0Y=$P($G(^TMP("PSJCOM2",$J,+PSJO,2)),"^",5),EDITS0XT=$P($G(^TMP("PSJCOM2",$J,+PSJO,2)),"^",6) D
..S:EDITS0Y PSGS0Y=EDITS0Y I EDITS0XT!(",O,D,"[(","_EDITS0XT_",")) S PSGS0XT=EDITS0XT
.N DIE,DA,DR S DR="28////^S X=$P(^TMP(""PSJCOM"",$J,+PSJO,0),""^"",9)",DA=+PSJO,DIE="^PS(53.1," D ^DIE
.N DIK,DA S DIK="^PS(53.1,",DA=+PSJO S:$G(DFN) DA(1)=DFN D IX^DIK K DIK,DA
.M ^PS(53.1,+PSJO)=^TMP("PSJCOM",$J,+PSJO)
.S PSGND=$G(^PS(53.1,+PSJO,0)),PSGND2P5=$G(^PS(53.1,+PSJO,2.5)),DUR=$P(PSGND2P5,"^",2),ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P")
.I $P(PSGND,U,4)="U",$P(PSGND,U,24)="R" D
..N PND0,PSGORDR S PND0=^PS(53.1,+PSJO,0) I $P(PND0,U,24)="R" S PSGORDR=$P(PND0,U,25) D
...S:'$G(PSGP) PSGP=$G(DFN) Q:'$$LS^PSSLOCK(PSGP,PSGORDR)
...N OEORD,OOEORD,FILE55,FILE55N0,PNDP2 S PNDP2=^PS(53.1,+PSJO,.2),FILE55="^PS(55,"_DFN_$S($P(PND0,U,4)="U":",5,",1:",""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
...D START^PSGOTR(+PSJO_"P",+PSGORDR) I OEORD D
....K DA,DR,DIE S DA(1)=DFN,DA=+PSGORDR,DIE=FILE55,DR=$S(DIE["IV":110,1:66)_"////"_+OEORD
....S:$P(PNDP2,U,8) DR=DR_";125////"_$P(PNDP2,U,8) D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OEORD
....D EN1^PSJHL2(DFN,"SC",PSGORDR),UNL^PSSLOCK(DFN,PSGORDR)
..I '$G(COMQUIT) S ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P") I $G(ND14) S DA=+$P(PSGND,U,25) I DA D
...N PSGAT S PSGAT=$P($G(^TMP("PSJCOM",$J,+PSJO,2)),"^",5)
...D UPDREN^PSGOER(DA,$P(ND14,U),$P(ND14,U,3),$P(ND14,U,4),$P($G(^PS(53.1,+PSJO,.2)),U,3),$P(ND14,U,2))
...K PSJPREX I $G(PSGORDR)["U" I $G(PSJORD)=+$G(PSJORD) D CMPLX2^PSJCOM1(DFN,PSJORD,PSGORDR) I $G(PSGPXN) S PSJPREX=1
.I '$G(PSGP) S:$G(DFN) PSGP=DFN
.I $P(PSGND,U,4)'="U",$P(PSGND,U,24)="R",$P(PSGND,U,25),$P($G(^PS(53.1,+PSJO,2)),U,2)<$P($G(^PS(55,PSGP,"IV",+$P(PSGND,U,25),0)),U,3) D
..K DA,DR S DA(1)=PSGP,DA=+$P(PSGND,U,25),DIE="^PS(55,"_PSGP_",""IV"",",DR=".03////"_$P($G(^PS(53.1,+PSJO,2)),U,2)_";116////"_$P($G(^PS(55,PSGP,"IV",+$P(PSGND,U,25),0)),U,3)
..D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(PSGND,U,25)) L -^PS(53.1,+PSJO)
.I $P(PSGND,U,9)="DE",$D(^TMP("PSJCOM2",$J,PSJO,0)),(",N,A,"[$P(^TMP("PSJCOM2",$J,PSJO,0),"^",9)) D
..S:'$G(PSGP) PSGP=DFN S PSGS0Y=$P($G(^TMP("PSJCOM2",$J,+PSJO,2)),"^",5)
..N DA,DR,DIE D ENGNN^PSGOETO S $P(^TMP("PSJCOM",$J,PSJO,0),"^",26)=DA_"P",$P(^TMP("PSJCOM2",$J,PSJO,0),"^")=DA,$P(^(0),"^",18)=DA
..S DR="28////^S X=$P(^TMP(""PSJCOM2"",$J,+PSJO,0),""^"",9)",DIE="^PS(53.1," D ^DIE
..M ^PS(53.1,DA)=^TMP("PSJCOM2",$J,+PSJO) M ^TMP("PSJCOM2",$J,DA)=^TMP("PSJCOM2",$J,+PSJO) N PSJOCHIL S PSJOCHIL=$P(^PS(53.1,DA,.2),"^",8) I PSJOCHIL S ^PS(53.1,"ACX",+PSJOCHIL,DA)=""
..I $P(^PS(53.1,+PSJO,2),"^",5)'=$P(^TMP("PSJCOM2",$J,+PSJO,2),"^",5) S $P(^PS(53.1,+PSJO,2),"^",5)=$P(^TMP("PSJCOM2",$J,+PSJO,2),"^",5)
..D EN1^PSJHL2(PSGP,"OD",+PSJO_"P"),EN1^PSJHL2(PSGP,"SN",+DA_"P")
..K ^PS(53.1,"ACX",PSJORD,PSJO) L -^PS(53.1,+PSJO) L -^PS(53.1,DA)
I '$G(COMQUIT) N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJORD,PSJO)) Q:'PSJO Q:PSJCOMV D
.I '$D(^TMP("PSJCOM",$J,PSJO)) D Q:$G(PSJCOMV)
..N EDITND0,PREV,REAS S EDITND0=$G(^PS(53.1,+PSJO,0)) S PREV=$P(EDITND0,"^",25),REAS=$P(EDITND0,"^",24)
..I PREV,REAS="E" I $P($G(^PS(53.1,+PREV,0)),"^",9)="DE" M ^TMP("PSJCOM",$J,+PSJO)=^PS(53.1,+PSJO) K ^TMP("PSJCOM",$J,+PREV),^PS(53.1,"ACX",+PREV) Q
..S PSJCOMV=1
.I $P(^TMP("PSJCOM",$J,PSJO,0),"^",9)'="A",'$D(^TMP("PSJCOM2",$J,PSJO,0)) S PSJCOMV=1 Q
.I $P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",4)="U",$P(^TMP("PSJCOM",$J,PSJO,0),"^",9)'="A",$P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",9)'="A" S PSJCOMV=1 Q
.I $P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",4)'="U",$P(^TMP("PSJCOM",$J,PSJO,0),"^",9)'="A",$P($G(^TMP("PSJCOM2",$J,PSJO,0)),"^",17)'="A" S PSJCOMV=1
I ($G(COMQUIT)=2)!(($G(COMQUIT)!PSJCOMV)&$G(^TMP("PSJCOM",$J))="A") K ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J) W !,"By not verifying all the orders, none of the orders will be verified." D PAUSE^VALM1 Q
;
D CHK^PSJOEA2
Q
PSJOEA1 ;BIR/MLM-INPATIENT ORDER ENTRY ;23 Jun 98 / 1:46 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**110,127,133,171**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA #2191.
+4 ; Reference to ^PSSLOCK is supported by DBIA #2789.
+5 ;
CHK ;Check to be sure all the orders in the complex order series are completed.
+1 NEW COMQUIT,PSJCOMV,PSJOT,PSJSTAT,PSJSTAT2,PSGND2P5,DUR,ND14,PSJPREX
SET (PSJCOMV,COMQUIT)=0
SET PSJSTAT2=""
+2 IF '$DATA(^TMP("PSJCOM",$JOB))
QUIT
+3 NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
IF 'PSJO
QUIT
IF COMQUIT
QUIT
SET PSJOT=$PIECE(^PS(53.1,PSJO,0),"^",4)
Begin DoDot:1
+4 IF '$DATA(^TMP("PSJCOM",$JOB,PSJO,0))
MERGE ^TMP("PSJCOM",$JOB,PSJO)=^PS(53.1,PSJO)
IF '$DATA(^TMP("PSJCOM",$JOB,PSJO,0))
SET COMQUIT=2
IF COMQUIT
QUIT
+5 SET PSJSTAT=$PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)
+6 IF PSJSTAT="DE"
SET PSJSTAT=$PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",9)
IF PSJSTAT=""
SET COMQUIT=1
QUIT
+7 IF PSJSTAT2=""
SET PSJSTAT2=PSJSTAT
IF PSJSTAT'=PSJSTAT2
SET COMQUIT=2
IF COMQUIT
QUIT
SET PSJSTAT2=PSJSTAT
End DoDot:1
+8 IF COMQUIT
IF PSJOT="U"
IF $GET(^TMP("PSJCOM",$JOB))'="A"
IF $GET(PSJOWALL)]""
SET $PIECE(^PS(55,PSGP,5.1),U)=PSJOWALL
+9 IF (COMQUIT=2)!(COMQUIT&($GET(^TMP("PSJCOM",$JOB))'="A"))
Begin DoDot:1
+10 KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB)
+11 WRITE !,"By not finishing all the orders, none of the orders will be updated."
DO PAUSE^VALM1
End DoDot:1
QUIT
+12 IF 'COMQUIT
NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^TMP("PSJCOM",$JOB,PSJO))
IF 'PSJO
QUIT
Begin DoDot:1
+13 SET PSGS0Y=$PIECE($GET(^TMP("PSJCOM",$JOB,+PSJO,2)),"^",5)
SET PSGS0XT=$PIECE($GET(^TMP("PSJCOM",$JOB,+PSJO,2)),"^",6)
+14 NEW EDITS0Y,EDITS0XT
SET EDITS0Y=$PIECE($GET(^TMP("PSJCOM2",$JOB,+PSJO,2)),"^",5)
SET EDITS0XT=$PIECE($GET(^TMP("PSJCOM2",$JOB,+PSJO,2)),"^",6)
Begin DoDot:2
+15 IF EDITS0Y
SET PSGS0Y=EDITS0Y
IF EDITS0XT!(",O,D,"[(","_EDITS0XT_","))
SET PSGS0XT=EDITS0XT
End DoDot:2
+16 NEW DIE,DA,DR
SET DR="28////^S X=$P(^TMP(""PSJCOM"",$J,+PSJO,0),""^"",9)"
SET DA=+PSJO
SET DIE="^PS(53.1,"
DO ^DIE
+17 NEW DIK,DA
SET DIK="^PS(53.1,"
SET DA=+PSJO
IF $GET(DFN)
SET DA(1)=DFN
DO IX^DIK
KILL DIK,DA
+18 MERGE ^PS(53.1,+PSJO)=^TMP("PSJCOM",$JOB,+PSJO)
+19 SET PSGND=$GET(^PS(53.1,+PSJO,0))
SET PSGND2P5=$GET(^PS(53.1,+PSJO,2.5))
SET DUR=$PIECE(PSGND2P5,"^",2)
SET ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P")
+20 IF $PIECE(PSGND,U,4)="U"
IF $PIECE(PSGND,U,24)="R"
Begin DoDot:2
+21 NEW PND0,PSGORDR
SET PND0=^PS(53.1,+PSJO,0)
IF $PIECE(PND0,U,24)="R"
SET PSGORDR=$PIECE(PND0,U,25)
Begin DoDot:3
+22 IF '$GET(PSGP)
SET PSGP=$GET(DFN)
IF '$$LS^PSSLOCK(PSGP,PSGORDR)
QUIT
+23 NEW OEORD,OOEORD,FILE55,FILE55N0,PNDP2
SET PNDP2=^PS(53.1,+PSJO,.2)
SET FILE55="^PS(55,"_DFN_$SELECT($PIECE(PND0,U,4)="U":",5,",1:",""IV"",")
SET FILE55N0=FILE55_+PSGORDR_",0)"
+24 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"))
+25 SET PSGORDP=PSJO
SET DIE="^PS(53.1,"
SET DA=+PSJO
SET DR="28////A;104////@"
WRITE "."
DO ^DIE
+26 DO START^PSGOTR(+PSJO_"P",+PSGORDR)
IF OEORD
Begin DoDot:4
+27 KILL DA,DR,DIE
SET DA(1)=DFN
SET DA=+PSGORDR
SET DIE=FILE55
SET DR=$SELECT(DIE["IV":110,1:66)_"////"_+OEORD
+28 IF $PIECE(PNDP2,U,8)
SET DR=DR_";125////"_$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(DFN,PSGORDR)
End DoDot:4
End DoDot:3
+30 IF '$GET(COMQUIT)
SET ND14=$$LASTREN^PSJLMPRI(DFN,+PSJO_"P")
IF $GET(ND14)
SET DA=+$PIECE(PSGND,U,25)
IF DA
Begin DoDot:3
+31 NEW PSGAT
SET PSGAT=$PIECE($GET(^TMP("PSJCOM",$JOB,+PSJO,2)),"^",5)
+32 DO UPDREN^PSGOER(DA,$PIECE(ND14,U),$PIECE(ND14,U,3),$PIECE(ND14,U,4),$PIECE($GET(^PS(53.1,+PSJO,.2)),U,3),$PIECE(ND14,U,2))
+33 KILL PSJPREX
IF $GET(PSGORDR)["U"
IF $GET(PSJORD)=+$GET(PSJORD)
DO CMPLX2^PSJCOM1(DFN,PSJORD,PSGORDR)
IF $GET(PSGPXN)
SET PSJPREX=1
End DoDot:3
End DoDot:2
+34 IF '$GET(PSGP)
IF $GET(DFN)
SET PSGP=DFN
+35 IF $PIECE(PSGND,U,4)'="U"
IF $PIECE(PSGND,U,24)="R"
IF $PIECE(PSGND,U,25)
IF $PIECE($GET(^PS(53.1,+PSJO,2)),U,2)<$PIECE($GET(^PS(55,PSGP,"IV",+$PIECE(PSGND,U,25),0)),U,3)
Begin DoDot:2
+36 KILL DA,DR
SET DA(1)=PSGP
SET DA=+$PIECE(PSGND,U,25)
SET DIE="^PS(55,"_PSGP_",""IV"","
SET DR=".03////"_$PIECE($GET(^PS(53.1,+PSJO,2)),U,2)_";116////"_$PIECE($GET(^PS(55,PSGP,"IV",+$PIECE(PSGND,U,25),0)),U,3)
+37 DO ^DIE
DO EN1^PSJHL2(PSGP,"XX",$PIECE(PSGND,U,25))
LOCK -^PS(53.1,+PSJO)
End DoDot:2
+38 IF $PIECE(PSGND,U,9)="DE"
IF $DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
IF (",N,A,"[$PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^",9))
Begin DoDot:2
+39 IF '$GET(PSGP)
SET PSGP=DFN
SET PSGS0Y=$PIECE($GET(^TMP("PSJCOM2",$JOB,+PSJO,2)),"^",5)
+40 NEW DA,DR,DIE
DO ENGNN^PSGOETO
SET $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",26)=DA_"P"
SET $PIECE(^TMP("PSJCOM2",$JOB,PSJO,0),"^")=DA
SET $PIECE(^(0),"^",18)=DA
+41 SET DR="28////^S X=$P(^TMP(""PSJCOM2"",$J,+PSJO,0),""^"",9)"
SET DIE="^PS(53.1,"
DO ^DIE
+42 MERGE ^PS(53.1,DA)=^TMP("PSJCOM2",$JOB,+PSJO)
MERGE ^TMP("PSJCOM2",$JOB,DA)=^TMP("PSJCOM2",$JOB,+PSJO)
NEW PSJOCHIL
SET PSJOCHIL=$PIECE(^PS(53.1,DA,.2),"^",8)
IF PSJOCHIL
SET ^PS(53.1,"ACX",+PSJOCHIL,DA)=""
+43 IF $PIECE(^PS(53.1,+PSJO,2),"^",5)'=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,2),"^",5)
SET $PIECE(^PS(53.1,+PSJO,2),"^",5)=$PIECE(^TMP("PSJCOM2",$JOB,+PSJO,2),"^",5)
+44 DO EN1^PSJHL2(PSGP,"OD",+PSJO_"P")
DO EN1^PSJHL2(PSGP,"SN",+DA_"P")
+45 KILL ^PS(53.1,"ACX",PSJORD,PSJO)
LOCK -^PS(53.1,+PSJO)
LOCK -^PS(53.1,DA)
End DoDot:2
End DoDot:1
+46 IF '$GET(COMQUIT)
NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJORD,PSJO))
IF 'PSJO
QUIT
IF PSJCOMV
QUIT
Begin DoDot:1
+47 IF '$DATA(^TMP("PSJCOM",$JOB,PSJO))
Begin DoDot:2
+48 NEW EDITND0,PREV,REAS
SET EDITND0=$GET(^PS(53.1,+PSJO,0))
SET PREV=$PIECE(EDITND0,"^",25)
SET REAS=$PIECE(EDITND0,"^",24)
+49 IF PREV
IF REAS="E"
IF $PIECE($GET(^PS(53.1,+PREV,0)),"^",9)="DE"
MERGE ^TMP("PSJCOM",$JOB,+PSJO)=^PS(53.1,+PSJO)
KILL ^TMP("PSJCOM",$JOB,+PREV),^PS(53.1,"ACX",+PREV)
QUIT
+50 SET PSJCOMV=1
End DoDot:2
IF $GET(PSJCOMV)
QUIT
+51 IF $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)'="A"
IF '$DATA(^TMP("PSJCOM2",$JOB,PSJO,0))
SET PSJCOMV=1
QUIT
+52 IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",4)="U"
IF $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)'="A"
IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",9)'="A"
SET PSJCOMV=1
QUIT
+53 IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",4)'="U"
IF $PIECE(^TMP("PSJCOM",$JOB,PSJO,0),"^",9)'="A"
IF $PIECE($GET(^TMP("PSJCOM2",$JOB,PSJO,0)),"^",17)'="A"
SET PSJCOMV=1
End DoDot:1
+54 IF ($GET(COMQUIT)=2)!(($GET(COMQUIT)!PSJCOMV)&$GET(^TMP("PSJCOM",$JOB))="A")
KILL ^TMP("PSJCOM",$JOB),^TMP("PSJCOM2",$JOB)
WRITE !,"By not verifying all the orders, none of the orders will be verified."
DO PAUSE^VALM1
QUIT
+55 ;
+56 DO CHK^PSJOEA2
+57 QUIT
