PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ;9/18/06 2:59pm
;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249,225**;DEC 1997;Build 29
;External reference to File #55 supported by DBIA 2228
;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
Q
APSOD(PSODFN) ;called from file #2 date of death xref 'APOSD'
N D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DQ,DU,DV,DW,DR
S PSODEATH=1 D CAN K PSODEATH
Q
CAN ;discontinued rxs due to death
I $G(PSODFN),$D(^PS(52.91,PSODFN,0)) D
.I '$P($G(^PS(52.91,PSODFN,0)),"^",3)!($P($G(^(0)),"^",3)>DT) S $P(^PS(52.91,PSODFN,0),"^",3)=DT,$P(^PS(52.91,PSODFN,0),"^",4)=5,^PS(52.91,"AX",DT,PSODFN)="" D SET^PSOTPCAN(PSODFN)
F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ I $D(^(PSORXJ,0)) S PSORX=^(0) S STA=$S($P($G(^PSRX(PSORX,"STA")),"^")<11:1,$P($G(^("STA")),"^")=16:1,1:0) D:STA
.I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,"STA")),"^")="" D SETC
.D REVERSE^PSOBPSU1(PSORX,,"DC",7)
.I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,2)),"^",6)'<DT S PSO0=^(0),PSO2=$G(^(2)) D
..S ^PSRX(PSORX,"DDSTA")="52;"_$P(^PSRX(PSORX,"STA"),"^")
..;remove from hold
..I $G(^PSRX(PSORX,"H"))]"" D
...S ^PSRX(PSORX,"DDSTA")="52;"_$P(^PSRX(PSORX,"STA"),"^")_"^"_^PSRX(PSORX,"H")
...K:$P(^PSRX(PSORX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSORX,"H"),"^"),PSORX) S ^PSRX(PSORX,"H")=""
...I '$P($G(^PSRX(PSORX,2)),"^",2),$P($G(^(3)),"^") S $P(^PSRX(PSORX,2),"^",2)=$P(^(3),"^")
...I $G(PSODEATH),$P(^PSRX(PSORX,0),"^",2) S ^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
..;delete from non-verified file
..I $G(^PS(52.4,PSORX,0))]"" S ^PSRX(PSORX,"DDSTA")="52.4;"_$P(^PSRX(PSORX,"STA"),"^")_"^"_^PS(52.4,PSORX,0),DIK="^PS(52.4,",DA=PSORX D ^DIK K DIK
..I $G(PSODEATH),$P(^PSRX(PSORX,0),"^",2) S ^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
..;delete from suspense
..D:$O(^PS(52.5,"B",PSORX,0))
...S DA=$O(^PS(52.5,"B",PSORX,0)) I '$G(^PS(52.5,DA,"P")),$G(PSODEATH) S ^PSRX(PSORX,"DDSTA")="52.5;5^"_^PS(52.5,DA,0),^PSRX("APSOD",$P(^PSRX(PSORX,0),"^",2),PSORX)=""
...I $O(^PSRX(PSORX,1,0)),'$G(PSODEATH) S DA=PSORX,SUSD=$P($G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),0)),"^",2) D:'$G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),"P")) REF^PSOCAN2
...S DA=$O(^PS(52.5,"B",PSORX,0)),DIK="^PS(52.5," D ^DIK K DIK
..D SETC
..;activity record
..S (COM,ACOM)=$S($G(PSODEATH):"Date of Death Entered by MAS",1:"Discontinued by Pharmacy")_"."
..S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(PSORX,"A",SUB)) Q:'SUB S ACNT=SUB
..S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(PSORX,1,RF)) Q:'RF S RFCNT=RF
..D NOW^%DTC S ACNT=ACNT+1,^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
..S ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued Due to Death. "_ACOM
..;check for label/release/pending release
..D FIL
..S STAT="OD",PHARMST="" D EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A") K COMM,PHARMST,STAT
;dc pending orders
F PDA=0:0 S PDA=$O(^PS(52.41,"P",PSODFN,PDA)) Q:'PDA I $P(^PS(52.41,PDA,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") D
.I $G(PSODEATH) D
..S ^PS(52.41,PDA,"DDSTA")=$P(^PS(52.41,PDA,0),"^",3)_";"_+$P($G(^PS(52.41,PDA,"INI")),"^"),^PS(52.41,"APSOD",PSODFN,PDA)=""
..S $P(^PS(52.41,PDA,4),"^")="Date of Death Entered by MAS."
.S $P(^PS(52.41,PDA,0),"^",3)="DC"
.K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,PDA,"INI")),"^"),PDA)
.S COM=$S($G(PSODEATH):"Date of Death Entered by MAS.",1:""),PL=$P(^PS(52.41,PDA,0),"^"),$P(^(0),"^",3)="DC"
.D EN^PSOHLSN(PL,"OC",COM,"A") K COM,PL
;dc non-va meds
D APSOD^PSONVNEW
KILL K %,%H,%T,ACNT,DA,PDA,DIRUT,DTOUT,PSO,PSO0,PSO2,PSOD,PSOD0,PSODFN,PSODL,PSORX,PSORXJ,PSOSD,RF,RFCNT,SUB,TM,TSKDT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
D KVAR^VADPT S:$D(ZTQUEUED) ZTREQ="@"
Q
CAN1 Q:$G(DODR)
S PSOMGDFN=$G(PSODFN) ; SAVE IN CASE CANCELING RX THAT WAS MERGED TO ANOTHER DFN
I $G(^PSRX(DA,"H"))]"" D HLD^PSOCAN2
D REVERSE^PSOBPSU1(DA,,"DC",7)
S PSCANVAR=0,RXDA=DA,DA=$O(^PS(52.5,"B",DA,0)) I DA,'$G(^PS(52.5,DA,"P")) S PSCANVAR=1 D
.S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
.S:+$G(^PS(52.5,DA,"P"))'=1 ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" while suspended. "_$G(COM)
.S DIK="^PS(52.5," D ^DIK K DIK S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2)
.D AREC^PSOCAN1 S DA=RXDA I $O(^PSRX(DA,1,0)) D REF^PSOCAN2
I $G(REA)="C" S DA=$O(^PS(52.5,"B",RXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK
I 'PSCANVAR S:$D(SPCANC) ACOM=$S(REA="C":"Discontinued",1:"Reinstated")_" during Rx cancel. "
ADD S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) S:$G(PSOOPT)=3 REA="L"
D:'$G(PSCANVAR) AREC^PSOCAN1 S:REA="L" REA="C" S:REA'="C" $P(^PSRX(DA,"STA"),"^")=0
N PSOTPCNZ S PSOTPCNZ=0 I $P(^PSRX(DA,"STA"),"^")'=12 S PSOTPCNZ=1
S:REA="C"&($P(^PSRX(DA,"STA"),"^")<12)!($P(^("STA"),"^")=16) $P(^PSRX(DA,"STA"),"^")=12 I $P($G(^PSRX(DA,"STA")),"^")=12,$G(PSOTPCNZ) D CAN^PSOTPCAN(DA)
K PSOTPCNZ
I REA="R" D
.I $P(^PSRX(DA,3),"^",8) S $P(^PSRX(DA,3),"^",2)=$P(^PSRX(DA,3),"^",8),$P(^(3),"^",8)=""
.S $P(^PSRX(DA,3),"^")=$S($P(^PSRX(DA,3),"^",10):$P(^(3),"^",10),$G(PSOCANHD):PSOCANHD,$P(^(3),"^",5):$P(^(3),"^",5),1:$P(^(3),"^")),$P(^(3),"^",5)="",$P(^(3),"^",10)=""
I REA="C" D
.S $P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^")
.S:'$P(^PSRX(DA,3),"^",5) $P(^PSRX(DA,3),"^",5)=DT
.I $O(^PS(52.41,"ARF",DA,0)),'$O(^PS(52.41,"APSOD",PSODFN,0)) S HLDDA=DA,DA=$O(^PS(52.41,"ARF",DA,0)),DIK="^PS(52.41," D ^DIK S DA=HLDDA K HLDDA
.;check for label/release/pending release
.I $G(PSOOPT)'=3 D FILX
S PSONOOR=$S($D(PSONOOR):PSONOOR,1:"D"),STAT=$S(REA="C":"OD",1:"SC"),PHARMST=$S(REA="C":"",1:"CM")
S COM=$S(REA="C":$S($G(PSOOPT)=3&('$G(DUP)):"Renewed",1:"Discontinued")_" by Pharmacy",1:"Reinstated by Pharmacy")
D EN^PSOHLSN1(DA,STAT,PHARMST,$S(COM["Discontinued"&($D(INCOM)):INCOM,1:COM),$S($G(PSOOPT)=3&('$G(DUP)):"",1:PSONOOR)) K COM,STAT,PHARMST,PSCANVAR
I REA="C" D
.I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA
I $G(PSOMGDFN)'="" S PSODFN=PSOMGDFN K PSOMGDFN
Q:(REA="C")!('$P($G(PSOPAR),"^",2))!($P(^PSRX(DA,2),"^",10)]"")
Q:$D(^XUSEC("PSORPH",DUZ)) S PSVC=$P(^PSRX(DA,0),"^",16) F JJ=0:0 S JJ=$O(^PS(55,PSODFN,"P",JJ)) Q:'JJ I $D(^(JJ,0)),+^(0)=DA Q
Q:'JJ S PSRXIN=DA,DIC="^PS(52.4,",DLAYGO=52.4,(X,DINUM)=PSRXIN,DIC(0)="ML"
S DIC("DR")="1////"_$G(PSODFN)_";2////"_DUZ_";4////"_DT
K DD,DO D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM
K DA,DIK S DA=PSRXIN K PSRXIN S $P(^PSRX(DA,"STA"),"^")=1 D NVER^PSOCAN2
W !,"Rx # "_$P(^PSRX(DA,0),"^")_" is still non-verified!"
Q
OERR I '$D(^XUSEC("PSORPH",DUZ)),'$P($G(PSOPAR),"^",2) S VALMSG="Invalid Action Selection!",VALMBCK="" Q
S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
K PSOPLCK S PSOCANRD=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",4),PSOCANRA=1
I $P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^"),$P(^("STA"),"^")=1!($P(^("STA"),"^")=4) S:$G(SPEED) PSONOORS=$G(PSONOOR) D DEL^PSOCAN4 S:$G(PSONOORS)'="" PSONOOR=$G(PSONOORS) K PSONOORS D KCAN D ULP Q
D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D KCAN D ULP Q
I '+^PSRX($P(PSOLST(ORN),"^",2),"OR1"),$P(^("STA"),"^")=12 S VALMSG="Rx Cannot be Reinstated. No Orderable Item." D KCAN D ULP D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12,$P($G(^("PKI")),"^") S VALMSG="Cannot be Reinstated - Digitally Signed" D KCAN D ULP D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q
I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12 S PSOCANRZ=1
D HLDHDR^PSOLMUTL S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),PS=$S($P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
S POERR=1,DFNHLD=PSODFN,DA=$P(PSOLST(ORN),"^",2)
I $P(^PSRX(DA,3),"^",5) S PSOCANHD=$P(^PSRX(DA,3),"^",5)
D LMNO D:$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=12 RMP
D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2))
K POERR,PSCAN,PSI,PSL S PSODFN=DFNHLD K DFNHLD D ULP
D KCAN
Q
Q
ULP D UL^PSSLOCK(+$G(PSODFN))
Q
;
LMNO ; Calls LMNO^PSOCAN
N PSODFN,PSORX,RXN,RX0
S PSPOP=0,RXNUM=X S PSODFN=+$P(^PSRX(DA,0),"^",2) D LMNO^PSOCAN
Q
;
KCAN ;
K PSOCANRA,PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ,PSOMSG,PSOCANHD
Q
;
KCAN1 ;
K PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ
Q
;
RMP D RMP^PSOCAN3N
Q
;
FIL Q:'$G(PSORX)
S PSOFC=PSORX G FILC
FILX Q:'$G(DA)
S PSOFC=DA
FILC ;
N PFC,PSOFFLAG
I $P($G(^PSRX(PSOFC,2)),"^",13) G FILQ
S PSOFFLAG=0 F PFC=0:0 S PFC=$O(^PSRX(PSOFC,1,PFC)) Q:'PFC!(PSOFFLAG) I $P($G(^PSRX(PSOFC,1,PFC,0)),"^",18) S PSOFFLAG=1
I PSOFFLAG G FILQ
F PFC=0:0 S PFC=$O(^PSRX(PSOFC,"L",PFC)) Q:'PFC!(PSOFFLAG) I $D(^PSRX(PSOFC,"L",PFC,0)),'$P($G(^(0)),"^",5) S PSOFFLAG=1
I PSOFFLAG G FILQ
S PSOFCSUS=$O(^PS(52.5,"B",PSOFC,0))
I $G(PSOFCSUS),$P($G(^PS(52.5,PSOFCSUS,0)),"^",7)="L"!($P($G(^(0)),"^",7)="X") G FILQ
S $P(^PSRX(PSOFC,3),"^",8)=$P($G(^PSRX(PSOFC,3)),"^",2)
S $P(^PSRX(PSOFC,3),"^",2)=$P($G(^PSRX(PSOFC,2)),"^",2)
I $P($G(^PSRX(PSOFC,"OR1")),"^",3) S $P(^PSRX(PSOFC,3),"^")=$P($G(^PSRX($P(^PSRX(PSOFC,"OR1"),"^",3),3)),"^")
FILQ K PSOFC,PSOFCSUS
Q
;
SETC ;Called from Date of Death
S $P(^PSRX(PSORX,"STA"),"^")=12,$P(^PSRX(PSORX,3),"^",5)=DT,$P(^PSRX(PSORX,3),"^",10)=$P(^PSRX(PSORX,3),"^") D CAN^PSOTPCAN(PSORX)
Q
PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ;9/18/06 2:59pm
+1 ;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249,225**;DEC 1997;Build 29
+2 ;External reference to File #55 supported by DBIA 2228
+3 ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
+4 QUIT
APSOD(PSODFN) ;called from file #2 date of death xref 'APOSD'
+1 NEW D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DQ,DU,DV,DW,DR
+2 SET PSODEATH=1
DO CAN
KILL PSODEATH
+3 QUIT
CAN ;discontinued rxs due to death
+1 IF $GET(PSODFN)
IF $DATA(^PS(52.91,PSODFN,0))
Begin DoDot:1
+2 IF '$PIECE($GET(^PS(52.91,PSODFN,0)),"^",3)!($PIECE($GET(^(0)),"^",3)>DT)
SET $PIECE(^PS(52.91,PSODFN,0),"^",3)=DT
SET $PIECE(^PS(52.91,PSODFN,0),"^",4)=5
SET ^PS(52.91,"AX",DT,PSODFN)=""
DO SET^PSOTPCAN(PSODFN)
End DoDot:1
+3 FOR PSORXJ=0:0
SET PSORXJ=$ORDER(^PS(55,PSODFN,"P",PSORXJ))
IF 'PSORXJ
QUIT
IF $DATA(^(PSORXJ,0))
SET PSORX=^(0)
SET STA=$SELECT($PIECE($GET(^PSRX(PSORX,"STA")),"^")<11:1,$PIECE($GET(^("STA")),"^")=16:1,1:0)
IF STA
Begin DoDot:1
+4 IF $DATA(^PSRX(PSORX,0))
IF $PIECE($GET(^PSRX(PSORX,"STA")),"^")=""
DO SETC
+5 DO REVERSE^PSOBPSU1(PSORX,,"DC",7)
+6 IF $DATA(^PSRX(PSORX,0))
IF $PIECE($GET(^PSRX(PSORX,2)),"^",6)'<DT
SET PSO0=^(0)
SET PSO2=$GET(^(2))
Begin DoDot:2
+7 SET ^PSRX(PSORX,"DDSTA")="52;"_$PIECE(^PSRX(PSORX,"STA"),"^")
+8 ;remove from hold
+9 IF $GET(^PSRX(PSORX,"H"))]""
Begin DoDot:3
+10 SET ^PSRX(PSORX,"DDSTA")="52;"_$PIECE(^PSRX(PSORX,"STA"),"^")_"^"_^PSRX(PSORX,"H")
+11 IF $PIECE(^PSRX(PSORX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSORX,"H"),"^"),PSORX)
SET ^PSRX(PSORX,"H")=""
+12 IF '$PIECE($GET(^PSRX(PSORX,2)),"^",2)
IF $PIECE($GET(^(3)),"^")
SET $PIECE(^PSRX(PSORX,2),"^",2)=$PIECE(^(3),"^")
+13 IF $GET(PSODEATH)
IF $PIECE(^PSRX(PSORX,0),"^",2)
SET ^PSRX("APSOD",$PIECE(^PSRX(PSORX,0),"^",2),PSORX)=""
End DoDot:3
+14 ;delete from non-verified file
+15 IF $GET(^PS(52.4,PSORX,0))]""
SET ^PSRX(PSORX,"DDSTA")="52.4;"_$PIECE(^PSRX(PSORX,"STA"),"^")_"^"_^PS(52.4,PSORX,0)
SET DIK="^PS(52.4,"
SET DA=PSORX
DO ^DIK
KILL DIK
+16 IF $GET(PSODEATH)
IF $PIECE(^PSRX(PSORX,0),"^",2)
SET ^PSRX("APSOD",$PIECE(^PSRX(PSORX,0),"^",2),PSORX)=""
+17 ;delete from suspense
+18 IF $ORDER(^PS(52.5,"B",PSORX,0))
Begin DoDot:3
+19 SET DA=$ORDER(^PS(52.5,"B",PSORX,0))
IF '$GET(^PS(52.5,DA,"P"))
IF $GET(PSODEATH)
SET ^PSRX(PSORX,"DDSTA")="52.5;5^"_^PS(52.5,DA,0)
SET ^PSRX("APSOD",$PIECE(^PSRX(PSORX,0),"^",2),PSORX)=""
+20 IF $ORDER(^PSRX(PSORX,1,0))
IF '$GET(PSODEATH)
SET DA=PSORX
SET SUSD=$PIECE($GET(^PS(52.5,$ORDER(^PS(52.5,"B",PSORX,0)),0)),"^",2)
IF '$GET(^PS(52.5,$ORDER(^PS(52.5,"B",PSORX,0)),"P"))
DO REF^PSOCAN2
+21 SET DA=$ORDER(^PS(52.5,"B",PSORX,0))
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
End DoDot:3
+22 DO SETC
+23 ;activity record
+24 SET (COM,ACOM)=$SELECT($GET(PSODEATH):"Date of Death Entered by MAS",1:"Discontinued by Pharmacy")_"."
+25 SET ACNT=0
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(PSORX,"A",SUB))
IF 'SUB
QUIT
SET ACNT=SUB
+26 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(PSORX,1,RF))
IF 'RF
QUIT
SET RFCNT=RF
+27 DO NOW^%DTC
SET ACNT=ACNT+1
SET ^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
+28 SET ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued Due to Death. "_ACOM
+29 ;check for label/release/pending release
+30 DO FIL
+31 SET STAT="OD"
SET PHARMST=""
DO EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A")
KILL COMM,PHARMST,STAT
End DoDot:2
End DoDot:1
+32 ;dc pending orders
+33 FOR PDA=0:0
SET PDA=$ORDER(^PS(52.41,"P",PSODFN,PDA))
IF 'PDA
QUIT
IF $PIECE(^PS(52.41,PDA,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
Begin DoDot:1
+34 IF $GET(PSODEATH)
Begin DoDot:2
+35 SET ^PS(52.41,PDA,"DDSTA")=$PIECE(^PS(52.41,PDA,0),"^",3)_";"_+$PIECE($GET(^PS(52.41,PDA,"INI")),"^")
SET ^PS(52.41,"APSOD",PSODFN,PDA)=""
+36 SET $PIECE(^PS(52.41,PDA,4),"^")="Date of Death Entered by MAS."
End DoDot:2
+37 SET $PIECE(^PS(52.41,PDA,0),"^",3)="DC"
+38 KILL ^PS(52.41,"AOR",PSODFN,+$PIECE($GET(^PS(52.41,PDA,"INI")),"^"),PDA)
+39 SET COM=$SELECT($GET(PSODEATH):"Date of Death Entered by MAS.",1:"")
SET PL=$PIECE(^PS(52.41,PDA,0),"^")
SET $PIECE(^(0),"^",3)="DC"
+40 DO EN^PSOHLSN(PL,"OC",COM,"A")
KILL COM,PL
End DoDot:1
+41 ;dc non-va meds
+42 DO APSOD^PSONVNEW
KILL KILL %,%H,%T,ACNT,DA,PDA,DIRUT,DTOUT,PSO,PSO0,PSO2,PSOD,PSOD0,PSODFN,PSODL,PSORX,PSORXJ,PSOSD,RF,RFCNT,SUB,TM,TSKDT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+1 DO KVAR^VADPT
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
CAN1 IF $GET(DODR)
QUIT
+1 ; SAVE IN CASE CANCELING RX THAT WAS MERGED TO ANOTHER DFN
SET PSOMGDFN=$GET(PSODFN)
+2 IF $GET(^PSRX(DA,"H"))]""
DO HLD^PSOCAN2
+3 DO REVERSE^PSOBPSU1(DA,,"DC",7)
+4 SET PSCANVAR=0
SET RXDA=DA
SET DA=$ORDER(^PS(52.5,"B",DA,0))
IF DA
IF '$GET(^PS(52.5,DA,"P"))
SET PSCANVAR=1
Begin DoDot:1
+5 SET SUSD=$PIECE($GET(^PS(52.5,DA,0)),"^",2)
+6 IF +$GET(^PS(52.5,DA,"P"))'=1
SET ACOM=$SELECT(REA="C":"Discontinued",1:"Reinstated")_" while suspended. "_$GET(COM)
+7 SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
SET DA=RXDA
SET RXREF=0
SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
+8 DO AREC^PSOCAN1
SET DA=RXDA
IF $ORDER(^PSRX(DA,1,0))
DO REF^PSOCAN2
End DoDot:1
+9 IF $GET(REA)="C"
SET DA=$ORDER(^PS(52.5,"B",RXDA,0))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+10 IF 'PSCANVAR
IF $DATA(SPCANC)
SET ACOM=$SELECT(REA="C":"Discontinued",1:"Reinstated")_" during Rx cancel. "
ADD SET DA=RXDA
SET RXREF=0
SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
IF $GET(PSOOPT)=3
SET REA="L"
+1 IF '$GET(PSCANVAR)
DO AREC^PSOCAN1
IF REA="L"
SET REA="C"
IF REA'="C"
SET $PIECE(^PSRX(DA,"STA"),"^")=0
+2 NEW PSOTPCNZ
SET PSOTPCNZ=0
IF $PIECE(^PSRX(DA,"STA"),"^")'=12
SET PSOTPCNZ=1
+3 IF REA="C"&($PIECE(^PSRX(DA,"STA"),"^")<12)!($PIECE(^("STA"),"^")=16)
SET $PIECE(^PSRX(DA,"STA"),"^")=12
IF $PIECE($GET(^PSRX(DA,"STA")),"^")=12
IF $GET(PSOTPCNZ)
DO CAN^PSOTPCAN(DA)
+4 KILL PSOTPCNZ
+5 IF REA="R"
Begin DoDot:1
+6 IF $PIECE(^PSRX(DA,3),"^",8)
SET $PIECE(^PSRX(DA,3),"^",2)=$PIECE(^PSRX(DA,3),"^",8)
SET $PIECE(^(3),"^",8)=""
+7 SET $PIECE(^PSRX(DA,3),"^")=$SELECT($PIECE(^PSRX(DA,3),"^",10):$PIECE(^(3),"^",10),$GET(PSOCANHD):PSOCANHD,$PIECE(^(3),"^",5):$PIECE(^(3),"^",5),1:$PIECE(^(3),"^"))
SET $PIECE(^(3),"^",5)=""
SET $PIECE(^(3),"^",10)=""
End DoDot:1
+8 IF REA="C"
Begin DoDot:1
+9 SET $PIECE(^PSRX(DA,3),"^",10)=$PIECE(^PSRX(DA,3),"^")
+10 IF '$PIECE(^PSRX(DA,3),"^",5)
SET $PIECE(^PSRX(DA,3),"^",5)=DT
+11 IF $ORDER(^PS(52.41,"ARF",DA,0))
IF '$ORDER(^PS(52.41,"APSOD",PSODFN,0))
SET HLDDA=DA
SET DA=$ORDER(^PS(52.41,"ARF",DA,0))
SET DIK="^PS(52.41,"
DO ^DIK
SET DA=HLDDA
KILL HLDDA
+12 ;check for label/release/pending release
+13 IF $GET(PSOOPT)'=3
DO FILX
End DoDot:1
+14 SET PSONOOR=$SELECT($DATA(PSONOOR):PSONOOR,1:"D")
SET STAT=$SELECT(REA="C":"OD",1:"SC")
SET PHARMST=$SELECT(REA="C":"",1:"CM")
+15 SET COM=$SELECT(REA="C":$SELECT($GET(PSOOPT)=3&('$GET(DUP)):"Renewed",1:"Discontinued")_" by Pharmacy",1:"Reinstated by Pharmacy")
+16 DO EN^PSOHLSN1(DA,STAT,PHARMST,$SELECT(COM["Discontinued"&($DATA(INCOM)):INCOM,1:COM),$SELECT($GET(PSOOPT)=3&('$GET(DUP)):"",1:PSONOOR))
KILL COM,STAT,PHARMST,PSCANVAR
+17 IF REA="C"
Begin DoDot:1
+18 IF $GET(^PS(52.4,DA,0))]""
SET PSCDA=DA
SET DIK="^PS(52.4,"
DO ^DIK
SET DA=PSCDA
KILL DIK,PSCDA
End DoDot:1
+19 IF $GET(PSOMGDFN)'=""
SET PSODFN=PSOMGDFN
KILL PSOMGDFN
+20 IF (REA="C")!('$PIECE($GET(PSOPAR),"^",2))!($PIECE(^PSRX(DA,2),"^",10)]"")
QUIT
+21 IF $DATA(^XUSEC("PSORPH",DUZ))
QUIT
SET PSVC=$PIECE(^PSRX(DA,0),"^",16)
FOR JJ=0:0
SET JJ=$ORDER(^PS(55,PSODFN,"P",JJ))
IF 'JJ
QUIT
IF $DATA(^(JJ,0))
IF +^(0)=DA
QUIT
+22 IF 'JJ
QUIT
SET PSRXIN=DA
SET DIC="^PS(52.4,"
SET DLAYGO=52.4
SET (X,DINUM)=PSRXIN
SET DIC(0)="ML"
+23 SET DIC("DR")="1////"_$GET(PSODFN)_";2////"_DUZ_";4////"_DT
+24 KILL DD,DO
DO FILE^DICN
KILL DD,DO,DIC,DLAYGO,DINUM
+25 KILL DA,DIK
SET DA=PSRXIN
KILL PSRXIN
SET $PIECE(^PSRX(DA,"STA"),"^")=1
DO NVER^PSOCAN2
+26 WRITE !,"Rx # "_$PIECE(^PSRX(DA,0),"^")_" is still non-verified!"
+27 QUIT
OERR IF '$DATA(^XUSEC("PSORPH",DUZ))
IF '$PIECE($GET(PSOPAR),"^",2)
SET VALMSG="Invalid Action Selection!"
SET VALMBCK=""
QUIT
+1 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
IF '$GET(PSOPLCK)
DO LOCK^PSOORCPY
SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
KILL PSOPLCK
SET VALMBCK=""
QUIT
+2 KILL PSOPLCK
SET PSOCANRD=+$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^",4)
SET PSOCANRA=1
+3 IF $PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA"),"^")
IF $PIECE(^("STA"),"^")=1!($PIECE(^("STA"),"^")=4)
IF $GET(SPEED)
SET PSONOORS=$GET(PSONOOR)
DO DEL^PSOCAN4
IF $GET(PSONOORS)'=""
SET PSONOOR=$GET(PSONOORS)
KILL PSONOORS
DO KCAN
DO ULP
QUIT
+4 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
SET VALMSG=$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order.")
SET VALMBCK=""
KILL PSOMSG
DO KCAN
DO ULP
QUIT
+5 IF '+^PSRX($PIECE(PSOLST(ORN),"^",2),"OR1")
IF $PIECE(^("STA"),"^")=12
SET VALMSG="Rx Cannot be Reinstated. No Orderable Item."
DO KCAN
DO ULP
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
QUIT
+6 IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=12
IF $PIECE($GET(^("PKI")),"^")
SET VALMSG="Cannot be Reinstated - Digitally Signed"
DO KCAN
DO ULP
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
QUIT
+7 IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=12
SET PSOCANRZ=1
+8 DO HLDHDR^PSOLMUTL
SET X=$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")
SET PS=$SELECT($PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
+9 SET POERR=1
SET DFNHLD=PSODFN
SET DA=$PIECE(PSOLST(ORN),"^",2)
+10 IF $PIECE(^PSRX(DA,3),"^",5)
SET PSOCANHD=$PIECE(^PSRX(DA,3),"^",5)
+11 DO LMNO
IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")=12
DO RMP
+12 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+13 KILL POERR,PSCAN,PSI,PSL
SET PSODFN=DFNHLD
KILL DFNHLD
DO ULP
+14 DO KCAN
+15 QUIT
+16 QUIT
ULP DO UL^PSSLOCK(+$GET(PSODFN))
+1 QUIT
+2 ;
LMNO ; Calls LMNO^PSOCAN
+1 NEW PSODFN,PSORX,RXN,RX0
+2 SET PSPOP=0
SET RXNUM=X
SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
DO LMNO^PSOCAN
+3 QUIT
+4 ;
KCAN ;
+1 KILL PSOCANRA,PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ,PSOMSG,PSOCANHD
+2 QUIT
+3 ;
KCAN1 ;
+1 KILL PSOCANRC,PSOCANRD,PSOCANRN,PSOCANRP,PSOCANRZ
+2 QUIT
+3 ;
RMP DO RMP^PSOCAN3N
+1 QUIT
+2 ;
FIL IF '$GET(PSORX)
QUIT
+1 SET PSOFC=PSORX
GOTO FILC
FILX IF '$GET(DA)
QUIT
+1 SET PSOFC=DA
FILC ;
+1 NEW PFC,PSOFFLAG
+2 IF $PIECE($GET(^PSRX(PSOFC,2)),"^",13)
GOTO FILQ
+3 SET PSOFFLAG=0
FOR PFC=0:0
SET PFC=$ORDER(^PSRX(PSOFC,1,PFC))
IF 'PFC!(PSOFFLAG)
QUIT
IF $PIECE($GET(^PSRX(PSOFC,1,PFC,0)),"^",18)
SET PSOFFLAG=1
+4 IF PSOFFLAG
GOTO FILQ
+5 FOR PFC=0:0
SET PFC=$ORDER(^PSRX(PSOFC,"L",PFC))
IF 'PFC!(PSOFFLAG)
QUIT
IF $DATA(^PSRX(PSOFC,"L",PFC,0))
IF '$PIECE($GET(^(0)),"^",5)
SET PSOFFLAG=1
+6 IF PSOFFLAG
GOTO FILQ
+7 SET PSOFCSUS=$ORDER(^PS(52.5,"B",PSOFC,0))
+8 IF $GET(PSOFCSUS)
IF $PIECE($GET(^PS(52.5,PSOFCSUS,0)),"^",7)="L"!($PIECE($GET(^(0)),"^",7)="X")
GOTO FILQ
+9 SET $PIECE(^PSRX(PSOFC,3),"^",8)=$PIECE($GET(^PSRX(PSOFC,3)),"^",2)
+10 SET $PIECE(^PSRX(PSOFC,3),"^",2)=$PIECE($GET(^PSRX(PSOFC,2)),"^",2)
+11 IF $PIECE($GET(^PSRX(PSOFC,"OR1")),"^",3)
SET $PIECE(^PSRX(PSOFC,3),"^")=$PIECE($GET(^PSRX($PIECE(^PSRX(PSOFC,"OR1"),"^",3),3)),"^")
FILQ KILL PSOFC,PSOFCSUS
+1 QUIT
+2 ;
SETC ;Called from Date of Death
+1 SET $PIECE(^PSRX(PSORX,"STA"),"^")=12
SET $PIECE(^PSRX(PSORX,3),"^",5)=DT
SET $PIECE(^PSRX(PSORX,3),"^",10)=$PIECE(^PSRX(PSORX,3),"^")
DO CAN^PSOTPCAN(PSORX)
+2 QUIT
