PSGWEXP ;BHAM ISC/CML-Enter/Edit Drug Expiration Dates ; 26 Nov 93 / 2:46 PM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
W !!,"Enter Expiration Dates for Stock Items"
K DIC F QQ=0:0 S DIC="^PSI(58.1,",DIC(0)="QEAM",DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,^(""I"")>DT:1,1:0)" W ! D ^DIC K DIC Q:Y'>0 W ! S MEDR=+Y F QQ=0:0 D ITEM Q:"^"[X
QUIT K %,C,D0,DA,DI,DIE,DIC,DIYS,DQ,DR,MEDR,QQ,X,Y Q
ITEM I '$O(^PSI(58.1,MEDR,1,0)) W !!,"No items exist for this AOU." S X="^" Q
S DIC="^PSI(58.1,"_MEDR_",1,",DIC(0)="QEAOM" W ! D ^DIC Q:Y'>0 S DA(1)=MEDR,DA=+Y,DIE=DIC,DR="35" W ! D ^DIE Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWEXP 604 printed Nov 22, 2024@16:49:31 Page 2
PSGWEXP ;BHAM ISC/CML-Enter/Edit Drug Expiration Dates ; 26 Nov 93 / 2:46 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 WRITE !!,"Enter Expiration Dates for Stock Items"
+3 KILL DIC
FOR QQ=0:0
SET DIC="^PSI(58.1,"
SET DIC(0)="QEAM"
SET DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,^(""I"")>DT:1,1:0)"
WRITE !
DO ^DIC
KILL DIC
if Y'>0
QUIT
WRITE !
SET MEDR=+Y
FOR QQ=0:0
DO ITEM
if "^"[X
QUIT
QUIT KILL %,C,D0,DA,DI,DIE,DIC,DIYS,DQ,DR,MEDR,QQ,X,Y
QUIT
ITEM IF '$ORDER(^PSI(58.1,MEDR,1,0))
WRITE !!,"No items exist for this AOU."
SET X="^"
QUIT
+1 SET DIC="^PSI(58.1,"_MEDR_",1,"
SET DIC(0)="QEAOM"
WRITE !
DO ^DIC
if Y'>0
QUIT
SET DA(1)=MEDR
SET DA=+Y
SET DIE=DIC
SET DR="35"
WRITE !
DO ^DIE
QUIT
