PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;29-May-2012 14:29;PLS
;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,1013,110,134,1015**;16 DEC 97;Build 62
;
; 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.
; Modified - 10/24/2011 - Lines AC+10, NC+4, EN+1, DCOR+2 - add comments to hl7 message
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="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)=""
N PSJTX
S PSJTX=$S($L($G(INCOM)):INCOM_"-",1:"")_"ORDER DISCONTINUED" ;IHS/MSC/MGH Patch 13 added text
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-verifed 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
N PSJTX
S PSJTX=$S($L($G(INCOM)):INCOM_"-",1:"")_"ORDER CANCELLED" ;IHS/MSC/MGH Patch 13 added text
D EN1^PSJHL2(PSGP,"OC",PSGORD,PSJTX)
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
N INCOM
S INCOM=""
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 comments IHS/MSC/MGH Patch 1013
S INCOM=$$INPTCOM^APSPFUNC()
;Prompt for requesting provider
W ! I '$$REQPROV^PSGOEC G EN1
W !
;
;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")
N PSJTX
S PSJTX=$S($L($G(INCOM)):INCOM_"-",1:"")_"ORDER DISCONTINUED" ;IHS/MSC
D EN1^PSJHL2(PSGP,PSOC,PSGORD,PSJTX) ;IHS/MSC/MGH Patch 1013
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
PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;29-May-2012 14:29;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,1013,110,134,1015**;16 DEC 97;Build 62
+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 ; Modified - 10/24/2011 - Lines AC+10, NC+4, EN+1, DCOR+2 - add comments to hl7 message
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="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 NEW PSJTX
+11 ;IHS/MSC/MGH Patch 13 added text
SET PSJTX=$SELECT($LENGTH($GET(INCOM)):INCOM_"-",1:"")_"ORDER DISCONTINUED"
+12 DO EN1^PSJHL2(PSGP,"OD",PSGORD)
SET DA(1)=PSGP
SET DA=+PSGORD
+13 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
+14 QUIT
+15 ;
NC ; discontinue non-verifed 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 NEW PSJTX
+5 ;IHS/MSC/MGH Patch 13 added text
SET PSJTX=$SELECT($LENGTH($GET(INCOM)):INCOM_"-",1:"")_"ORDER CANCELLED"
+6 DO EN1^PSJHL2(PSGP,"OC",PSGORD,PSJTX)
+7 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
+8 IF $GET(PSJDCTYP)
DO UNL^PSSLOCK(DFN,PSGORD)
+9 QUIT
+10 ;
EN ; enter here
+1 NEW INCOM
+2 SET INCOM=""
+3 ;Use for Speed DC in IV Order Profile
IF $GET(PSJIVPRF)
DO ^PSIVSPDC
QUIT
+4 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 comments IHS/MSC/MGH Patch 1013
+7 SET INCOM=$$INPTCOM^APSPFUNC()
+8 ;Prompt for requesting provider
+9 WRITE !
IF '$$REQPROV^PSGOEC
GOTO EN1
+10 WRITE !
+11 ;
+12 ;Replaced above line with block structure below.
+13 NEW COMFLG,PSJCOM
SET (EXITLOOP,PSJCOM)=0
+14 FOR PSGOECS=1:1:PSGODDD
Begin DoDot:1
+15 FOR PSGOECS1=1:1
Begin DoDot:2
+16 SET PSGOECS2=$PIECE(PSGODDD(PSGOECS),",",PSGOECS1)
+17 IF 'PSGOECS2
SET EXITLOOP=1
QUIT
+18 SET (ON,PSGORD)=^TMP("PSJON",$JOB,PSGOECS2)
+19 IF PSGORD=+PSGORD
DO DCCOM
QUIT
+20 IF '$$LS^PSSLOCK(DFN,PSGORD)
Begin DoDot:3
+21 IF PSGORD'["V"
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
QUIT
+22 WRITE !
IF PSGORD["V"
NEW PSJLINE
SET PSJLINE=1
DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
Begin DoDot:4
+23 FOR X=0:0
SET X=$ORDER(PSJOC(ON,X))
IF 'X
QUIT
Begin DoDot:5
+24 WRITE !,$GET(PSJOC(ON,X))
End DoDot:5
End DoDot:4
WRITE !,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
End DoDot:3
QUIT
+25 DO CHKCOM
IF COMFLG
Begin DoDot:3
+26 IF PSGORD'["V"
WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
QUIT
+27 WRITE !
IF PSGORD["V"
NEW PSJLINE
SET PSJLINE=1
DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
Begin DoDot:4
+28 FOR X=0:0
SET X=$ORDER(PSJOC(ON,X))
IF 'X
QUIT
Begin DoDot:5
+29 WRITE !,$GET(PSJOC(ON,X))
End DoDot:5
End DoDot:4
WRITE !,"NO ACTION WAS TAKEN",!,$CHAR(7)
HANG 1
End DoDot:3
+30 IF PSJCOM
QUIT
+31 IF (PSGORD["U")
DO AC
+32 IF (PSGORD["P")
DO NC
+33 IF (PSGORD["V")
DO SPDCIV^PSIVSPDC
+34 ; Call the unlock procedure
+35 DO UNL^PSSLOCK(DFN,PSGORD)
End DoDot:2
IF EXITLOOP=1
QUIT
End DoDot:1
+36 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 NEW PSJTX
+3 ;IHS/MSC
SET PSJTX=$SELECT($LENGTH($GET(INCOM)):INCOM_"-",1:"")_"ORDER DISCONTINUED"
+4 ;IHS/MSC/MGH Patch 1013
DO EN1^PSJHL2(PSGP,PSOC,PSGORD,PSJTX)
+5 QUIT
+6 ;
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
