PSGWOLD1.m

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

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