- 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 Jan 18, 2025@02:40:56 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