Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGWOLD

PSGWOLD.m

Go to the documentation of this file.
  1. 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
  1. 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"".",!!
  1. W ?34,"**WARNING**",!?22,"Since this option is CPU intensive,",!?17,"it should be QUEUED to run in the ""off"" hours!",!!
  1. 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
  1. E S BDT=$P($O(^PSI(58.19,"B",BDT)),".")
  1. 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
  1. D NOW^%DTC S X1=$P(%,".") D ^%DTC I X<100 W !!,"Data less than 100 days old may NOT BE DELETED!",!! G EDT
  1. I BDT>EDT W !!,"No INVENTORY data to purge in selected date range.",!! G END
  1. 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
  1. G:'$T!("^Nn"[$E(X)) END
  1. I "YyNn"'[$E(X) W !!,"Answer ""yes"" if you wish to purge INVENTORY data.",!,"Answer ""no"" or <return> if you do not.",!! G ASK
  1. S ZTIO="",ZTRTN="ENQ^PSGWOLD",ZTDESC="Purge Inventory Data" F G="BDT","EDT" S:$D(@G) ZTSAVE(G)=""
  1. D ^%ZTLOAD,HOME^%ZIS I $D(ZTSK) W !,"INVENTORY purge queued!" K ZTSK
  1. G END
  1. ;
  1. ENQ ;ENTRY POINT WHEN QUEUED
  1. S LPDT=BDT-1,DATDA=0
  1. DTLP S LPDT=$O(^PSI(58.19,"B",LPDT)) G:($P(LPDT,".")>EDT)!'LPDT BO
  1. DTDA S DATDA=$O(^PSI(58.19,"B",LPDT,DATDA)),AOUDA=0 G:'DATDA DTLP S DELFL="" D INVK G AOULP
  1. AOULP S AOUDA=$O(^PSI(58.1,AOUDA)),DRGDA=0 G:'AOUDA DTDA
  1. DRGLP S DRGDA=$O(^PSI(58.1,AOUDA,1,DRGDA)) G:'DRGDA AOULP
  1. ;
  1. AR ;DELETE DATA IN THE INVENTORY SUBFILE 58.12
  1. 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
  1. G RETURNS
  1. ;
  1. RETURNS ;DELETE DATA IN THE RETURNS SUBFILE 58.15
  1. S RETDT=0
  1. RETLP S RETDT=$O(^PSI(58.1,AOUDA,1,DRGDA,3,RETDT)) G:'RETDT OD
  1. 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
  1. G RETLP
  1. ;
  1. OD ;DELETE DATA IN THE ON-DEMAND REQUEST SUBFILE 58.28
  1. S ODA=0
  1. 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),"^"),".")
  1. 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
  1. G ODLP
  1. ;
  1. BO ;DELETE DATA IN FILE 58.3 - BACKORDER FILE
  1. S (DRG,BODTDA)=0
  1. 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
  1. BODTLP S DELFL="",BODTDA=$O(^PSI(58.3,"D",BODTDA)),BODRG=0 G:'BODTDA DONE
  1. BODRGLP S BODRG=$O(^PSI(58.3,"D",BODTDA,BODRG)),BOAOU=0 D:'BODRG INVK G:'BODRG BODTLP
  1. BOAOULP S BOAOU=$O(^PSI(58.3,"D",BODTDA,BODRG,BOAOU)),BOINV=0 G:'BOAOU BODRGLP
  1. BOINVLP S BOINV=$O(^PSI(58.3,"D",BODTDA,BODRG,BOAOU,BOINV)) G:'BOINV BOAOULP
  1. 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
  1. S DELFL="NO" G BOINVLP
  1. ;
  1. INVK ;DELETE DATA IN FILE 58.19 - PHARMACY AOU INVENTORY FILE
  1. I DELFL="" S DIK="^PSI(58.19,",DA=$S(DATDA="":BODTDA,1:DATDA) D ^DIK K DIK
  1. Q
  1. ;
  1. 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. 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
  1. I '$O(^PSI(58.3,BODRG,1,0)) S DIE="^PSI(58.3,",DA=BODRG,DR=".01///@" D ^DIE K DIE
  1. Q
  1. ;
  1. DONE D ^PSGWOLD1
  1. 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
  1. S:$D(ZTQUEUED) ZTREQ="@" Q