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
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
D NOW^%DTC S PSGWDT=X
S AOUDA=0
AOULP S AOUDA=$O(^PSI(58.1,AOUDA)),DRGDA=0 G:'AOUDA END
DRGLP S DRGDA=$O(^PSI(58.1,AOUDA,1,DRGDA)) G:'DRGDA AOUDEL
DRGDEL ;DELETE INACTIVATED DRUG FROM AOU IF INACTIVE DATE LESS THAN OR EQUAL EDT, AND THERE IS NO INVENTORY DATA IN FILE FOR DRUG.
;G:$P(^PSI(58.1,AOUDA,1,DRGDA,0),"^",10)'="Y" DRGLP
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
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
I $D(^PSI(58.3,"B",DRGNUM)) G DRGLP
S DIK="^PSI(58.1,AOUDA,1,",DA=DRGDA,DA(1)=AOUDA D ^DIK K DIK G DRGLP
;
AOUDEL G:$O(^PSI(58.1,AOUDA,1,0)) AOULP
S GRPDA=0,DELFL=1
GRLP S GRPDA=$O(^PSI(58.2,GRPDA)),PTR=0 G:'GRPDA DEL
PTRLP S PTR=$O(^PSI(58.2,GRPDA,1,"B",PTR)) G:'PTR GRLP I PTR=AOUDA S DELFL=0
G PTRLP
;
DEL G:DELFL=0 AOULP
S DIK="^PSI(58.1,",DA=AOUDA D ^DIK K DIK G AOULP
;
END K AOUDA,DRGDA,LOC,DRGNUM,GRPDA,DELFL,PTR,DA,PSGWDT,%,%H,%I,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWOLD1 1307 printed Dec 13, 2024@01:39:42 Page 2
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
+2 DO NOW^%DTC
SET PSGWDT=X
+3 SET AOUDA=0
AOULP SET AOUDA=$ORDER(^PSI(58.1,AOUDA))
SET DRGDA=0
if 'AOUDA
GOTO END
DRGLP SET DRGDA=$ORDER(^PSI(58.1,AOUDA,1,DRGDA))
if 'DRGDA
GOTO AOUDEL
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
+2 SET LOC=^PSI(58.1,AOUDA,1,DRGDA,0)
SET DRGNUM=$PIECE(LOC,"^")
IF $PIECE(LOC,"^",3)=""
SET $PIECE(^PSI(58.1,AOUDA,1,DRGDA,0),"^",10)=""
GOTO DRGLP
+3 if $PIECE(LOC,"^",3)>PSGWDT
GOTO DRGLP
if $ORDER(^PSI(58.1,AOUDA,1,DRGDA,1,0))
GOTO DRGLP
if $ORDER(^PSI(58.1,AOUDA,1,DRGDA,3,0))
GOTO DRGLP
if $ORDER(^PSI(58.1,AOUDA,1,DRGDA,5,0))
GOTO DRGLP
+4 IF $DATA(^PSI(58.3,"B",DRGNUM))
GOTO DRGLP
+5 SET DIK="^PSI(58.1,AOUDA,1,"
SET DA=DRGDA
SET DA(1)=AOUDA
DO ^DIK
KILL DIK
GOTO DRGLP
+6 ;
AOUDEL if $ORDER(^PSI(58.1,AOUDA,1,0))
GOTO AOULP
+1 SET GRPDA=0
SET DELFL=1
GRLP SET GRPDA=$ORDER(^PSI(58.2,GRPDA))
SET PTR=0
if 'GRPDA
GOTO DEL
PTRLP SET PTR=$ORDER(^PSI(58.2,GRPDA,1,"B",PTR))
if 'PTR
GOTO GRLP
IF PTR=AOUDA
SET DELFL=0
+1 GOTO PTRLP
+2 ;
DEL if DELFL=0
GOTO AOULP
+1 SET DIK="^PSI(58.1,"
SET DA=AOUDA
DO ^DIK
KILL DIK
GOTO AOULP
+2 ;
END KILL AOUDA,DRGDA,LOC,DRGNUM,GRPDA,DELFL,PTR,DA,PSGWDT,%,%H,%I,X
+1 QUIT
