PSGOEC ;BIR/CML3-CANCEL ORDERS ;29-May-2012 14:29;PLS
;;5.0; INPATIENT MEDICATIONS ;**23,58,1013,110,175,201,134,1015**;16 DEC 97;Build 62
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSSLOCK is supported by DBIA 2789.
; Modified - IHS/MSC/PLS - 10/17/2011 - Line SOC+2
ENA ; all orders
D ENCV^PSGSETU Q:$D(XQUIT) S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
F W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:% D ENCAM^PSGOEM
S PSGCF=0 Q:%<0 S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND Q
E F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 Q
E G DONE
W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1
W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400
F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND W "." D RS,^PSGAL5
F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 W "." D RS
W " . . . DONE!" G DONE
ENCA ;
D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1 F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2 I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q
E F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2 I $P($G(^PS(53.1,Q2,0)),U,21) Q
I S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D G DONE
.W !!,$C(7),"No changes made to this order." D PAUSE^VALM1
S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET
F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"A" D AC
D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"N" D NC
W " . . . DONE!" K PSGORD G DONE
ENO(PSGP,PSGORD) ; single order
I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q
S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ)))
S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8))
I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q
I $$PNDRNOK(PSGORD) N PSJDCTYP S PSJDCTYP=$$PNDRNA(PSGORD) D:(PSJDCTYP=1!(PSJDCTYP=2)) PNDRN($G(PSJDCTYP),PSGORD) G DONE
I PSJCOM W !!,"This order 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 ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:% D ENCOM^PSGOEM
I %<0 S VALMBCK="" Q
G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS"
I D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!"
G DONE
SOC ;
I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..."
E I CF,'($G(PSJDCTYP)=2) S INCOM=$$INPTCOM^APSPFUNC() S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE ;IHS/MSC/PLS - 10/17/2011
; prompt for requesting provider
I '($G(PSJDCTYP)=2) I CF,'$$REQPROV D ABORT^PSGOEE G DONE
K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP
I 'PSJCOM D
.I PSGORD["U" D ASET:CF,AC
.I PSGORD'["U" D NSET:CF,NC
I PSJCOM N COMFLG S COMFLG=0 D
. I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM)) D
.. N O S O="" F S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O="" S (PSGORD,PSJORD)=O_"P" D NSET,NC
.I PSGORD["U" 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="" Q:COMFLG D
.. Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
I PSJCOM 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["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D
.. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA
. I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC
Q
D1 N %,DA,DIE,DIU,STP,NSTOP
D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE
I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
Q
OUT ;
W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1
DONE ;
K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP Q
ASET ;
S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"")
Q
NSET ;
S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q
AC ;
I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5
I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
Q:'CF K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)=""
I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS
S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS
Q
NC ;
I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
Q:'CF S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21)
I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK
I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS
Q
T ;
F W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:% D ENCTM^PSGOEM1
S T=$S(%<0:"^",1:$E("T",%=1)) Q
RS ;
; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
S $P(^(4),U,11,14)="^^^" Q
REQPROV() ;
I $G(PSJDCTYP)=2 Q 1
K PSJDCPRV,DIC,DUOUT,DTOUT,Y
N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
I PROVIDER>0 D
.S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
.K DIC,DR,DA,DIQ
.I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D
..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1
..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR
K DIC S DIC=200,DIC(0)="AEMQZ"
S:PROVNAME]"" DIC("B")=PROVNAME
S DIC("A")="Requesting PROVIDER: "
S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC
I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y
Q RESULT
;
PNDRNA(ORDER) ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order
; Perform this action only for pending renewals
I '$G(ORDER)!'($G(ORDER)["P") Q 3
; Quit if original order is no longer active
N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD D I ORIGSTOP<$G(PSGDT) Q 1
.S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
N NDP2
S NDP2=^PS(53.1,+ORDER,.2) S DRG=NDP2,DO=$P(DRG,"^",2) S DRG=$$ENPDN^PSGMI($P(DRG,"^"))
S ND2=^PS(53.1,+ORDER,2) S SCH=$P(ND2,"^"),START=$P(ND2,"^",2),START=$$FMTE^XLFDT(START,2)
W !!?5,DRG_" "_DO
W !?5,"This order has a pending status. If this pending order"
W !?5,"is discontinued, the original order may still be active."
S DIR("A")="Select order(s) to discontinue"
S DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken"
S DIR("L",1)="1 - DC BOTH Orders"
S DIR("L",2)="2 - DC Pending Order"
S DIR("L",3)="3 - Cancel - No Action Taken" D ^DIR
; Reverse order - Y=1 - Pending only Y=2:BOTH
S Y=$S(Y=1:2,Y=2:1,1:3)
Q Y
;
PNDRN(PSJDCTYP,ORDER) ; Perform Discontinue action for Pending order only or both Pending and Renewed
; Perform this action only for pending renewals
N PSGORD S PSGORD=ORDER
Q:'$G(PSGORD)!'($G(PSGORD)["P")
I PSJDCTYP=1 G SOC
I PSJDCTYP=2 S PSJDCTYP=1 D SOC 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 SOC K PSJDCTYP
Q
PNDRNOK(ORDER) ; Execute DC Pending Renew if
; 1) Renewal order is pending/non-verified, and
; 2) Original order is not DC'd or Expired
Q:'$G(PSGORD)!'($G(PSGORD)["P") 0
N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD 0 D I ORIGSTOP<$G(PSGDT) Q 0
.S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
Q:'($P($G(^PS(53.1,+PSGORD,0)),U,24)="R") 0
Q 1
PSGOEC ;BIR/CML3-CANCEL ORDERS ;29-May-2012 14:29;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**23,58,1013,110,175,201,134,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PSSLOCK is supported by DBIA 2789.
+5 ; Modified - IHS/MSC/PLS - 10/17/2011 - Line SOC+2
ENA ; all orders
+1 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
SET CF=$PIECE(PSJSYSP0,U,5)
NEW ND,ND1
SET ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
SET ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
+2 FOR
WRITE !!,"Do you want to ",$SELECT(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders"
SET %=1
DO YN^DICN
IF %
QUIT
DO ENCAM^PSGOEM
+3 SET PSGCF=0
IF %<0
QUIT
SET PSGCF=1
SET T=$EXTRACT("T",'PSJSYSU)
IF %=1
GOTO ENCA
FOR T=0:0
SET T=$ORDER(^PS(55,PSGP,5,"AUS",T))
IF 'T
QUIT
FOR PSGDA=0:0
SET PSGDA=$ORDER(^PS(55,PSGP,5,"AUS",T,PSGDA))
IF 'PSGDA
QUIT
IF @ND
QUIT
+4 IF '$TEST
FOR PSGDA=0:0
SET PSGDA=$ORDER(^PS(53.1,"AC",PSGP,PSGDA))
IF 'PSGDA
QUIT
IF @ND1
QUIT
+5 IF '$TEST
GOTO DONE
+6 WRITE !!,"SOME OR ALL OF THESE ORDERS HAVE"
DO ENUMK^PSGOEM
IF %'=1
QUIT
+7 WRITE !!,"...a few moments, please..."
SET PSGAL("C")=PSJSYSU*10+21400
+8 FOR T=PSGDT:0
SET T=$ORDER(^PS(55,PSGP,5,"AUS",T))
IF 'T
QUIT
FOR PSGDA=0:0
SET PSGDA=$ORDER(^PS(55,PSGP,5,"AUS",T,PSGDA))
IF 'PSGDA
QUIT
IF @ND
WRITE "."
DO RS
DO ^PSGAL5
+9 FOR PSGDA=0:0
SET PSGDA=$ORDER(^PS(53.1,"AC",PSGP,PSGDA))
IF 'PSGDA
QUIT
IF @ND1
WRITE "."
DO RS
+10 WRITE " . . . DONE!"
GOTO DONE
ENCA ;
+1 DO NOW^%DTC
SET (Q1,PSGDT)=+$EXTRACT(%,1,12)
FOR
SET Q1=$ORDER(^PS(55,PSGP,5,"AUS",Q1))
IF 'Q1
QUIT
FOR Q2=0:0
SET Q2=$ORDER(^PS(55,PSGP,5,"AUS",Q1,Q2))
IF 'Q2
QUIT
IF $PIECE($GET(^PS(55,PSGP,5,Q2,0)),"^",21)
QUIT
+2 IF '$TEST
FOR Q2=0:0
SET Q2=$ORDER(^PS(53.1,"AC",PSGP,Q2))
IF 'Q2
QUIT
IF $PIECE($GET(^PS(53.1,Q2,0)),U,21)
QUIT
+3 IF $TEST
SET PSJNOO=$$ENNOO^PSJUTL5("D")
IF PSJNOO<0!('$$REQPROV)
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"No changes made to this order."
DO PAUSE^VALM1
End DoDot:1
GOTO DONE
+5 SET PSGALR=$SELECT('$DATA(PSGALO):20,PSGALO?4N&($EXTRACT(PSGALO)=1):10,1:20)
IF $PIECE(PSJSYSP0,U,5)
DO ENHE^PSJADT0
SET PSGOP=PSGP
DO ASET
+6 FOR SD=PSGDT:0
SET SD=$ORDER(^PS(55,PSGP,5,"AUS",SD))
IF 'SD
QUIT
FOR PSGORD=0:0
SET PSGORD=$ORDER(^PS(55,PSGP,5,"AUS",SD,PSGORD))
IF 'PSGORD
QUIT
SET PSGORD=+PSGORD_"A"
DO AC
+7 DO NSET
SET CF=$PIECE(PSJSYSP0,U,5)
FOR PSGORD=0:0
SET PSGORD=$ORDER(^PS(53.1,"AC",PSGP,PSGORD))
IF 'PSGORD
QUIT
SET PSGORD=+PSGORD_"N"
DO NC
+8 WRITE " . . . DONE!"
KILL PSGORD
GOTO DONE
ENO(PSGP,PSGORD) ; single order
+1 IF PSGSTAT="D"
WRITE !,"This order has already been DISCONTINUED."
DO PAUSE^VALM1
QUIT
+2 SET CF=$SELECT($PIECE(PSJSYSP0,U,5):1,PSGORD["U":0,1:($PIECE($GET(^PS(53.1,+PSGORD,0)),U,25)=""&($PIECE($GET(^(4)),U,7)=DUZ)))
+3 SET PSJCOM=+$SELECT(PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8))
+4 IF 'CF
IF PSJCOM
WRITE !!,"This order is part of a complex order and CANNOT be marked for discontinuation."
QUIT
+5 IF $$PNDRNOK(PSGORD)
NEW PSJDCTYP
SET PSJDCTYP=$$PNDRNA(PSGORD)
IF (PSJDCTYP=1!(PSJDCTYP=2))
DO PNDRN($GET(PSJDCTYP),PSGORD)
GOTO DONE
+6 IF PSJCOM
WRITE !!,"This order 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)
+7 FOR
WRITE !!,"Do you want to ",$SELECT(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation")
SET %=1
DO YN^DICN
IF %
QUIT
DO ENCOM^PSGOEM
+8 IF %<0
SET VALMBCK=""
QUIT
+9 IF %=1
GOTO SOC
IF $SELECT(PSGORD["U":$DATA(^PS(55,PSGP,5,+PSGORD,4)),1:$DATA(^PS(53.1,+PSGORD,4)))
IF $PIECE(^(4),U,12)
WRITE !!,"THIS ORDER HAS"
+10 IF $TEST
DO ENUMK^PSGOEM
IF %=1
WRITE "..."
KILL DA
IF PSGORD["A"
SET PSGAL("C")=PSJSYSU*10+21400
SET DA=+PSGORD
SET DA(1)=PSGP
DO RS
IF PSGORD["A"
DO ^PSGAL5
WRITE " . . . DONE!"
+11 GOTO DONE
SOC ;
+1 IF 'CF
IF '$PIECE($SELECT(PSGORD["U":$GET(^PS(55,PSGP,5,+PSGORD,0)),1:$GET(^PS(53.1,+PSGORD,0))),U,21)
WRITE !!,"...one moment, please..."
+2 ;IHS/MSC/PLS - 10/17/2011
IF '$TEST
IF CF
IF '($GET(PSJDCTYP)=2)
SET INCOM=$$INPTCOM^APSPFUNC()
SET PSJNOO=$$ENNOO^PSJUTL5("D")
IF PSJNOO<0
DO ABORT^PSGOEE
GOTO DONE
+3 ; prompt for requesting provider
+4 IF '($GET(PSJDCTYP)=2)
IF CF
IF '$$REQPROV
DO ABORT^PSGOEE
GOTO DONE
+5 KILL DA
DO NOW^%DTC
SET PSGDT=%
SET T=$EXTRACT("T",'PSJSYSU)
SET PSGALR=20
SET DA=+PSGORD
SET DA(1)=PSGP
+6 IF 'PSJCOM
Begin DoDot:1
+7 IF PSGORD["U"
IF CF
DO ASET
DO AC
+8 IF PSGORD'["U"
IF CF
DO NSET
DO NC
End DoDot:1
+9 IF PSJCOM
NEW COMFLG
SET COMFLG=0
Begin DoDot:1
+10 IF PSGORD["P"
IF ('$$LOCK^PSJOEA(PSGP,PSJCOM))
QUIT
Begin DoDot:2
+11 NEW O
SET O=""
FOR
SET O=$ORDER(^PS(53.1,"ACX",PSJCOM,O))
IF O=""
QUIT
SET (PSGORD,PSJORD)=O_"P"
DO NSET
DO NC
End DoDot:2
+12 IF PSGORD["U"
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
IF COMFLG
QUIT
Begin DoDot:2
+13 IF OO=PSGORD
QUIT
IF '$$LS^PSSLOCK(DFN,OO)
SET COMFLG=1
QUIT
End DoDot:2
End DoDot:1
+14 IF PSJCOM
IF COMFLG
QUIT
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["V"
SET ON55=OO
DO D1^PSIVOPT2
SET PSIVALT=1
SET PSIVALCK="STOP"
SET PSIVREA="D"
SET ON=ON55
SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
Begin DoDot:2
+16 DO LOG^PSIVORAL
NEW PSJORD
SET PSJORD=ON55
SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
SET P("NAT")=PSJNOO
DO HL^PSIVORA
End DoDot:2
+17 IF OO["U"
NEW PSGORD,PSJORD
SET (PSGORD,PSJORD)=OO
DO ASET^PSGOEC
DO AC^PSGOEC
End DoDot:1
+18 QUIT
D1 NEW %,DA,DIE,DIU,STP,NSTOP
+1 DO NOW^%DTC
SET NSTOP=+$EXTRACT(%,1,12)
SET STP=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
SET NSTOP=+$SELECT(STP>NSTOP:NSTOP,1:STP)
SET P(17)="D"
+2 SET DA(1)=DFN
SET DA=+ON55
SET DIE="^PS(55,"_DFN_",""IV"","
SET DR="109////"_NSTOP_$SELECT('$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP
SET PSIVACT=1
DO ^DIE
+3 IF $SELECT($GET(PSIVAC)="OD":0,$GET(PSIVAC)'="AD":1,$GET(PSGALO)<1060:0,1:$PIECE($GET(PSJSYSW0),U,15))
SET X=$SELECT($GET(PSIVAC)="AD":1,1:2)
DO ENLBL^PSIVOPT(X,$SELECT(X=1:+$GET(PSGUOW),1:DUZ),DFN,3,+ON55,$EXTRACT("AD",1,3-X))
+4 ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
IF '$DATA(PSJIVORF)
DO ORPARM^PSIVOREN
IF 'PSJIVORF
QUIT
+5 QUIT
OUT ;
+1 WRITE $SELECT(PSJCOM:"...ORDER ",1:"...ORDERS "),$SELECT(CF:"DISCONTINUED!",1:"MARKED!")
SET PSGCANFL=1
DONE ;
+1 KILL CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP
QUIT
ASET ;
+1 SET DIE="^PS(55,"_PSGP_",5,"
SET DR="28////"_$SELECT($PIECE($GET(^PS(55,PSGP,5,+$GET(PSJORD),0)),U,27)="E":"DE",$DATA(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$SELECT(T]"":";49////1",1:"")
+2 QUIT
NSET ;
+1 SET DIE="^PS(53.1,"
SET DR="28////"_$SELECT($PIECE($GET(^PS(53.1,+$GET(PSJORD),0)),U,27)="E":"DE",$DATA(PSGEDIT):"DE",1:"D")_$SELECT(T]"":";42////1",1:"")_";25////"_PSGDT
QUIT
AC ;
+1 IF 'CF
KILL DA
SET $PIECE(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT
SET PSGAL("C")=13040
SET DA=+PSGORD
SET DA(1)=PSGP
DO ^PSGAL5
+2 IF 'CF
IF $DATA(PSJSYSO)
SET PSGORD=+PSGORD_"A"
SET PSGPOSA="C"
SET PSGPOSD=PSGDT
DO ENPOS^PSGVDS
+3 IF 'CF
QUIT
KILL DA,ORIFN
SET PSGAL("C")=PSJSYSU*10+4000
SET DA=+PSGORD
SET DA(1)=PSGP
DO ^PSGAL5
SET $PIECE(^(2),U,3)=$PIECE(^PS(55,PSGP,5,+PSGORD,2),U,4)
DO ^DIE
SET ^PS(55,"AUE",PSGP,+PSGORD)=""
+4 IF PSJSYSL
KILL DA
SET $PIECE(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$SELECT($DATA(PSGEDIT):"DE",1:"D")
SET PSGTOL=2
SET PSGUOW=DUZ
SET PSGTOO=1
SET DA=+PSGORD
SET DA(1)=PSGP
DO ENL^PSGVDS
+5 SET ORIFN=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),U,21)
IF ORIFN
DO DCOR^PSGOECS
+6 QUIT
NC ;
+1 IF 'CF
SET $PIECE(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
+2 IF 'CF
IF $DATA(PSJSYSO)
SET PSGORD=+PSGORD_"N"
SET PSGPOSA="C"
SET PSGPOSD=PSGDT
DO ENPOS^PSGVDS
+3 IF 'CF
QUIT
SET PSGSTAT=$PIECE($GET(^PS(53.1,+PSGORD,0)),U,9)
SET PSGORIFN=$PIECE($GET(^(0)),U,21)
+4 IF PSGSTAT'="U"
KILL DA,ORIFN
SET DA=+PSGORD
DO ^DIE
IF PSJSYSL
IF PSJSYSL<3
IF (PSGSTAT'="P")
SET $PIECE(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$SELECT($DATA(PSGEDIT):"DE",1:"D")
SET PSGTOO=2
SET PSGUOW=DUZ
SET PSGTOL=2
DO ENL^PSGVDS
+5 IF PSGSTAT="U"
KILL DA
SET DA=+PSGORD
SET DIK="^PS(53.1,"
DO ^DIK
+6 IF PSGORIFN
SET ORIFN=PSGORIFN
DO DCOR^PSGOECS
+7 QUIT
T ;
+1 FOR
WRITE !!,"Is this due to the patient being transferred"
SET %=2
DO YN^DICN
IF %
QUIT
DO ENCTM^PSGOEM1
+2 SET T=$SELECT(%<0:"^",1:$EXTRACT("T",%=1))
QUIT
RS ;
+1 ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
+2 SET $PIECE(^(4),U,11,14)="^^^"
QUIT
REQPROV() ;
+1 IF $GET(PSJDCTYP)=2
QUIT 1
+2 KILL PSJDCPRV,DIC,DUOUT,DTOUT,Y
+3 NEW PROVIDER,PROVNAME,RESULT,RSB
SET RESULT=0
+4 SET PROVIDER=+$PIECE($GET(^PS(55,DFN,5.1)),"^",2)
SET PROVNAME=""
+5 IF PROVIDER>0
Begin DoDot:1
+6 SET DIC=200
SET DR="53.1;53.4"
SET DIQ="RSB"
SET DIQ(0)="I"
SET DA=PROVIDER
DO EN^DIQ1
+7 KILL DIC,DR,DA,DIQ
+8 IF $GET(RSB(200,PROVIDER,53.1,"I"))="1"&(($GET(RSB(200,PROVIDER,53.4,"I"))="")!($GET(RSB(200,PROVIDER,53.4,"I"))>DT))
Begin DoDot:2
+9 SET DIC=200
SET DA=PROVIDER
SET DR=".01"
SET DIQ="RSB"
SET DIQ(0)="E"
DO EN^DIQ1
+10 SET PROVNAME=$GET(RSB(200,PROVIDER,.01,"E"))
KILL DA,DIQ,DR
End DoDot:2
End DoDot:1
+11 KILL DIC
SET DIC=200
SET DIC(0)="AEMQZ"
+12 IF PROVNAME]""
SET DIC("B")=PROVNAME
+13 SET DIC("A")="Requesting PROVIDER: "
+14 SET DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)"
DO ^DIC
KILL DIC
+15 IF +Y>0
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
SET RESULT=1
SET PSJDCPRV=+Y
+16 QUIT RESULT
+17 ;
PNDRNA(ORDER) ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order
+1 ; Perform this action only for pending renewals
+2 IF '$GET(ORDER)!'($GET(ORDER)["P")
QUIT 3
+3 ; Quit if original order is no longer active
+4 NEW ORIGORD,ORIGSTOP
SET ORIGORD=$PIECE($GET(^PS(53.1,+ORDER,0)),"^",25)
IF 'ORIGORD
QUIT
Begin DoDot:1
+5 SET ORIGSTOP=$SELECT(ORIGORD["U":$PIECE($GET(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
End DoDot:1
IF ORIGSTOP<$GET(PSGDT)
QUIT 1
+6 NEW NDP2
+7 SET NDP2=^PS(53.1,+ORDER,.2)
SET DRG=NDP2
SET DO=$PIECE(DRG,"^",2)
SET DRG=$$ENPDN^PSGMI($PIECE(DRG,"^"))
+8 SET ND2=^PS(53.1,+ORDER,2)
SET SCH=$PIECE(ND2,"^")
SET START=$PIECE(ND2,"^",2)
SET START=$$FMTE^XLFDT(START,2)
+9 WRITE !!?5,DRG_" "_DO
+10 WRITE !?5,"This order has a pending status. If this pending order"
+11 WRITE !?5,"is discontinued, the original order may still be active."
+12 SET DIR("A")="Select order(s) to discontinue"
+13 SET DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken"
+14 SET DIR("L",1)="1 - DC BOTH Orders"
+15 SET DIR("L",2)="2 - DC Pending Order"
+16 SET DIR("L",3)="3 - Cancel - No Action Taken"
DO ^DIR
+17 ; Reverse order - Y=1 - Pending only Y=2:BOTH
+18 SET Y=$SELECT(Y=1:2,Y=2:1,1:3)
+19 QUIT Y
+20 ;
PNDRN(PSJDCTYP,ORDER) ; Perform Discontinue action for Pending order only or both Pending and Renewed
+1 ; Perform this action only for pending renewals
+2 NEW PSGORD
SET PSGORD=ORDER
+3 IF '$GET(PSGORD)!'($GET(PSGORD)["P")
QUIT
+4 IF PSJDCTYP=1
GOTO SOC
+5 IF PSJDCTYP=2
SET PSJDCTYP=1
DO SOC
IF '$GET(PSJDCTYP)
QUIT
Begin DoDot:1
+6 IF ($GET(PSJNOO)<0)
QUIT
+7 NEW ND5310
SET ND5310=$GET(^PS(53.1,+PSGORD,0))
+8 NEW PSGORD
SET PSGORD=$PIECE(ND5310,"^",25)
IF PSGORD
SET PSJDCTYP=2
DO SOC
KILL PSJDCTYP
End DoDot:1
+9 QUIT
PNDRNOK(ORDER) ; Execute DC Pending Renew if
+1 ; 1) Renewal order is pending/non-verified, and
+2 ; 2) Original order is not DC'd or Expired
+3 IF '$GET(PSGORD)!'($GET(PSGORD)["P")
QUIT 0
+4 NEW ORIGORD,ORIGSTOP
SET ORIGORD=$PIECE($GET(^PS(53.1,+ORDER,0)),"^",25)
IF 'ORIGORD
QUIT 0
Begin DoDot:1
+5 SET ORIGSTOP=$SELECT(ORIGORD["U":$PIECE($GET(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
End DoDot:1
IF ORIGSTOP<$GET(PSGDT)
QUIT 0
+6 IF '($PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R")
QUIT 0
+7 QUIT 1
