PSJO1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ;15 May 98 / 9:28 AM
;;5.0; INPATIENT MEDICATIONS ;**3,47,56,58,109,110,127,162**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^%DTC is supported by DBIA# 10000.
; Reference to ^%ZOSV is supported by DBIA# 10097.
; Reference to XLFDT is supported by DBIA# 10103.
;
ECHK ;
S C="A",ON=+O_"U",START=$G(^PS(55,PSGP,5,+O,2)),STOP=$P(START,U,4),START=$P(START,U,2) S:PSJOS START=-START
I +START>PSGDT,(STOP>PSGDT) G SET
S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) SET S ND4=$G(^PS(55,PSGP,5,+O,4)) I ST'="O",SD'<PSGODT,$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)
E I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))
E Q:PSJOL="S" S C="O"
;
SET ;
I ON["P",($D(PRNTON)!($D(P("PRNTON")))) N PSJOK S PSJOK=$$COMCHK($S($G(P("PRNTON"))]"":P("PRNTON"),$G(PRNTON)]"":PRNTON,1:""),PSJPTYP) Q:'PSJOK
NEW DRUGNAME D DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
S DN=DRUGNAME(1),SUB=$S(PSJOS:START,1:$E(DN,1,40))
I ON["P",$G(P("PRNTON"))]"",$G(PRNTON)=+P("PRNTON") Q
I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
S ^TMP("PSJ",$J,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),ON)=DN_"^"_$G(NF),PSJOCNT=PSJOCNT+1 Q
;
IVSET ;Set IV data in ^TMP("PSJ",$J,.
N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND
I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,9,17 S P(X)=$P(Y,U,X)
I ON["V",(P(2)=""),(P(3)="") Q
I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q
I ON'["V",ND S P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4),P(4)=$P($G(^PS(53.1,+ON,8)),U),P("PRNTON")=$P($G(^PS(53.1,+ON,.2)),U,8)
I ON'["V",P("PRNTON")]"" N PSJOK S PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP) Q:'PSJOK
D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4))
I $G(DRG) S DRGT=$S($G(DRG("AD",1))]"":$P($G(DRG("AD",1)),U,2),1:$P($G(DRG("SOL",1)),U,2)),ORTX=DRGT
I $G(ORTX)="",(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
;* I $G(ORTX)=""!(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
S:$G(ORTX)="" ORTX="NOT FOUND"
;
IVSET1 ;
;* S TYP=$S(P(2)=P(3):"O",1:"C"),STAT=$S("ED"[P(17):"O",P(17)="P":"P",1:"A")
S TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3)) I TYP'="O" S TYP=$S(ON["P":"z",1:"C")
S STAT=$S($G(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
I P(17)="P" S STAT="C"_$S($P($G(^PS(53.1,+ON,.2)),U,8)]"":"D",$P($G(^PS(53.1,+ON,.2)),U,4)="S":"A",$P($G(^(0)),U,24)="R":"C",1:"B")
I ON["P",$G(P("PRNTON"))]"",PRNTON=+P("PRNTON") Q
I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
S ^TMP("PSJ",$J,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="^F",PSJOCNT=PSJOCNT+1
Q
;
ENU ; update status field to reflect expired orders, if necessary
W !!,"...a few moments, I have some updating to do..."
ENUNM ;
F Q=+PSJPAD:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q!(Q>PSGDT) S UPD=Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $D(^PS(55,PSGP,5,QQ,0)),"DEH"'[$E($P(^(0),"^",9)) D
.; naked ref below refers to line above
.S $P(^(0),"^",9)="E",ORIFN=$P(^(0),"^",21) D EN1^PSJHL2(PSGP,"SC",QQ_"U")
K UPD Q
;
EN(PSJPTYP) ; enter here
; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
N PSJX,PSJY
S PSJOL=$G(PSJOL) ; Initialize if no 'View Profile' option selected
I PSJOL="L",$D(XRTL) D T0^%ZOSV
K ^TMP("PSJ",$J) D NOW^%DTC S PSGDT=+$E(%,1,12),DT=$$DT^XLFDT,PSJOS=$P(PSJSYSP0,"^",11),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1)
S PSJOCNT=0 I PSJPTYP>1 F PSJORD=0:0 S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
.S PSJX=$G(^PS(55,DFN,"IV",+PSJORD,0))
.S PSJY=$P(PSJX,U,17)
.I $P(PSJX,U,3)<PSGDT,"AR"[PSJY S $P(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E",PSJY="E",ON=+PSJORD D EXPIR^PSIVOE
.I +PSJSYSU=3,('+$P($G(^PS(55,DFN,"IV",+PSJORD,4)),U,4)),($P($G(^(.2)),U,4)="D") S PSJPRI="D"
.I $S($G(PSJPRI)="D":1,PSJY="P":0,PSJOL="L":1,1:"DPE"'[PSJY) S ON=+PSJORD_"V" D IVSET K PSJPRI,ON
D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,(X1,DT)=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)
D ENUNM
I PSJPTYP'=2 F ST="C","O","OC","P","R" F SD=+PSJPAD:0 S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD F O=0:0 S O=$O(^PS(55,PSGP,5,"AU",ST,SD,O)) Q:'O D ECHK
Q:$D(PSGONNV)
;I PSJPTYP'=2 F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
N PRNTON F SD="I","N" S (PRNTON,O)=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S O=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
N PRNTON S (PRNTON,O)=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV
Q
;
NVSET ; Set up orders from 53.1.
N ND S ND=$G(^PS(53.1,O,0)) I 'ND D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
I $P(ND,U,15),$G(PSGP) I PSGP'=$P(ND,U,15) D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
I $P(ND,U,9)["D" D Q
.K ^PS(53.1,"AS",SD,PSGP,O)
.N ND2 S ND2=$G(^PS(53.1,O,.2)) I $P(ND2,U,8) K ^PS(53.1,"ACX",$P(ND2,U,8))
S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
S C=$S(((SD="N")&($P($G(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$P($G(^PS(53.1,O,.2)),U,8)]"":"CD",$P($G(^PS(53.1,O,.2)),U,4)="S":"CA",$P($G(^(0)),U,24)="R":"CC",1:"CB")
;I C="CC" S C=$$CKPC^PSGOU(PSGP,+$P($G(^PS(53.1,O,0)),U,25),O)
D SET
Q
;
KILL ;
K P,STAT,TYP,ORTX,N,JJ
Q
COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
S OK=0
I PSJCOM=0 S OK=1 Q OK
I PSJCOM="" Q OK
I PSJPTYP="" Q OK
I '$D(^PS(53.1,"ACX",PSJCOM)) Q OK
S OK=1 I PSJPTYP=3 Q OK
N PSJON S PSJON=""
F S PSJON=$O(^PS(53.1,"ACX",PSJCOM,PSJON)) Q:'PSJON D Q:OK=0
.I $P($G(^PS(53.1,PSJON,0)),"^",9)["D" K ^PS(53.1,"ACX",PSJCOM)
.I $P($G(^PS(53.1,PSJON,0)),"^",4)'="U",PSJPTYP=1 S OK=0 Q
.I $P($G(^PS(53.1,PSJON,0)),"^",4)="U",PSJPTYP=2 S OK=0 Q
Q OK
PSJO1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ;15 May 98 / 9:28 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**3,47,56,58,109,110,127,162**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^%DTC is supported by DBIA# 10000.
+5 ; Reference to ^%ZOSV is supported by DBIA# 10097.
+6 ; Reference to XLFDT is supported by DBIA# 10103.
+7 ;
ECHK ;
+1 SET C="A"
SET ON=+O_"U"
SET START=$GET(^PS(55,PSGP,5,+O,2))
SET STOP=$PIECE(START,U,4)
SET START=$PIECE(START,U,2)
IF PSJOS
SET START=-START
+2 IF +START>PSGDT
IF (STOP>PSGDT)
GOTO SET
+3 SET ND=$GET(^PS(55,PSGP,5,+O,0))
IF $SELECT($PIECE(ND,"^",9)=""
GOTO SET
SET ND4=$GET(^PS(55,PSGP,5,+O,4))
IF ST'="O"
IF SD'<PSGODT
IF $SELECT($PIECE(ND,"^",9)="E":$PIECE(ND4,"^",16),1:0)
+4 IF '$TEST
IF ST="O"
IF $PIECE(ND,"^",9)="E"
IF $SELECT('$PIECE(ND4,"^",UDU):1,SD<PSGODT:0,1:$PIECE(ND4,"^",16))
+5 IF '$TEST
IF PSJOL="S"
QUIT
SET C="O"
+6 ;
SET ;
+1 IF ON["P"
IF ($DATA(PRNTON)!($DATA(P("PRNTON"))))
NEW PSJOK
SET PSJOK=$$COMCHK($SELECT($GET(P("PRNTON"))]"":P("PRNTON"),$GET(PRNTON)]"":PRNTON,1:""),PSJPTYP)
IF 'PSJOK
QUIT
+2 NEW DRUGNAME
DO DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
+3 SET DN=DRUGNAME(1)
SET SUB=$SELECT(PSJOS:START,1:$EXTRACT(DN,1,40))
+4 IF ON["P"
IF $GET(P("PRNTON"))]""
IF $GET(PRNTON)=+P("PRNTON")
QUIT
+5 IF ON["P"
IF $GET(P("PRNTON"))]""
SET PRNTON=+P("PRNTON")
SET ON=+P("PRNTON")
+6 SET ^TMP("PSJ",$JOB,C,$SELECT(PSJOS:SUB,1:ST),$SELECT(PSJOS:ST,1:SUB),ON)=DN_"^"_$GET(NF)
SET PSJOCNT=PSJOCNT+1
QUIT
+7 ;
IVSET ;Set IV data in ^TMP("PSJ",$J,.
+1 NEW DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND
+2 IF ON["V"
SET ON55=ON
SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
FOR X=2,3,4,9,17
SET P(X)=$PIECE(Y,U,X)
+3 IF ON["V"
IF (P(2)="")
IF (P(3)="")
QUIT
+4 IF ON'["V"
SET ND=$GET(^PS(53.1,+ON,0))
IF 'ND
KILL ^PS(53.1,"AS",SD,PSGP,+ON)
QUIT
+5 IF ON'["V"
IF ND
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
SET Y=$GET(^PS(53.1,+ON,2))
SET P(9)=$PIECE(Y,U)
SET P(2)=$PIECE(Y,U,2)
SET P(3)=$PIECE(Y,U,4)
SET P(4)=$PIECE($GET(^PS(53.1,+ON,8)),U)
SET P("PRNTON")=$PIECE($GET(^PS(53.1,+ON,.2)),U,8)
+6 IF ON'["V"
IF P("PRNTON")]""
NEW PSJOK
SET PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP)
IF 'PSJOK
QUIT
+7 DO @$SELECT(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA")
DO GTOT^PSIVUTL(P(4))
+8 IF $GET(DRG)
SET DRGT=$SELECT($GET(DRG("AD",1))]"":$PIECE($GET(DRG("AD",1)),U,2),1:$PIECE($GET(DRG("SOL",1)),U,2))
SET ORTX=DRGT
+9 IF $GET(ORTX)=""
IF (ON'["V")
DO DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1)
SET ORTX=NAME(1)
+10 ;* I $G(ORTX)=""!(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
+11 IF $GET(ORTX)=""
SET ORTX="NOT FOUND"
+12 ;
IVSET1 ;
+1 ;* S TYP=$S(P(2)=P(3):"O",1:"C"),STAT=$S("ED"[P(17):"O",P(17)="P":"P",1:"A")
+2 SET TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3))
IF TYP'="O"
SET TYP=$SELECT(ON["P":"z",1:"C")
+3 SET STAT=$SELECT($GET(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
+4 IF P(17)="P"
SET STAT="C"_$SELECT($PIECE($GET(^PS(53.1,+ON,.2)),U,8)]"":"D",$PIECE($GET(^PS(53.1,+ON,.2)),U,4)="S":"A",$PIECE($GET(^(0)),U,24)="R":"C",1:"B")
+5 IF ON["P"
IF $GET(P("PRNTON"))]""
IF PRNTON=+P("PRNTON")
QUIT
+6 IF ON["P"
IF $GET(P("PRNTON"))]""
SET PRNTON=+P("PRNTON")
SET ON=+P("PRNTON")
+7 SET ^TMP("PSJ",$JOB,STAT,$SELECT(PSJOS:-P(2),1:TYP),$SELECT(PSJOS:TYP,1:ORTX),ON)="^F"
SET PSJOCNT=PSJOCNT+1
+8 QUIT
+9 ;
ENU ; update status field to reflect expired orders, if necessary
+1 WRITE !!,"...a few moments, I have some updating to do..."
ENUNM ;
+1 FOR Q=+PSJPAD:0
SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
IF 'Q!(Q>PSGDT)
QUIT
SET UPD=Q
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
IF 'QQ
QUIT
IF $DATA(^PS(55,PSGP,5,QQ,0))
IF "DEH"'[$EXTRACT($PIECE(^(0),"^",9))
Begin DoDot:1
+2 ; naked ref below refers to line above
+3 SET $PIECE(^(0),"^",9)="E"
SET ORIFN=$PIECE(^(0),"^",21)
DO EN1^PSJHL2(PSGP,"SC",QQ_"U")
End DoDot:1
+4 KILL UPD
QUIT
+5 ;
EN(PSJPTYP) ; enter here
+1 ; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
+2 NEW PSJX,PSJY
+3 ; Initialize if no 'View Profile' option selected
SET PSJOL=$GET(PSJOL)
+4 IF PSJOL="L"
IF $DATA(XRTL)
DO T0^%ZOSV
+5 KILL ^TMP("PSJ",$JOB)
DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET DT=$$DT^XLFDT
SET PSJOS=$PIECE(PSJSYSP0,"^",11)
SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)
+6 SET PSJOCNT=0
IF PSJPTYP>1
FOR PSJORD=0:0
SET PSJORD=$ORDER(^PS(55,DFN,"IV",PSJORD))
IF 'PSJORD
QUIT
Begin DoDot:1
+7 SET PSJX=$GET(^PS(55,DFN,"IV",+PSJORD,0))
+8 SET PSJY=$PIECE(PSJX,U,17)
+9 IF $PIECE(PSJX,U,3)<PSGDT
IF "AR"[PSJY
SET $PIECE(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E"
SET PSJY="E"
SET ON=+PSJORD
DO EXPIR^PSIVOE
+10 IF +PSJSYSU=3
IF ('+$PIECE($GET(^PS(55,DFN,"IV",+PSJORD,4)),U,4))
IF ($PIECE($GET(^(.2)),U,4)="D")
SET PSJPRI="D"
+11 IF $SELECT($GET(PSJPRI)="D":1,PSJY="P":0,PSJOL="L":1,1:"DPE"'[PSJY)
SET ON=+PSJORD_"V"
DO IVSET
KILL PSJPRI,ON
End DoDot:1
+12 DO NOW^%DTC
SET PSJIVOF=PSJOCNT
SET PSGDT=%
SET (X1,DT)=$PIECE(%,".")
SET X2=-2
DO C^%DTC
SET PSGODT=X_(PSGDT#1)
SET HDT=$$ENDTC^PSGMI(PSGDT)
+13 DO ENUNM
+14 IF PSJPTYP'=2
FOR ST="C","O","OC","P","R"
FOR SD=+PSJPAD:0
SET SD=$ORDER(^PS(55,PSGP,5,"AU",ST,SD))
IF 'SD
QUIT
FOR O=0:0
SET O=$ORDER(^PS(55,PSGP,5,"AU",ST,SD,O))
IF 'O
QUIT
DO ECHK
+15 IF $DATA(PSGONNV)
QUIT
+16 ;I PSJPTYP'=2 F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
+17 NEW PRNTON
FOR SD="I","N"
SET (PRNTON,O)=0
FOR
SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
IF 'O
QUIT
SET ON=+O_"P"
SET X=$PIECE($GET(^PS(53.1,+O,0)),U,4)
IF $SELECT(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1)
DO NVSET
+18 ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S O=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
+19 NEW PRNTON
SET (PRNTON,O)=0
SET SD="P"
FOR
SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
IF 'O
QUIT
SET ON=O_"P"
SET X=$PIECE($GET(^PS(53.1,+O,0)),U,4)
IF $SELECT(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1)
DO @$SELECT("FI"[X:"IVSET",1:"NVSET")
+20 IF PSJOL="L"
IF $DATA(XRT0)
SET XRTN="PSJO1"
DO T1^%ZOSV
+21 QUIT
+22 ;
NVSET ; Set up orders from 53.1.
+1 NEW ND
SET ND=$GET(^PS(53.1,O,0))
IF 'ND
Begin DoDot:1
+2 KILL ^PS(53.1,"AS",SD,PSGP,O)
End DoDot:1
QUIT
+3 IF $PIECE(ND,U,15)
IF $GET(PSGP)
IF PSGP'=$PIECE(ND,U,15)
Begin DoDot:1
+4 KILL ^PS(53.1,"AS",SD,PSGP,O)
End DoDot:1
QUIT
+5 IF $PIECE(ND,U,9)["D"
Begin DoDot:1
+6 KILL ^PS(53.1,"AS",SD,PSGP,O)
+7 NEW ND2
SET ND2=$GET(^PS(53.1,O,.2))
IF $PIECE(ND2,U,8)
KILL ^PS(53.1,"ACX",$PIECE(ND2,U,8))
End DoDot:1
QUIT
+8 SET ST=$PIECE($GET(^PS(53.1,O,0)),U,7)
SET START=-$PIECE($GET(^(2)),U,2)
SET P("PRNTON")=$PIECE($GET(^PS(53.1,O,.2)),"^",8)
IF ST=""
SET ST="z"
+9 SET C=$SELECT(((SD="N")&($PIECE($GET(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$PIECE($GET(^PS(53.1,O,.2)),U,8)]"":"CD",$PIECE($GET(^PS(53.1,O,.2)),U,4)="S":"CA",$PIECE($GET(^(0)),U,24)="R":"CC",1:"CB")
+10 ;I C="CC" S C=$$CKPC^PSGOU(PSGP,+$P($G(^PS(53.1,O,0)),U,25),O)
+11 DO SET
+12 QUIT
+13 ;
KILL ;
+1 KILL P,STAT,TYP,ORTX,N,JJ
+2 QUIT
COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
+1 SET OK=0
+2 IF PSJCOM=0
SET OK=1
QUIT OK
+3 IF PSJCOM=""
QUIT OK
+4 IF PSJPTYP=""
QUIT OK
+5 IF '$DATA(^PS(53.1,"ACX",PSJCOM))
QUIT OK
+6 SET OK=1
IF PSJPTYP=3
QUIT OK
+7 NEW PSJON
SET PSJON=""
+8 FOR
SET PSJON=$ORDER(^PS(53.1,"ACX",PSJCOM,PSJON))
IF 'PSJON
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",9)["D"
KILL ^PS(53.1,"ACX",PSJCOM)
+10 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",4)'="U"
IF PSJPTYP=1
SET OK=0
QUIT
+11 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",4)="U"
IF PSJPTYP=2
SET OK=0
QUIT
End DoDot:1
IF OK=0
QUIT
+12 QUIT OK
