- 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 Jan 18, 2025@03:36:31 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