PSGWOLD ;BHAM ISC/PTD,CML-Purge Old Inventory Data (Auto Replenish, On-Demands, Returns & Backorder Data) ; 21 Jul 93 / 3:16 PM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
W !!,"This option will purge data from files PSI(58.1), PSI(58.3), and PSI(58.19).",!,"You should retain the data for at least 1 quarter.",!,"Therefore, the option will NOT ALLOW DELETION of data newer than ""T-100"".",!!
W ?34,"**WARNING**",!?22,"Since this option is CPU intensive,",!?17,"it should be QUEUED to run in the ""off"" hours!",!!
BDT S BDT=0 I '$O(^PSI(58.19,"B",BDT)) W !,"There is NO data in the Pharmacy AOU Inventory file.",!! K BDT Q
E S BDT=$P($O(^PSI(58.19,"B",BDT)),".")
EDT S %DT="AEXP",%DT("A")="Purge INVENTORY data older than (and including): ",%DT("B")="T-100" D ^%DT K %DT G:Y<0 END S (EDT,X2)=Y
D NOW^%DTC S X1=$P(%,".") D ^%DTC I X<100 W !!,"Data less than 100 days old may NOT BE DELETED!",!! G EDT
I BDT>EDT W !!,"No INVENTORY data to purge in selected date range.",!! G END
ASK S Y=EDT X ^DD("DD") W !!,"I will now delete INVENTORY data that is older than (and including) ",Y,!,"Are you SURE that is what you want to do? NO// " R X:DTIME
G:'$T!("^Nn"[$E(X)) END
I "YyNn"'[$E(X) W !!,"Answer ""yes"" if you wish to purge INVENTORY data.",!,"Answer ""no"" or <return> if you do not.",!! G ASK
S ZTIO="",ZTRTN="ENQ^PSGWOLD",ZTDESC="Purge Inventory Data" F G="BDT","EDT" S:$D(@G) ZTSAVE(G)=""
D ^%ZTLOAD,HOME^%ZIS I $D(ZTSK) W !,"INVENTORY purge queued!" K ZTSK
G END
;
ENQ ;ENTRY POINT WHEN QUEUED
S LPDT=BDT-1,DATDA=0
DTLP S LPDT=$O(^PSI(58.19,"B",LPDT)) G:($P(LPDT,".")>EDT)!'LPDT BO
DTDA S DATDA=$O(^PSI(58.19,"B",LPDT,DATDA)),AOUDA=0 G:'DATDA DTLP S DELFL="" D INVK G AOULP
AOULP S AOUDA=$O(^PSI(58.1,AOUDA)),DRGDA=0 G:'AOUDA DTDA
DRGLP S DRGDA=$O(^PSI(58.1,AOUDA,1,DRGDA)) G:'DRGDA AOULP
;
AR ;DELETE DATA IN THE INVENTORY SUBFILE 58.12
I $D(^PSI(58.1,AOUDA,1,DRGDA,1,DATDA,0)) S DIE="^PSI(58.1,"_AOUDA_",1,"_DRGDA_",1,",DA=DATDA,DA(1)=DRGDA,DA(2)=AOUDA,DR=".01///@" D ^DIE K DIE
G RETURNS
;
RETURNS ;DELETE DATA IN THE RETURNS SUBFILE 58.15
S RETDT=0
RETLP S RETDT=$O(^PSI(58.1,AOUDA,1,DRGDA,3,RETDT)) G:'RETDT OD
I RETDT'>EDT S DIE="^PSI(58.1,"_AOUDA_",1,"_DRGDA_",3,",DA=RETDT,DA(1)=DRGDA,DA(2)=AOUDA,DR=".01///@" D ^DIE K DIE G RETLP
G RETLP
;
OD ;DELETE DATA IN THE ON-DEMAND REQUEST SUBFILE 58.28
S ODA=0
ODLP S ODA=$O(^PSI(58.1,AOUDA,1,DRGDA,5,ODA)) G:'ODA DRGLP S ODT=$P($P(^PSI(58.1,AOUDA,1,DRGDA,5,ODA,0),"^"),".")
I ODT'>EDT S DIE="^PSI(58.1,"_AOUDA_",1,"_DRGDA_",5,",DA=ODA,DA(1)=DRGDA,DA(2)=AOUDA,DR=".01///@" D ^DIE K DIE G ODLP
G ODLP
;
BO ;DELETE DATA IN FILE 58.3 - BACKORDER FILE
S (DRG,BODTDA)=0
BXREF F JJ=0:0 S DRG=$O(^PSI(58.3,DRG)) Q:'DRG I '$O(^PSI(58.3,DRG,1,0)) S DIE="^PSI(58.3,",DA=DRG,DR=".01///@" D ^DIE K DIE
BODTLP S DELFL="",BODTDA=$O(^PSI(58.3,"D",BODTDA)),BODRG=0 G:'BODTDA DONE
BODRGLP S BODRG=$O(^PSI(58.3,"D",BODTDA,BODRG)),BOAOU=0 D:'BODRG INVK G:'BODRG BODTLP
BOAOULP S BOAOU=$O(^PSI(58.3,"D",BODTDA,BODRG,BOAOU)),BOINV=0 G:'BOAOU BODRGLP
BOINVLP S BOINV=$O(^PSI(58.3,"D",BODTDA,BODRG,BOAOU,BOINV)) G:'BOINV BOAOULP
I (($P(^PSI(58.3,BODRG,1,BOAOU,1,BOINV,0),"^",5)'="")&($P(^(0),"^",5)'>EDT)) S DIE="^PSI(58.3,"_BODRG_",1,"_BOAOU_",1,",DA=BOINV,DA(1)=BOAOU,DA(2)=BODRG,DR=".01///@" D ^DIE K DIE D BODEL G BOINVLP
S DELFL="NO" G BOINVLP
;
INVK ;DELETE DATA IN FILE 58.19 - PHARMACY AOU INVENTORY FILE
I DELFL="" S DIK="^PSI(58.19,",DA=$S(DATDA="":BODTDA,1:DATDA) D ^DIK K DIK
Q
;
BODEL ;IF ALL BACKORDER DATES DELETED FOR BO AOU, THEN DELETE AOU FROM SUBFILE. IF ALL AOUS DELETED FOR DRUG, THEN DELETE DRUG FROM FILE.
I '$O(^PSI(58.3,BODRG,1,BOAOU,1,0)) S DIE="^PSI(58.3,"_BODRG_",1,",DA=BOAOU,DA(1)=BODRG,DR=".01///@" D ^DIE K DIE
I '$O(^PSI(58.3,BODRG,1,0)) S DIE="^PSI(58.3,",DA=BODRG,DR=".01///@" D ^DIE K DIE
Q
;
DONE D ^PSGWOLD1
END K ZTSK,BDT,EDT,X,Y,LPDT,DATDA,AOUDA,INVDA,DRGDA,ODA,ODT,RETDT,BODTDA,BODRG,BOAOU,BOINV,DELFL,DRG,JJ,%,%I,%H,DA,DR,G,ZTIO
S:$D(ZTQUEUED) ZTREQ="@" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWOLD 4044 printed Apr 09, 2024@20:45:29 Page 2
PSGWOLD ;BHAM ISC/PTD,CML-Purge Old Inventory Data (Auto Replenish, On-Demands, Returns & Backorder Data) ; 21 Jul 93 / 3:16 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 WRITE !!,"This option will purge data from files PSI(58.1), PSI(58.3), and PSI(58.19).",!,"You should retain the data for at least 1 quarter.",!,"Therefore, the option will NOT ALLOW DELETION of data newer than ""T-100"".",!!
+3 WRITE ?34,"**WARNING**",!?22,"Since this option is CPU intensive,",!?17,"it should be QUEUED to run in the ""off"" hours!",!!
BDT SET BDT=0
IF '$ORDER(^PSI(58.19,"B",BDT))
WRITE !,"There is NO data in the Pharmacy AOU Inventory file.",!!
KILL BDT
QUIT
+1 IF '$TEST
SET BDT=$PIECE($ORDER(^PSI(58.19,"B",BDT)),".")
EDT SET %DT="AEXP"
SET %DT("A")="Purge INVENTORY data older than (and including): "
SET %DT("B")="T-100"
DO ^%DT
KILL %DT
if Y<0
GOTO END
SET (EDT,X2)=Y
+1 DO NOW^%DTC
SET X1=$PIECE(%,".")
DO ^%DTC
IF X<100
WRITE !!,"Data less than 100 days old may NOT BE DELETED!",!!
GOTO EDT
+2 IF BDT>EDT
WRITE !!,"No INVENTORY data to purge in selected date range.",!!
GOTO END
ASK SET Y=EDT
XECUTE ^DD("DD")
WRITE !!,"I will now delete INVENTORY data that is older than (and including) ",Y,!,"Are you SURE that is what you want to do? NO// "
READ X:DTIME
+1 if '$TEST!("^Nn"[$EXTRACT(X))
GOTO END
+2 IF "YyNn"'[$EXTRACT(X)
WRITE !!,"Answer ""yes"" if you wish to purge INVENTORY data.",!,"Answer ""no"" or <return> if you do not.",!!
GOTO ASK
+3 SET ZTIO=""
SET ZTRTN="ENQ^PSGWOLD"
SET ZTDESC="Purge Inventory Data"
FOR G="BDT","EDT"
if $DATA(@G)
SET ZTSAVE(G)=""
+4 DO ^%ZTLOAD
DO HOME^%ZIS
IF $DATA(ZTSK)
WRITE !,"INVENTORY purge queued!"
KILL ZTSK
+5 GOTO END
+6 ;
ENQ ;ENTRY POINT WHEN QUEUED
+1 SET LPDT=BDT-1
SET DATDA=0
DTLP SET LPDT=$ORDER(^PSI(58.19,"B",LPDT))
if ($PIECE(LPDT,".")>EDT)!'LPDT
GOTO BO
DTDA SET DATDA=$ORDER(^PSI(58.19,"B",LPDT,DATDA))
SET AOUDA=0
if 'DATDA
GOTO DTLP
SET DELFL=""
DO INVK
GOTO AOULP
AOULP SET AOUDA=$ORDER(^PSI(58.1,AOUDA))
SET DRGDA=0
if 'AOUDA
GOTO DTDA
DRGLP SET DRGDA=$ORDER(^PSI(58.1,AOUDA,1,DRGDA))
if 'DRGDA
GOTO AOULP
+1 ;
AR ;DELETE DATA IN THE INVENTORY SUBFILE 58.12
+1 IF $DATA(^PSI(58.1,AOUDA,1,DRGDA,1,DATDA,0))
SET DIE="^PSI(58.1,"_AOUDA_",1,"_DRGDA_",1,"
SET DA=DATDA
SET DA(1)=DRGDA
SET DA(2)=AOUDA
SET DR=".01///@"
DO ^DIE
KILL DIE
+2 GOTO RETURNS
+3 ;
RETURNS ;DELETE DATA IN THE RETURNS SUBFILE 58.15
+1 SET RETDT=0
RETLP SET RETDT=$ORDER(^PSI(58.1,AOUDA,1,DRGDA,3,RETDT))
if 'RETDT
GOTO OD
+1 IF RETDT'>EDT
SET DIE="^PSI(58.1,"_AOUDA_",1,"_DRGDA_",3,"
SET DA=RETDT
SET DA(1)=DRGDA
SET DA(2)=AOUDA
SET DR=".01///@"
DO ^DIE
KILL DIE
GOTO RETLP
+2 GOTO RETLP
+3 ;
OD ;DELETE DATA IN THE ON-DEMAND REQUEST SUBFILE 58.28
+1 SET ODA=0
ODLP SET ODA=$ORDER(^PSI(58.1,AOUDA,1,DRGDA,5,ODA))
if 'ODA
GOTO DRGLP
SET ODT=$PIECE($PIECE(^PSI(58.1,AOUDA,1,DRGDA,5,ODA,0),"^"),".")
+1 IF ODT'>EDT
SET DIE="^PSI(58.1,"_AOUDA_",1,"_DRGDA_",5,"
SET DA=ODA
SET DA(1)=DRGDA
SET DA(2)=AOUDA
SET DR=".01///@"
DO ^DIE
KILL DIE
GOTO ODLP
+2 GOTO ODLP
+3 ;
BO ;DELETE DATA IN FILE 58.3 - BACKORDER FILE
+1 SET (DRG,BODTDA)=0
BXREF FOR JJ=0:0
SET DRG=$ORDER(^PSI(58.3,DRG))
if 'DRG
QUIT
IF '$ORDER(^PSI(58.3,DRG,1,0))
SET DIE="^PSI(58.3,"
SET DA=DRG
SET DR=".01///@"
DO ^DIE
KILL DIE
BODTLP SET DELFL=""
SET BODTDA=$ORDER(^PSI(58.3,"D",BODTDA))
SET BODRG=0
if 'BODTDA
GOTO DONE
BODRGLP SET BODRG=$ORDER(^PSI(58.3,"D",BODTDA,BODRG))
SET BOAOU=0
if 'BODRG
DO INVK
if 'BODRG
GOTO BODTLP
BOAOULP SET BOAOU=$ORDER(^PSI(58.3,"D",BODTDA,BODRG,BOAOU))
SET BOINV=0
if 'BOAOU
GOTO BODRGLP
BOINVLP SET BOINV=$ORDER(^PSI(58.3,"D",BODTDA,BODRG,BOAOU,BOINV))
if 'BOINV
GOTO BOAOULP
+1 IF (($PIECE(^PSI(58.3,BODRG,1,BOAOU,1,BOINV,0),"^",5)'="")&($PIECE(^(0),"^",5)'>EDT))
SET DIE="^PSI(58.3,"_BODRG_",1,"_BOAOU_",1,"
SET DA=BOINV
SET DA(1)=BOAOU
SET DA(2)=BODRG
SET DR=".01///@"
DO ^DIE
KILL DIE
DO BODEL
GOTO BOINVLP
+2 SET DELFL="NO"
GOTO BOINVLP
+3 ;
INVK ;DELETE DATA IN FILE 58.19 - PHARMACY AOU INVENTORY FILE
+1 IF DELFL=""
SET DIK="^PSI(58.19,"
SET DA=$SELECT(DATDA="":BODTDA,1:DATDA)
DO ^DIK
KILL DIK
+2 QUIT
+3 ;
BODEL ;IF ALL BACKORDER DATES DELETED FOR BO AOU, THEN DELETE AOU FROM SUBFILE. IF ALL AOUS DELETED FOR DRUG, THEN DELETE DRUG FROM FILE.
+1 IF '$ORDER(^PSI(58.3,BODRG,1,BOAOU,1,0))
SET DIE="^PSI(58.3,"_BODRG_",1,"
SET DA=BOAOU
SET DA(1)=BODRG
SET DR=".01///@"
DO ^DIE
KILL DIE
+2 IF '$ORDER(^PSI(58.3,BODRG,1,0))
SET DIE="^PSI(58.3,"
SET DA=BODRG
SET DR=".01///@"
DO ^DIE
KILL DIE
+3 QUIT
+4 ;
DONE DO ^PSGWOLD1
END KILL ZTSK,BDT,EDT,X,Y,LPDT,DATDA,AOUDA,INVDA,DRGDA,ODA,ODT,RETDT,BODTDA,BODRG,BOAOU,BOINV,DELFL,DRG,JJ,%,%I,%H,DA,DR,G,ZTIO
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
