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

PSGWOLD1.m

Go to the documentation of this file.
  1. PSGWOLD1 ;BHAM ISC/PTD,CML-Purge Old Inventory Data - CONTINUED (Delete Drugs Inactivated in AOU & Delete AOUs with No Drugs or Pointers to 58.2) ; 21 Jul 93 / 3:21 PM
  1. ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
  1. D NOW^%DTC S PSGWDT=X
  1. S AOUDA=0
  1. AOULP S AOUDA=$O(^PSI(58.1,AOUDA)),DRGDA=0 G:'AOUDA END
  1. DRGLP S DRGDA=$O(^PSI(58.1,AOUDA,1,DRGDA)) G:'DRGDA AOUDEL
  1. DRGDEL ;DELETE INACTIVATED DRUG FROM AOU IF INACTIVE DATE LESS THAN OR EQUAL EDT, AND THERE IS NO INVENTORY DATA IN FILE FOR DRUG.
  1. ;G:$P(^PSI(58.1,AOUDA,1,DRGDA,0),"^",10)'="Y" DRGLP
  1. S LOC=^PSI(58.1,AOUDA,1,DRGDA,0),DRGNUM=$P(LOC,"^") I $P(LOC,"^",3)="" S $P(^PSI(58.1,AOUDA,1,DRGDA,0),"^",10)="" G DRGLP
  1. G:$P(LOC,"^",3)>PSGWDT DRGLP G:$O(^PSI(58.1,AOUDA,1,DRGDA,1,0)) DRGLP G:$O(^PSI(58.1,AOUDA,1,DRGDA,3,0)) DRGLP G:$O(^PSI(58.1,AOUDA,1,DRGDA,5,0)) DRGLP
  1. I $D(^PSI(58.3,"B",DRGNUM)) G DRGLP
  1. S DIK="^PSI(58.1,AOUDA,1,",DA=DRGDA,DA(1)=AOUDA D ^DIK K DIK G DRGLP
  1. ;
  1. AOUDEL G:$O(^PSI(58.1,AOUDA,1,0)) AOULP
  1. S GRPDA=0,DELFL=1
  1. GRLP S GRPDA=$O(^PSI(58.2,GRPDA)),PTR=0 G:'GRPDA DEL
  1. PTRLP S PTR=$O(^PSI(58.2,GRPDA,1,"B",PTR)) G:'PTR GRLP I PTR=AOUDA S DELFL=0
  1. G PTRLP
  1. ;
  1. DEL G:DELFL=0 AOULP
  1. S DIK="^PSI(58.1,",DA=AOUDA D ^DIK K DIK G AOULP
  1. ;
  1. END K AOUDA,DRGDA,LOC,DRGNUM,GRPDA,DELFL,PTR,DA,PSGWDT,%,%H,%I,X
  1. Q