- PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ;Dec 13, 2021@07:58:41
- ;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249,225,324,251,375,379,372,540,508,457,617,441**;DEC 1997;Build 208
- ;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
- ..I $G(^PSRX(PSORX,"PARK")) K ^PSRX(PSORX,"PARK"),^PSRX("APARK",1,PSORX) ;441 PAPI
- ..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
- ;delete PARK info
- I $G(^PSRX(DA,"PARK")) K ^PSRX(DA,"PARK"),^PSRX("APARK",1,DA) ;441 PAPI
- 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,$P(^(7),"^")=""
- 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
- .K ^XTMP("PSO4D-"_PSODFN) ; p457 clear clozapine 4-day supply
- .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
- S PSVC=$P(^PSRX(DA,0),"^",16)
- Q:(REA="C")!($P(^PSRX(DA,2),"^",10)]"")
- Q:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2))
- 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
- ; PSO*7*508 - added ERXDCIEN parameter, and check for parameter and possession of psorph.
- ; - the pso application proxy will not possess the PSORPH key, so we do not quit if that is the case.
- OERR(ERXDCIEN) ;
- N PSORXIEN
- S PSORXIEN=$P(PSOLST(ORN),"^",2)
- I '$D(^XUSEC("PSORPH",DUZ)),'$P($G(PSOPAR),"^",2),'$G(ERXDCIEN) 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(PSORXIEN,0)),"^",4),PSOCANRA=1
- D PSOL^PSSLOCK(PSORXIEN) 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 $P(^PSRX(PSORXIEN,"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
- I '+^PSRX(PSORXIEN,"OR1"),$P(^("STA"),"^")=12 S VALMSG="Rx Cannot be Reinstated. No Orderable Item." D KCAN D ULP D PSOUL^PSSLOCK(PSORXIEN) Q
- I $P($G(^PSRX(PSORXIEN,"STA")),"^")=12,$P($G(^PSRX(PSORXIEN,"PKI")),"^")!$P($G(^PSRX(PSORXIEN,"PKI")),"^",3) S VALMSG="Cannot be Reinstated - Digitally Signed" D KCAN D ULP D PSOUL^PSSLOCK(PSORXIEN) Q
- I $P($G(^PSRX(PSORXIEN,"STA")),"^")=12 S PSOCANRZ=1
- ; PSO*7*508 - replacing below line with following 2 lines - do not try to build header if this is an auto-dc for an eRx.
- ;D HLDHDR^PSOLMUTL S X=$P(^PSRX(PSORXIEN,0),"^"),PS=$S($P(^PSRX(PSORXIEN,"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
- I '$G(ERXDCIEN) D HLDHDR^PSOLMUTL
- S X=$P(^PSRX(PSORXIEN,0),"^"),PS=$S($P(^PSRX(PSORXIEN,"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
- ; PSO*7*508 - end changes
- S POERR=1,DFNHLD=PSODFN,DA=PSORXIEN N PSOREINS,PSOONOFC S PSOREINS=1
- I $G(PSORX("DOSING OFF")) S PSOREINF=1
- I $P(^PSRX(DA,3),"^",5) S PSOCANHD=$P(^PSRX(DA,3),"^",5)
- D LMNO S:$G(PSOONOFC) PSORX("DOSING OFF")=1 I $G(PSOQUIT) D ULP,KCAN S VALMBCK="R" Q
- D:$P($G(^PSRX(PSORXIEN,"STA")),"^")=12 RMP
- D PSOUL^PSSLOCK(PSORXIEN)
- K POERR,PSCAN,PSI,PSL,PSOREINF S PSODFN=DFNHLD K DFNHLD D ULP
- D KCAN
- 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,PSOQUIT
- 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)
- D CHKCMOP^PSOUTL(PSORX,"D")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN3 10436 printed Jan 18, 2025@03:26:22 Page 2
- PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ;Dec 13, 2021@07:58:41
- +1 ;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249,225,324,251,375,379,372,540,508,457,617,441**;DEC 1997;Build 208
- +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 ;441 PAPI
- IF $GET(^PSRX(PSORX,"PARK"))
- KILL ^PSRX(PSORX,"PARK"),^PSRX("APARK",1,PSORX)
- +23 DO SETC
- +24 ;activity record
- +25 SET (COM,ACOM)=$SELECT($GET(PSODEATH):"Date of Death Entered by MAS",1:"Discontinued by Pharmacy")_"."
- +26 SET ACNT=0
- FOR SUB=0:0
- SET SUB=$ORDER(^PSRX(PSORX,"A",SUB))
- if 'SUB
- QUIT
- SET ACNT=SUB
- +27 SET RFCNT=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(PSORX,1,RF))
- if 'RF
- QUIT
- SET RFCNT=RF
- +28 DO NOW^%DTC
- SET ACNT=ACNT+1
- SET ^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
- +29 SET ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued Due to Death. "_ACOM
- +30 ;check for label/release/pending release
- +31 DO FIL
- +32 SET STAT="OD"
- SET PHARMST=""
- DO EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A")
- KILL COMM,PHARMST,STAT
- End DoDot:2
- End DoDot:1
- +33 ;dc pending orders
- +34 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
- +35 IF $GET(PSODEATH)
- Begin DoDot:2
- +36 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)=""
- +37 SET $PIECE(^PS(52.41,PDA,4),"^")="Date of Death Entered by MAS."
- End DoDot:2
- +38 SET $PIECE(^PS(52.41,PDA,0),"^",3)="DC"
- +39 KILL ^PS(52.41,"AOR",PSODFN,+$PIECE($GET(^PS(52.41,PDA,"INI")),"^"),PDA)
- +40 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"
- +41 DO EN^PSOHLSN(PL,"OC",COM,"A")
- KILL COM,PL
- End DoDot:1
- +42 ;dc non-va meds
- +43 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 ;delete PARK info
- +4 ;441 PAPI
- IF $GET(^PSRX(DA,"PARK"))
- KILL ^PSRX(DA,"PARK"),^PSRX("APARK",1,DA)
- +5 DO REVERSE^PSOBPSU1(DA,,"DC",7)
- +6 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
- +7 SET SUSD=$PIECE($GET(^PS(52.5,DA,0)),"^",2)
- +8 if +$GET(^PS(52.5,DA,"P"))'=1
- SET ACOM=$SELECT(REA="C":"Discontinued",1:"Reinstated")_" while suspended. "_$GET(COM)
- +9 SET DIK="^PS(52.5,"
- DO ^DIK
- KILL DIK
- SET DA=RXDA
- SET RXREF=0
- SET PSODFN=+$PIECE(^PSRX(DA,0),"^",2)
- +10 DO AREC^PSOCAN1
- SET DA=RXDA
- IF $ORDER(^PSRX(DA,1,0))
- DO REF^PSOCAN2
- End DoDot:1
- +11 IF $GET(REA)="C"
- SET DA=$ORDER(^PS(52.5,"B",RXDA,0))
- IF DA
- SET DIK="^PS(52.5,"
- DO ^DIK
- KILL DIK
- +12 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"
- +2 if REA'="C"
- SET $PIECE(^PSRX(DA,"STA"),"^")=0
- SET $PIECE(^(7),"^")=""
- +3 NEW PSOTPCNZ
- SET PSOTPCNZ=0
- IF $PIECE(^PSRX(DA,"STA"),"^")'=12
- SET PSOTPCNZ=1
- +4 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)
- +5 KILL PSOTPCNZ
- +6 IF REA="R"
- Begin DoDot:1
- +7 IF $PIECE(^PSRX(DA,3),"^",8)
- SET $PIECE(^PSRX(DA,3),"^",2)=$PIECE(^PSRX(DA,3),"^",8)
- SET $PIECE(^(3),"^",8)=""
- +8 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
- +9 IF REA="C"
- Begin DoDot:1
- +10 SET $PIECE(^PSRX(DA,3),"^",10)=$PIECE(^PSRX(DA,3),"^")
- +11 if '$PIECE(^PSRX(DA,3),"^",5)
- SET $PIECE(^PSRX(DA,3),"^",5)=DT
- +12 ; p457 clear clozapine 4-day supply
- KILL ^XTMP("PSO4D-"_PSODFN)
- +13 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
- +14 ;check for label/release/pending release
- +15 IF $GET(PSOOPT)'=3
- DO FILX
- End DoDot:1
- +16 SET PSONOOR=$SELECT($DATA(PSONOOR):PSONOOR,1:"D")
- SET STAT=$SELECT(REA="C":"OD",1:"SC")
- SET PHARMST=$SELECT(REA="C":"",1:"CM")
- +17 SET COM=$SELECT(REA="C":$SELECT($GET(PSOOPT)=3&('$GET(DUP)):"Renewed",1:"Discontinued")_" by Pharmacy",1:"Reinstated by Pharmacy")
- +18 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
- +19 IF REA="C"
- Begin DoDot:1
- +20 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
- +21 IF $GET(PSOMGDFN)'=""
- SET PSODFN=PSOMGDFN
- KILL PSOMGDFN
- +22 SET PSVC=$PIECE(^PSRX(DA,0),"^",16)
- +23 if (REA="C")!($PIECE(^PSRX(DA,2),"^",10)]"")
- QUIT
- +24 if $DATA(^XUSEC("PSORPH",DUZ))!('$PIECE(PSOPAR,"^",2))
- QUIT
- +25 SET PSRXIN=DA
- SET DIC="^PS(52.4,"
- SET DLAYGO=52.4
- SET (X,DINUM)=PSRXIN
- SET DIC(0)="ML"
- +26 SET DIC("DR")="1////"_$GET(PSODFN)_";2////"_DUZ_";4////"_DT
- +27 KILL DD,DO
- DO FILE^DICN
- KILL DD,DO,DIC,DLAYGO,DINUM
- +28 KILL DA,DIK
- SET DA=PSRXIN
- KILL PSRXIN
- SET $PIECE(^PSRX(DA,"STA"),"^")=1
- DO NVER^PSOCAN2
- +29 WRITE !,"Rx # "_$PIECE(^PSRX(DA,0),"^")_" is still non-verified!"
- +30 QUIT
- +31 ; PSO*7*508 - added ERXDCIEN parameter, and check for parameter and possession of psorph.
- +32 ; - the pso application proxy will not possess the PSORPH key, so we do not quit if that is the case.
- OERR(ERXDCIEN) ;
- +1 NEW PSORXIEN
- +2 SET PSORXIEN=$PIECE(PSOLST(ORN),"^",2)
- +3 IF '$DATA(^XUSEC("PSORPH",DUZ))
- IF '$PIECE($GET(PSOPAR),"^",2)
- IF '$GET(ERXDCIEN)
- SET VALMSG="Invalid Action Selection!"
- SET VALMBCK=""
- QUIT
- +4 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
- +5 KILL PSOPLCK
- SET PSOCANRD=+$PIECE($GET(^PSRX(PSORXIEN,0)),"^",4)
- SET PSOCANRA=1
- +6 DO PSOL^PSSLOCK(PSORXIEN)
- 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
- +7 IF $PIECE(^PSRX(PSORXIEN,"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
- +8 IF '+^PSRX(PSORXIEN,"OR1")
- IF $PIECE(^("STA"),"^")=12
- SET VALMSG="Rx Cannot be Reinstated. No Orderable Item."
- DO KCAN
- DO ULP
- DO PSOUL^PSSLOCK(PSORXIEN)
- QUIT
- +9 IF $PIECE($GET(^PSRX(PSORXIEN,"STA")),"^")=12
- IF $PIECE($GET(^PSRX(PSORXIEN,"PKI")),"^")!$PIECE($GET(^PSRX(PSORXIEN,"PKI")),"^",3)
- SET VALMSG="Cannot be Reinstated - Digitally Signed"
- DO KCAN
- DO ULP
- DO PSOUL^PSSLOCK(PSORXIEN)
- QUIT
- +10 IF $PIECE($GET(^PSRX(PSORXIEN,"STA")),"^")=12
- SET PSOCANRZ=1
- +11 ; PSO*7*508 - replacing below line with following 2 lines - do not try to build header if this is an auto-dc for an eRx.
- +12 ;D HLDHDR^PSOLMUTL S X=$P(^PSRX(PSORXIEN,0),"^"),PS=$S($P(^PSRX(PSORXIEN,"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
- +13 IF '$GET(ERXDCIEN)
- DO HLDHDR^PSOLMUTL
- +14 SET X=$PIECE(^PSRX(PSORXIEN,0),"^")
- SET PS=$SELECT($PIECE(^PSRX(PSORXIEN,"STA"),"^")=12:"Reinstate: ",1:"Discontinue: ")
- +15 ; PSO*7*508 - end changes
- +16 SET POERR=1
- SET DFNHLD=PSODFN
- SET DA=PSORXIEN
- NEW PSOREINS,PSOONOFC
- SET PSOREINS=1
- +17 IF $GET(PSORX("DOSING OFF"))
- SET PSOREINF=1
- +18 IF $PIECE(^PSRX(DA,3),"^",5)
- SET PSOCANHD=$PIECE(^PSRX(DA,3),"^",5)
- +19 DO LMNO
- if $GET(PSOONOFC)
- SET PSORX("DOSING OFF")=1
- IF $GET(PSOQUIT)
- DO ULP
- DO KCAN
- SET VALMBCK="R"
- QUIT
- +20 if $PIECE($GET(^PSRX(PSORXIEN,"STA")),"^")=12
- DO RMP
- +21 DO PSOUL^PSSLOCK(PSORXIEN)
- +22 KILL POERR,PSCAN,PSI,PSL,PSOREINF
- SET PSODFN=DFNHLD
- KILL DFNHLD
- DO ULP
- +23 DO KCAN
- +24 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,PSOQUIT
- +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 DO CHKCMOP^PSOUTL(PSORX,"D")
- +3 QUIT