PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM
;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110,134,181**;16 DEC 97;Build 190
;
; Reference to FULL^VALM1 is supported by DBIA# 10116.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSSLOCK is supported by DBIA #2789.
;
AM ;
W !,"...marking ",$P(X,U),"..." S $P(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT,PSGAL("C")=13040 W "." D ^PSGAL5 W "."
I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
Q
;
NM ;
W !,"...marking ",$P(X,U),"..." S $P(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT W "."
I $D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSD=PSGDT,PSGPOSA="C" D ENPOS^PSGVDS
Q
;
AC ; discontinue active order
K DA S DA(1)=PSGP,DA=+PSGORD
S X=$G(^PS(55,PSGP,5,DA,.2))
I $P(X,U,4)="D" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$C(7) HANG 1 Q
NEW XX S XX=$P(^PS(55,PSGP,5,DA,0),U,9)
I $S(XX="E":1,XX="D":1,XX="DE":1,1:0) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$C(7) HANG 1 Q
S X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
I '$P(PSJSYSP0,"^",5) D AM Q
W !,"...discontinuing ",$P(X,U),"...",! S PSGAL("C")=PSJSYSU*10+4000 D ^PSGAL5
S PSGALR=20,DIE="^PS(55,"_PSGP_",5,",DR="136////@;28////D;Q;34////"_PSGDT_$S(PSJSYSU:"",1:";49////1"),DP=55.06,$P(^(2),"^",3)=$P(^PS(55,PSGP,5,DA,2),"^",4) D ^DIE S ^PS(55,"AUE",PSGP,DA)=""
D EN1^PSJHL2(PSGP,"OD",PSGORD) S DA(1)=PSGP,DA=+PSGORD
I PSJSYSL S $P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D",PSGTOL=2,PSGUOW=DUZ,PSGTOO=1 D ENL^PSGVDS
Q
;
NC ; discontinue non-verified order
I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(PSGORD) I $G(PSJDCTYP)'=1 D PNDRN($G(PSJDCTYP)) Q
NC2 ; Called from PNDRN to discontinue both pending renewal and original order
K DA S DA=+PSGORD,X=$G(^PS(53.1,DA,.2)),X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
I $S($P(PSJSYSP0,"^",5):0,'$D(^PS(53.1,DA,4)):1,1:$P(^(4),"^",7)'=DUZ) D NM Q
W !,"...discontinuing ",$P(X,U),"...",! S DIE="^PS(53.1,",DR="28////D"_$S(PSJSYSU:"",1:";42////1") D ^DIE
D EN1^PSJHL2(PSGP,"OC",PSGORD)
S DA=+PSGORD I PSJSYSL,PSJSYSL<3 S $P(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D",PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
I $G(PSJDCTYP) D UNL^PSSLOCK(DFN,PSGORD)
Q
;
EN ; enter here
I $G(PSJIVPRF) D ^PSIVSPDC Q ;Use for Speed DC in IV Order Profile
D FULL^VALM1
EN1 ;
S (PSGONC,PSGLMT)=PSJOCNT,PSGONW="C" D ENWO^PSGON I "^"[X K X G RESET
D NOW^%DTC S PSGDT=+$E(%,1,12)
W ! F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 D
.S PSGORD=^TMP("PSJON",$J,PSGOECS2) ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q
S PSJNOO=$$ENNOO^PSJUTL5("D") G:PSJNOO<0 EN1
;Prompt for requesting provider
W ! I '$$REQPROV^PSGOEC G EN1
W !
;
;F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) D:(PSGORD["U") AC D:(PSGORD["P") NC D:(PSGORD["V") SPDCIV^PSIVSPDC
;Replaced above line with block structure below.
N COMFLG,PSJCOM S (EXITLOOP,PSJCOM)=0
F PSGOECS=1:1:PSGODDD D
.F PSGOECS1=1:1 D Q:EXITLOOP=1
..S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1)
..I 'PSGOECS2 S EXITLOOP=1 Q
..S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2)
..I PSGORD=+PSGORD D DCCOM Q
..I '$$LS^PSSLOCK(DFN,PSGORD) D Q
... W:PSGORD'["V" !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D
.....W !,$G(PSJOC(ON,X))
..D CHKCOM I COMFLG D
... I PSGORD'["V" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D
.....W !,$G(PSJOC(ON,X))
..Q:PSJCOM
..D:(PSGORD["U") AC
..D:(PSGORD["P") NC
..D:(PSGORD["V") SPDCIV^PSIVSPDC
..; Call the unlock procedure
..D UNL^PSSLOCK(DFN,PSGORD)
S X=""
RESET ;
I $G(PSGORD)["V" D INIT^PSJLMHED(3) S VALMBK="R" G DONE
D INIT^PSJLMHED(1) S VALMBCK="R"
;
DONE ;
K DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR
Q
;
DCOR ; Create DC order/update stop date in OE/RR.
S PSOC=$S(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD")
D EN1^PSJHL2(PSGP,PSOC,PSGORD)
Q
;
ENOR ;
K DA S PSGEDIT=$S($D(PSGEDIT):PSGEDIT,1:"D"),CF=1,PSGALR=20,DA=+PSGORD,T="" I PSGORD'["U",(PSGORD'["O") D:CF NSET^PSGOEC D NC^PSGOEC D ENOR2 G DONE^PSGOEC
S DA(1)=PSGP D:CF ASET^PSGOEC D AC^PSGOEC
G DONE^PSGOEC
;
ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit.
I PSGEDIT="DE",$P(^PS(53.1,+PSGORD,0),U,25),$P(^PS(53.1,+PSGORD,0),U,24)="R",PSGSD<$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) D
.K DA,DR S DA(1)=PSGP,DA=+$P(^PS(53.1,+PSGORD,0),U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGSD_";25////"_$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
.D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(^PS(53.1,+PSGORD,0),U,25))
Q
;
CHKCOM ;Check to see if order is part of complex order series.
S PSJCOM=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8)),COMFLG=0
N PSJSTAT S PSJSTAT=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$P($G(^PS(53.1,+PSGORD,0)),"^",9))
Q:'PSJCOM I "DE"[PSJSTAT Q
W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D
.F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D
..W !,$G(PSJOC(ON,X))
I PSGORD["U" W !,$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1) D
.W !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
F W !!,"Do you want to discontinue this series of complex orders" S %=1 D YN^DICN Q:%
I %'=1 S COMFLG=1 Q
N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D Q:COMFLG
.Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
Q:COMFLG
N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D
.I (OO["U") N PSGORD S PSGORD=OO D AC
.I (OO["V") N PSGORD S (ON,PSGORD)=OO D SPDCIV^PSIVSPDC
.D UNL^PSSLOCK(DFN,PSGORD)
Q
;
DCCOM ;DC pending/non-verified complex order
I '$$LOCK^PSJOEA(DFN,PSGORD) W !,"Order # ",PSGOECS2," could not be discontinued.",!,$C(7) HANG 1 Q
N PSGORD1 S PSGORD1=PSGORD
N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSGORD1,PSJO)) Q:'PSJO S PSGORD=PSJO_"P" D NC
Q
PNDRN(PSJDCTYP) ; Discontinue both pending renewal and original order
N TMPORD S TMPORD=$G(PSGORD)
I PSJDCTYP=2 S PSJDCTYP=1 D NC2 Q:'$G(PSJDCTYP) D
.I ($G(PSJNOO)<0) Q
.N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0))
.N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D
..I '$$LS^PSSLOCK(DFN,PSGORD) K PSJDCTYP Q
..D @$S(PSGORD["U":"AC",PSGORD["V":"SPDCIV^PSIVSPDC",1:"")
S PSGORD=TMPORD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOECS 7469 printed Sep 23, 2025@19:38:12 Page 2
PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110,134,181**;16 DEC 97;Build 190
+2 ;
+3 ; Reference to FULL^VALM1 is supported by DBIA# 10116.
+4 ; Reference to ^PS(55 is supported by DBIA# 2191.
+5 ; Reference to ^PSSLOCK is supported by DBIA #2789.
+6 ;
AM ;
+1 WRITE !,"...marking ",$PIECE(X,U),"..."
SET $PIECE(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT
SET PSGAL("C")=13040
WRITE "."
DO ^PSGAL5
WRITE "."
+2 IF $DATA(PSJSYSO)
SET PSGORD=+PSGORD_"A"
SET PSGPOSA="C"
SET PSGPOSD=PSGDT
DO ENPOS^PSGVDS
+3 QUIT
+4 ;
NM ;
+1 WRITE !,"...marking ",$PIECE(X,U),"..."
SET $PIECE(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT
WRITE "."
+2 IF $DATA(PSJSYSO)
SET PSGORD=+PSGORD_"N"
SET PSGPOSD=PSGDT
SET PSGPOSA="C"
DO ENPOS^PSGVDS
+3 QUIT
+4 ;
AC ; discontinue active order
+1 KILL DA
SET DA(1)=PSGP
SET DA=+PSGORD
+2 SET X=$GET(^PS(55,PSGP,5,DA,.2))
+3 IF $PIECE(X,U,4)="D"
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$CHAR(7)
HANG 1
QUIT
+4 NEW XX
SET XX=$PIECE(^PS(55,PSGP,5,DA,0),U,9)
+5 IF $SELECT(XX="E":1,XX="D":1,XX="DE":1,1:0)
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$CHAR(7)
HANG 1
QUIT
+6 SET X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
+7 IF '$PIECE(PSJSYSP0,"^",5)
DO AM
QUIT
+8 WRITE !,"...discontinuing ",$PIECE(X,U),"...",!
SET PSGAL("C")=PSJSYSU*10+4000
DO ^PSGAL5
+9 SET PSGALR=20
SET DIE="^PS(55,"_PSGP_",5,"
SET DR="136////@;28////D;Q;34////"_PSGDT_$SELECT(PSJSYSU:"",1:";49////1")
SET DP=55.06
SET $PIECE(^(2),"^",3)=$PIECE(^PS(55,PSGP,5,DA,2),"^",4)
DO ^DIE
SET ^PS(55,"AUE",PSGP,DA)=""
+10 DO EN1^PSJHL2(PSGP,"OD",PSGORD)
SET DA(1)=PSGP
SET DA=+PSGORD
+11 IF PSJSYSL
SET $PIECE(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D"
SET PSGTOL=2
SET PSGUOW=DUZ
SET PSGTOO=1
DO ENL^PSGVDS
+12 QUIT
+13 ;
NC ; discontinue non-verified order
+1 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R"
SET PSJDCTYP=$$PNDRNA^PSGOEC(PSGORD)
IF $GET(PSJDCTYP)'=1
DO PNDRN($GET(PSJDCTYP))
QUIT
NC2 ; Called from PNDRN to discontinue both pending renewal and original order
+1 KILL DA
SET DA=+PSGORD
SET X=$GET(^PS(53.1,DA,.2))
SET X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
+2 IF $SELECT($PIECE(PSJSYSP0,"^",5):0,'$DATA(^PS(53.1,DA,4)):1,1:$PIECE(^(4),"^",7)'=DUZ)
DO NM
QUIT
+3 WRITE !,"...discontinuing ",$PIECE(X,U),"...",!
SET DIE="^PS(53.1,"
SET DR="28////D"_$SELECT(PSJSYSU:"",1:";42////1")
DO ^DIE
+4 DO EN1^PSJHL2(PSGP,"OC",PSGORD)
+5 SET DA=+PSGORD
IF PSJSYSL
IF PSJSYSL<3
SET $PIECE(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D"
SET PSGTOO=2
SET PSGUOW=DUZ
SET PSGTOL=2
DO ENL^PSGVDS
+6 IF $GET(PSJDCTYP)
DO UNL^PSSLOCK(DFN,PSGORD)
+7 QUIT
+8 ;
EN ; enter here
+1 ;Use for Speed DC in IV Order Profile
IF $GET(PSJIVPRF)
DO ^PSIVSPDC
QUIT
+2 DO FULL^VALM1
EN1 ;
+1 SET (PSGONC,PSGLMT)=PSJOCNT
SET PSGONW="C"
DO ENWO^PSGON
IF "^"[X
KILL X
GOTO RESET
+2 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
+3 WRITE !
FOR PSGOECS=1:1:PSGODDD
FOR PSGOECS1=1:1
SET PSGOECS2=$PIECE(PSGODDD(PSGOECS),",",PSGOECS1)
if 'PSGOECS2
QUIT
Begin DoDot:1
+4 ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q
SET PSGORD=^TMP("PSJON",$JOB,PSGOECS2)
End DoDot:1
+5 SET PSJNOO=$$ENNOO^PSJUTL5("D")
if PSJNOO<0
GOTO EN1
+6 ;Prompt for requesting provider
+7 WRITE !
IF '$$REQPROV^PSGOEC
GOTO EN1
+8 WRITE !
+9 ;
+10 ;F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) D:(PSGORD["U") AC D:(PSGORD["P") NC D:(PSGORD["V") SPDCIV^PSIVSPDC
+11 ;Replaced above line with block structure below.
+12 NEW COMFLG,PSJCOM
SET (EXITLOOP,PSJCOM)=0
+13 FOR PSGOECS=1:1:PSGODDD
Begin DoDot:1
+14 FOR PSGOECS1=1:1
Begin DoDot:2
+15 SET PSGOECS2=$PIECE(PSGODDD(PSGOECS),",",PSGOECS1)
+16 IF 'PSGOECS2
SET EXITLOOP=1
QUIT
+17 SET (ON,PSGORD)=^TMP("PSJON",$JOB,PSGOECS2)
+18 IF PSGORD=+PSGORD
DO DCCOM
QUIT
+19 IF '$$LS^PSSLOCK(DFN,PSGORD)
Begin DoDot:3
+20 if PSGORD'["V"
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
QUIT
+21 WRITE !
IF PSGORD["V"
NEW PSJLINE
SET PSJLINE=1
DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
Begin DoDot:4
+22 FOR X=0:0
SET X=$ORDER(PSJOC(ON,X))
if 'X
QUIT
Begin DoDot:5
+23 WRITE !,$GET(PSJOC(ON,X))
End DoDot:5
End DoDot:4
WRITE !,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
End DoDot:3
QUIT
+24 DO CHKCOM
IF COMFLG
Begin DoDot:3
+25 IF PSGORD'["V"
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
QUIT
+26 WRITE !
IF PSGORD["V"
NEW PSJLINE
SET PSJLINE=1
DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
Begin DoDot:4
+27 FOR X=0:0
SET X=$ORDER(PSJOC(ON,X))
if 'X
QUIT
Begin DoDot:5
+28 WRITE !,$GET(PSJOC(ON,X))
End DoDot:5
End DoDot:4
WRITE !,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
End DoDot:3
+29 if PSJCOM
QUIT
+30 if (PSGORD["U")
DO AC
+31 if (PSGORD["P")
DO NC
+32 if (PSGORD["V")
DO SPDCIV^PSIVSPDC
+33 ; Call the unlock procedure
+34 DO UNL^PSSLOCK(DFN,PSGORD)
End DoDot:2
if EXITLOOP=1
QUIT
End DoDot:1
+35 SET X=""
RESET ;
+1 IF $GET(PSGORD)["V"
DO INIT^PSJLMHED(3)
SET VALMBK="R"
GOTO DONE
+2 DO INIT^PSJLMHED(1)
SET VALMBCK="R"
+3 ;
DONE ;
+1 KILL DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR
+2 QUIT
+3 ;
DCOR ; Create DC order/update stop date in OE/RR.
+1 SET PSOC=$SELECT(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD")
+2 DO EN1^PSJHL2(PSGP,PSOC,PSGORD)
+3 QUIT
+4 ;
ENOR ;
+1 KILL DA
SET PSGEDIT=$SELECT($DATA(PSGEDIT):PSGEDIT,1:"D")
SET CF=1
SET PSGALR=20
SET DA=+PSGORD
SET T=""
IF PSGORD'["U"
IF (PSGORD'["O")
if CF
DO NSET^PSGOEC
DO NC^PSGOEC
DO ENOR2
GOTO DONE^PSGOEC
+2 SET DA(1)=PSGP
if CF
DO ASET^PSGOEC
DO AC^PSGOEC
+3 GOTO DONE^PSGOEC
+4 ;
ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit.
+1 IF PSGEDIT="DE"
IF $PIECE(^PS(53.1,+PSGORD,0),U,25)
IF $PIECE(^PS(53.1,+PSGORD,0),U,24)="R"
IF PSGSD<$PIECE($GET(^PS(55,PSGP,5,+$PIECE(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
Begin DoDot:1
+2 KILL DA,DR
SET DA(1)=PSGP
SET DA=+$PIECE(^PS(53.1,+PSGORD,0),U,25)
SET DIE="^PS(55,"_PSGP_",5,"
SET DR="34////"_PSGSD_";25////"_$PIECE($GET(^PS(55,PSGP,5,+$PIECE(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
+3 DO ^DIE
DO EN1^PSJHL2(PSGP,"XX",$PIECE(^PS(53.1,+PSGORD,0),U,25))
End DoDot:1
+4 QUIT
+5 ;
CHKCOM ;Check to see if order is part of complex order series.
+1 SET PSJCOM=$SELECT(PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$PIECE($GET(^PS(53.1,+PSGORD,.2)),U,8))
SET COMFLG=0
+2 NEW PSJSTAT
SET PSJSTAT=$SELECT(PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",9))
+3 if 'PSJCOM
QUIT
IF "DE"[PSJSTAT
QUIT
+4 WRITE !
IF PSGORD["V"
NEW PSJLINE
SET PSJLINE=1
DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
Begin DoDot:1
+5 FOR X=0:0
SET X=$ORDER(PSJOC(ON,X))
if 'X
QUIT
Begin DoDot:2
+6 WRITE !,$GET(PSJOC(ON,X))
End DoDot:2
End DoDot:1
+7 IF PSGORD["U"
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1)
Begin DoDot:1
+8 WRITE !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)."
DO CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
End DoDot:1
+9 FOR
WRITE !!,"Do you want to discontinue this series of complex orders"
SET %=1
DO YN^DICN
if %
QUIT
+10 IF %'=1
SET COMFLG=1
QUIT
+11 NEW O,OO
SET O=0
SET OO=""
FOR
SET O=$ORDER(^PS(55,"ACX",PSJCOM,O))
if 'O
QUIT
FOR
SET OO=$ORDER(^PS(55,"ACX",PSJCOM,O,OO))
if OO=""
QUIT
Begin DoDot:1
+12 if OO=PSGORD
QUIT
IF '$$LS^PSSLOCK(DFN,OO)
SET COMFLG=1
QUIT
End DoDot:1
if COMFLG
QUIT
+13 if COMFLG
QUIT
+14 NEW O,OO
SET O=0
SET OO=""
FOR
SET O=$ORDER(^PS(55,"ACX",PSJCOM,O))
if 'O
QUIT
FOR
SET OO=$ORDER(^PS(55,"ACX",PSJCOM,O,OO))
if OO=""
QUIT
Begin DoDot:1
+15 IF (OO["U")
NEW PSGORD
SET PSGORD=OO
DO AC
+16 IF (OO["V")
NEW PSGORD
SET (ON,PSGORD)=OO
DO SPDCIV^PSIVSPDC
+17 DO UNL^PSSLOCK(DFN,PSGORD)
End DoDot:1
+18 QUIT
+19 ;
DCCOM ;DC pending/non-verified complex order
+1 IF '$$LOCK^PSJOEA(DFN,PSGORD)
WRITE !,"Order # ",PSGOECS2," could not be discontinued.",!,$CHAR(7)
HANG 1
QUIT
+2 NEW PSGORD1
SET PSGORD1=PSGORD
+3 NEW PSJO
SET PSJO=0
FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSGORD1,PSJO))
if 'PSJO
QUIT
SET PSGORD=PSJO_"P"
DO NC
+4 QUIT
PNDRN(PSJDCTYP) ; Discontinue both pending renewal and original order
+1 NEW TMPORD
SET TMPORD=$GET(PSGORD)
+2 IF PSJDCTYP=2
SET PSJDCTYP=1
DO NC2
if '$GET(PSJDCTYP)
QUIT
Begin DoDot:1
+3 IF ($GET(PSJNOO)<0)
QUIT
+4 NEW ND5310
SET ND5310=$GET(^PS(53.1,+PSGORD,0))
+5 NEW PSGORD
SET PSGORD=$PIECE(ND5310,"^",25)
IF PSGORD
SET PSJDCTYP=2
Begin DoDot:2
+6 IF '$$LS^PSSLOCK(DFN,PSGORD)
KILL PSJDCTYP
QUIT
+7 DO @$SELECT(PSGORD["U":"AC",PSGORD["V":"SPDCIV^PSIVSPDC",1:"")
End DoDot:2
End DoDot:1
+8 SET PSGORD=TMPORD
+9 QUIT
