PSGWAOUI ;BHAM ISC/CML-Enter/Edit AOU Inactivation Dates ; 21 Aug 96 / 2:37 PM
;;2.3; Automatic Replenishment/Ward Stock ;**7,8**;4 JAN 94
W !!,"Enter AOU Inactivation Dates" S QFLG=0
K DIC F Q=0:0 S DIC="^PSI(58.1,",DIC(0)="QEAM" W ! D ^DIC K DIC Q:Y'>0 S (DA,AOU)=+Y,PRE="" S:$D(^PSI(58.1,DA,"I")) PRE=^("I") S DIE="^PSI(58.1,",DR="3" W ! D ^DIE Q:$D(Y) D CHK Q:QFLG
QUIT K %,%DT,%Y,AOU,ASKFLG,C,D0,DA,DI,DIE,DIC,DIYS,DQ,DR,FOUND,INDT,ITM,JJ,POST,PRE,PRTDT,Q,QFLG,X,Y Q
CHK ; Do checks on AOU inactivation date
S POST="" I $D(^PSI(58.1,AOU,"I")) S POST=^("I") Q:PRE=""&(POST="")
I PRE=POST!(PRE=""&(POST]"")) W !,"...One moment, please..." D ITMCHK D:ASKFLG ASK Q
I PRE]""&(POST="") D REACT Q
I PRE'=POST W !,"...Hmm, one moment..." D ITMCHK D:ASKFLG ASK
Q
ITMCHK ; Look for any currently active items or items with an inactive date AFTER TODAY
S ASKFLG=0 F ITM=0:0 S ITM=$O(^PSI(58.1,AOU,1,ITM)) Q:'ITM I $P(^PSI(58.1,AOU,1,ITM,0),"^",3)=""!($P(^(0),"^",3)>DT) S ASKFLG=1 Q
Q
ASK ; Ask if currently active items are to be inactivated
S INDT=POST S Y=INDT X ^DD("DD") S PRTDT=Y W !!,"There are items in this AOU that are currently active.",!,"You may, at this time, inactivate all of them as of ",Y,"."
F JJ=0:0 W !!,"Do you want to do this" S %=1 D YN^DICN Q:% D HELP
D:%=1 INACT S:%<0 QFLG=1 Q
INACT ; Inactivate items
S DA(1)=AOU,DIE="^PSI(58.1,"_DA(1)_",1,",DR="30///"_$P(PRTDT,"@")_";31///O;33///AOU INACTIVATED" W !!,"Now inactivating all currently active items as of ",PRTDT
F ITM=0:0 S ITM=$O(^PSI(58.1,AOU,1,ITM)) Q:'ITM I $D(^PSI(58.1,AOU,1,ITM,0)) I $P(^(0),"^",3)=""!($P(^(0),"^",3)>DT) S DA=ITM D ^DIE W "."
Q
REACT ; Reactivate items
S DA(1)=AOU,DIE="^PSI(58.1,"_DA(1)_",1,",DR="30///@" W !!,"Now deleting the inactivation dates for any items that were inactivated when",!,"this AOU was inactivated" S FOUND=0
F ITM=0:0 S ITM=$O(^PSI(58.1,AOU,1,ITM)) Q:'ITM I $D(^PSI(58.1,AOU,1,ITM,0)),$P(^(0),"^",9)="AOU INACTIVATED" S DA=ITM D ^DIE W "." S FOUND=1
I 'FOUND W *7," ...None found!"
Q
HELP ;
W !!?5,"Enter 'Y' if you want to inactivate all currently active items.",!?5,"Enter 'N' if you do not wish to inactivate all currently active items.",!?5,"Enter ""^"" to Exit." Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWAOUI 2246 printed Nov 22, 2024@16:48:59 Page 2
PSGWAOUI ;BHAM ISC/CML-Enter/Edit AOU Inactivation Dates ; 21 Aug 96 / 2:37 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;**7,8**;4 JAN 94
+2 WRITE !!,"Enter AOU Inactivation Dates"
SET QFLG=0
+3 KILL DIC
FOR Q=0:0
SET DIC="^PSI(58.1,"
SET DIC(0)="QEAM"
WRITE !
DO ^DIC
KILL DIC
if Y'>0
QUIT
SET (DA,AOU)=+Y
SET PRE=""
if $DATA(^PSI(58.1,DA,"I"))
SET PRE=^("I")
SET DIE="^PSI(58.1,"
SET DR="3"
WRITE !
DO ^DIE
if $DATA(Y)
QUIT
DO CHK
if QFLG
QUIT
QUIT KILL %,%DT,%Y,AOU,ASKFLG,C,D0,DA,DI,DIE,DIC,DIYS,DQ,DR,FOUND,INDT,ITM,JJ,POST,PRE,PRTDT,Q,QFLG,X,Y
QUIT
CHK ; Do checks on AOU inactivation date
+1 SET POST=""
IF $DATA(^PSI(58.1,AOU,"I"))
SET POST=^("I")
if PRE=""&(POST="")
QUIT
+2 IF PRE=POST!(PRE=""&(POST]""))
WRITE !,"...One moment, please..."
DO ITMCHK
if ASKFLG
DO ASK
QUIT
+3 IF PRE]""&(POST="")
DO REACT
QUIT
+4 IF PRE'=POST
WRITE !,"...Hmm, one moment..."
DO ITMCHK
if ASKFLG
DO ASK
+5 QUIT
ITMCHK ; Look for any currently active items or items with an inactive date AFTER TODAY
+1 SET ASKFLG=0
FOR ITM=0:0
SET ITM=$ORDER(^PSI(58.1,AOU,1,ITM))
if 'ITM
QUIT
IF $PIECE(^PSI(58.1,AOU,1,ITM,0),"^",3)=""!($PIECE(^(0),"^",3)>DT)
SET ASKFLG=1
QUIT
+2 QUIT
ASK ; Ask if currently active items are to be inactivated
+1 SET INDT=POST
SET Y=INDT
XECUTE ^DD("DD")
SET PRTDT=Y
WRITE !!,"There are items in this AOU that are currently active.",!,"You may, at this time, inactivate all of them as of ",Y,"."
+2 FOR JJ=0:0
WRITE !!,"Do you want to do this"
SET %=1
DO YN^DICN
if %
QUIT
DO HELP
+3 if %=1
DO INACT
if %<0
SET QFLG=1
QUIT
INACT ; Inactivate items
+1 SET DA(1)=AOU
SET DIE="^PSI(58.1,"_DA(1)_",1,"
SET DR="30///"_$PIECE(PRTDT,"@")_";31///O;33///AOU INACTIVATED"
WRITE !!,"Now inactivating all currently active items as of ",PRTDT
+2 FOR ITM=0:0
SET ITM=$ORDER(^PSI(58.1,AOU,1,ITM))
if 'ITM
QUIT
IF $DATA(^PSI(58.1,AOU,1,ITM,0))
IF $PIECE(^(0),"^",3)=""!($PIECE(^(0),"^",3)>DT)
SET DA=ITM
DO ^DIE
WRITE "."
+3 QUIT
REACT ; Reactivate items
+1 SET DA(1)=AOU
SET DIE="^PSI(58.1,"_DA(1)_",1,"
SET DR="30///@"
WRITE !!,"Now deleting the inactivation dates for any items that were inactivated when",!,"this AOU was inactivated"
SET FOUND=0
+2 FOR ITM=0:0
SET ITM=$ORDER(^PSI(58.1,AOU,1,ITM))
if 'ITM
QUIT
IF $DATA(^PSI(58.1,AOU,1,ITM,0))
IF $PIECE(^(0),"^",9)="AOU INACTIVATED"
SET DA=ITM
DO ^DIE
WRITE "."
SET FOUND=1
+3 IF 'FOUND
WRITE *7," ...None found!"
+4 QUIT
HELP ;
+1 WRITE !!?5,"Enter 'Y' if you want to inactivate all currently active items.",!?5,"Enter 'N' if you do not wish to inactivate all currently active items.",!?5,"Enter ""^"" to Exit."
QUIT
