- 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 Feb 18, 2025@23:06:05 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