PSOSUDEL.m

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

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