EHMPSRXDC ; PWC/ALB - Auto DX RX's due to Death ; Feb 10, 2026@14:57:12
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**8**;Apr 19, 2021;Build 38
;
;External reference to File #55 supported by DBIA #2228
;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA #2789
;External references to ^PS files and routines supported by DBIA #7632
;
; Made class 1 software from routine R1PSCAN3
; Rob Silverman wrote R1PSCAN3
; cloned from PSOCAN3 and modified as an API for EHRM Data Migration.
;Modifications are made throughout subroutine CAN and too extensive to document in line
Q
CAN(PSORX) ;using 'discontinued rxs due to death' as API to discontinue Rx's for EHRM
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,PSODEATH,COM,ACOM,STA,SUSD
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 <RMS 6-11-19 This code will be used if HOLD Rx's can be successfully migrated>
..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 RMS 12-3-19 comments updated for EHRM
..S (COM,ACOM)="Rx Discontinued by EHRM Data Migration."
..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 DC'ed: "_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
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
;
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[HEHMPSRXDC 4171 printed Jul 11, 2026@01:48:14 Page 2
EHMPSRXDC ; PWC/ALB - Auto DX RX's due to Death ; Feb 10, 2026@14:57:12
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**8**;Apr 19, 2021;Build 38
+2 ;
+3 ;External reference to File #55 supported by DBIA #2228
+4 ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA #2789
+5 ;External references to ^PS files and routines supported by DBIA #7632
+6 ;
+7 ; Made class 1 software from routine R1PSCAN3
+8 ; Rob Silverman wrote R1PSCAN3
+9 ; cloned from PSOCAN3 and modified as an API for EHRM Data Migration.
+10 ;Modifications are made throughout subroutine CAN and too extensive to document in line
+11 QUIT
CAN(PSORX) ;using 'discontinued rxs due to death' as API to discontinue Rx's for EHRM
+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,PSODEATH,COM,ACOM,STA,SUSD
+2 SET STA=$SELECT($PIECE($GET(^PSRX(PSORX,"STA")),"^")<11:1,$PIECE($GET(^("STA")),"^")=16:1,1:0)
if STA
Begin DoDot:1
+3 IF $DATA(^PSRX(PSORX,0))
IF $PIECE($GET(^PSRX(PSORX,"STA")),"^")=""
DO SETC
+4 DO REVERSE^PSOBPSU1(PSORX,,"DC",7)
+5 IF $DATA(^PSRX(PSORX,0))
IF $PIECE($GET(^PSRX(PSORX,2)),"^",6)'<DT
SET PSO0=^(0)
SET PSO2=$GET(^(2))
Begin DoDot:2
+6 SET ^PSRX(PSORX,"DDSTA")="52;"_$PIECE(^PSRX(PSORX,"STA"),"^")
+7 ;remove from hold <RMS 6-11-19 This code will be used if HOLD Rx's can be successfully migrated>
+8 IF $GET(^PSRX(PSORX,"H"))]""
Begin DoDot:3
+9 SET ^PSRX(PSORX,"DDSTA")="52;"_$PIECE(^PSRX(PSORX,"STA"),"^")_"^"_^PSRX(PSORX,"H")
+10 if $PIECE(^PSRX(PSORX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSORX,"H"),"^"),PSORX)
SET ^PSRX(PSORX,"H")=""
+11 IF '$PIECE($GET(^PSRX(PSORX,2)),"^",2)
IF $PIECE($GET(^(3)),"^")
SET $PIECE(^PSRX(PSORX,2),"^",2)=$PIECE(^(3),"^")
+12 IF $GET(PSODEATH)
IF $PIECE(^PSRX(PSORX,0),"^",2)
SET ^PSRX("APSOD",$PIECE(^PSRX(PSORX,0),"^",2),PSORX)=""
End DoDot:3
+13 ;delete from non-verified file
+14 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
+15 IF $GET(PSODEATH)
IF $PIECE(^PSRX(PSORX,0),"^",2)
SET ^PSRX("APSOD",$PIECE(^PSRX(PSORX,0),"^",2),PSORX)=""
+16 ;delete from suspense
+17 if $ORDER(^PS(52.5,"B",PSORX,0))
Begin DoDot:3
+18 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)=""
+19 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
+20 SET DA=$ORDER(^PS(52.5,"B",PSORX,0))
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
End DoDot:3
+21 DO SETC
+22 ;activity record RMS 12-3-19 comments updated for EHRM
+23 SET (COM,ACOM)="Rx Discontinued by EHRM Data Migration."
+24 SET ACNT=0
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(PSORX,"A",SUB))
if 'SUB
QUIT
SET ACNT=SUB
+25 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(PSORX,1,RF))
if 'RF
QUIT
SET RFCNT=RF
+26 DO NOW^%DTC
SET ACNT=ACNT+1
SET ^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
+27 SET ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto DC'ed: "_ACOM
+28 ;check for label/release/pending release
+29 DO FIL
+30 SET STAT="OD"
SET PHARMST=""
DO EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A")
KILL COMM,PHARMST,STAT
End DoDot:2
End DoDot:1
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
+3 ;
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 ;D CAN^PSOTPCAN(PSORX)
SET $PIECE(^PSRX(PSORX,"STA"),"^")=12
SET $PIECE(^PSRX(PSORX,3),"^",5)=DT
SET $PIECE(^PSRX(PSORX,3),"^",10)=$PIECE(^PSRX(PSORX,3),"^")
+2 DO CHKCMOP^PSOUTL(PSORX,"D")
+3 QUIT
