PSOSUDEL ;BIR/JMB-Delete printed Rx's or Rx's for deceased patients from suspense ;3/17/93
;;7.0;OUTPATIENT PHARMACY;**36**;DEC 1997
;External reference to ^PS(59.7 supported by DBIA 694
BEG Q:'$D(^PS(59.7,1,40.1)) S PSOSYS=^PS(59.7,1,40.1),DAYS=$S($P(PSOSYS,"^",5):$P(PSOSYS,"^",5),1:1)
D NOW^%DTC S X1=X,X2=-DAYS D C^%DTC S DATE=X S DATE=DATE+.01 F ZZZ=0:0 S ZZZ=$O(^PS(52.5,"ADL",ZZZ)) Q:'ZZZ!(ZZZ>DATE) F SFN=0:0 S SFN=$O(^PS(52.5,"ADL",ZZZ,SFN)) Q:'SFN S RXREC=$P($G(^PS(52.5,SFN,0)),"^") I RXREC D CHK
EXIT K %,%H,%T,CNT,COM,DA,DATE,DAYS,DFN,DIRUT,JJ,RF,RFCNT,RX,SFN,TM,TSKDT,VADM,X,X1,X2,Y,VADM,RXREC,ZZZ,OKAY
Q
CHK I $P($G(^PSRX(RXREC,2)),"^",6),$P($G(^(2)),"^",6)<DT D EX^PSOSUTL S $P(^PSRX(RXREC,"STA"),"^")=11 G DEL
S OKAY=0 I $P($G(^PS(52.5,SFN,0)),U,7)="X"!($P($G(^PS(52.5,SFN,0)),U,7)="P")!($P($G(^PS(52.5,SFN,0)),U,7)="") S OKAY=1
I +$G(^PS(52.5,SFN,"P"))=1,OKAY=1 G DEL
S DFN=$P($G(^PS(52.5,SFN,0)),"^",3) D DEM^VADPT Q:VADM(6)=""
DEAD S REA="C",COM="Died ("_$P(VADM(6),"^",2)_")",ACOM="Discontinued while suspended. Died ("_$P(VADM(6),"^",2)_")",DA=+$G(^PS(52.5,SFN,0)),PSCAN($P(^PSRX(DA,0),"^"))=DA_"^"_REA D CAN^PSOCAN K REA,COM,ACOM,PSCAN Q
DEL S DA=SFN,DIK="^PS(52.5," D ^DIK K DIK
Q
AUTO K %DT,DIC S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO PNDEL1" D ^DIC
I +Y>0 D EDIT^XUTMOPT("PSO PNDEL1") G EX
D RESCH^XUTMOPT("PSO PNDEL1","","","7D","L"),EDIT^XUTMOPT("PSO PNDEL1")
EX K Y,C,D,D0,DI,DQ,DA,DIE,DR,DIC,Y,X,PSOTM,PSOOPTN,%DT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUDEL 1478 printed Dec 13, 2024@02:35:24 Page 2
PSOSUDEL ;BIR/JMB-Delete printed Rx's or Rx's for deceased patients from suspense ;3/17/93
+1 ;;7.0;OUTPATIENT PHARMACY;**36**;DEC 1997
+2 ;External reference to ^PS(59.7 supported by DBIA 694
BEG if '$DATA(^PS(59.7,1,40.1))
QUIT
SET PSOSYS=^PS(59.7,1,40.1)
SET DAYS=$SELECT($PIECE(PSOSYS,"^",5):$PIECE(PSOSYS,"^",5),1:1)
+1 DO NOW^%DTC
SET X1=X
SET X2=-DAYS
DO C^%DTC
SET DATE=X
SET DATE=DATE+.01
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PS(52.5,"ADL",ZZZ))
if 'ZZZ!(ZZZ>DATE)
QUIT
FOR SFN=0:0
SET SFN=$ORDER(^PS(52.5,"ADL",ZZZ,SFN))
if 'SFN
QUIT
SET RXREC=$PIECE($GET(^PS(52.5,SFN,0)),"^")
IF RXREC
DO CHK
EXIT KILL %,%H,%T,CNT,COM,DA,DATE,DAYS,DFN,DIRUT,JJ,RF,RFCNT,RX,SFN,TM,TSKDT,VADM,X,X1,X2,Y,VADM,RXREC,ZZZ,OKAY
+1 QUIT
CHK IF $PIECE($GET(^PSRX(RXREC,2)),"^",6)
IF $PIECE($GET(^(2)),"^",6)<DT
DO EX^PSOSUTL
SET $PIECE(^PSRX(RXREC,"STA"),"^")=11
GOTO DEL
+1 SET OKAY=0
IF $PIECE($GET(^PS(52.5,SFN,0)),U,7)="X"!($PIECE($GET(^PS(52.5,SFN,0)),U,7)="P")!($PIECE($GET(^PS(52.5,SFN,0)),U,7)="")
SET OKAY=1
+2 IF +$GET(^PS(52.5,SFN,"P"))=1
IF OKAY=1
GOTO DEL
+3 SET DFN=$PIECE($GET(^PS(52.5,SFN,0)),"^",3)
DO DEM^VADPT
if VADM(6)=""
QUIT
DEAD SET REA="C"
SET COM="Died ("_$PIECE(VADM(6),"^",2)_")"
SET ACOM="Discontinued while suspended. Died ("_$PIECE(VADM(6),"^",2)_")"
SET DA=+$GET(^PS(52.5,SFN,0))
SET PSCAN($PIECE(^PSRX(DA,0),"^"))=DA_"^"_REA
DO CAN^PSOCAN
KILL REA,COM,ACOM,PSCAN
QUIT
DEL SET DA=SFN
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
+1 QUIT
AUTO KILL %DT,DIC
SET DIC(0)="XZM"
SET DIC="^DIC(19.2,"
SET X="PSO PNDEL1"
DO ^DIC
+1 IF +Y>0
DO EDIT^XUTMOPT("PSO PNDEL1")
GOTO EX
+2 DO RESCH^XUTMOPT("PSO PNDEL1","","","7D","L")
DO EDIT^XUTMOPT("PSO PNDEL1")
EX KILL Y,C,D,D0,DI,DQ,DA,DIE,DR,DIC,Y,X,PSOTM,PSOOPTN,%DT
+1 QUIT
