PSGWDEL ;BHAM ISC/CML-Delete Inventory Sheets ; 02/14/90 8:14
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
W !!,"*** READY TO DELETE ***",! F II=0:0 S DIC="^PSI(58.19,",DIC(0)="QEAMN",DIC("A")="Select DATE/TIME FOR INVENTORY to be deleted: " W ! D ^DIC K DIC Q:Y'>0 S INVDA=+Y,INVDT=$P(Y,"^",2) D START
QUIT K ^TMP("PSGW",$J),%,%Y,BO,BODRUG,GRP,II,DA,DIK,INVDA,INVDT,ITM,LN,LP,MR,PC,X,Y Q
START ;
W !!,"First, let me check for existing entries in other files for this Inventory Date.",! K ^TMP("PSGW",$J) D CHK
I $D(^TMP("PSGW",$J)) D PRT W *7,!!,"Because this Inventory Date is pointed to, it cannot be deleted at this time." Q
I '$D(^TMP("PSGW",$J)) W !!,"None found." F II=0:0 W !!,"Are you sure you want to delete this Inventory Sheet " S %=2 D YN^DICN Q:% W !?60,"Enter 'Y' or 'N'"
Q:%'=1 S DIK="^PSI(58.19,",DA=INVDA D ^DIK W !,"...Deleted" Q
CHK ;Check PHARMACY AOU STOCK FILE (#58.1)
F MR=0:0 S MR=$O(^PSI(58.1,MR)) Q:'MR W "." F ITM=0:0 S ITM=$O(^PSI(58.1,MR,1,ITM)) Q:'ITM I $D(^(ITM,1,INVDA,0)) S ^TMP("PSGW",$J,"PASF",MR,ITM)=""
;Check PHARMACY BACKORDER file (#58.3)
F BO=0:0 S BO=$O(^PSI(58.3,"D",INVDT,BO)) Q:'BO S MR=$O(^(BO,0)) I MR W "." S ^TMP("PSGW",$J,"PBO",BO,MR)=""
Q
PRT ;Print pointer entries
S $P(LN,"-",80)=""
I $D(^TMP("PSGW",$J,"PASF")) W !!,"***> There are entries in the PHARMACY AOU STOCK FILE (#58.1) for this",!?5,"DATE/TIME FOR INVENTORY for MED ROOM(S):",!,LN
I F MR=0:0 S MR=$O(^TMP("PSGW",$J,"PASF",MR)) Q:'MR W !,$P(^PSI(58.1,MR,0),"^")
I $D(^TMP("PSGW",$J,"PBO")) W !!,"***> There are entries in the PHARMACY BACKORDER FILE (#58.3) for this",!?5,"DATE/TIME FOR INVENTORY for the following ITEMS:",!!?18,"ITEM",?50,"MED ROOM",!,LN
I F BO=0:0 S BO=$O(^TMP("PSGW",$J,"PBO",BO)) Q:'BO S:$D(^PSI(58.3,BO,0)) BODRUG=+^(0) Q:'BODRUG F MR=0:0 S MR=$O(^TMP("PSGW",$J,"PBO",BO,MR)) Q:'MR W !,$P(^PSDRUG(BODRUG,0),"^"),?45,$P(^PSI(58.1,MR,0),"^")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWDEL 1935 printed Dec 13, 2024@01:39:10 Page 2
PSGWDEL ;BHAM ISC/CML-Delete Inventory Sheets ; 02/14/90 8:14
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 WRITE !!,"*** READY TO DELETE ***",!
FOR II=0:0
SET DIC="^PSI(58.19,"
SET DIC(0)="QEAMN"
SET DIC("A")="Select DATE/TIME FOR INVENTORY to be deleted: "
WRITE !
DO ^DIC
KILL DIC
if Y'>0
QUIT
SET INVDA=+Y
SET INVDT=$PIECE(Y,"^",2)
DO START
QUIT KILL ^TMP("PSGW",$JOB),%,%Y,BO,BODRUG,GRP,II,DA,DIK,INVDA,INVDT,ITM,LN,LP,MR,PC,X,Y
QUIT
START ;
+1 WRITE !!,"First, let me check for existing entries in other files for this Inventory Date.",!
KILL ^TMP("PSGW",$JOB)
DO CHK
+2 IF $DATA(^TMP("PSGW",$JOB))
DO PRT
WRITE *7,!!,"Because this Inventory Date is pointed to, it cannot be deleted at this time."
QUIT
+3 IF '$DATA(^TMP("PSGW",$JOB))
WRITE !!,"None found."
FOR II=0:0
WRITE !!,"Are you sure you want to delete this Inventory Sheet "
SET %=2
DO YN^DICN
if %
QUIT
WRITE !?60,"Enter 'Y' or 'N'"
+4 if %'=1
QUIT
SET DIK="^PSI(58.19,"
SET DA=INVDA
DO ^DIK
WRITE !,"...Deleted"
QUIT
CHK ;Check PHARMACY AOU STOCK FILE (#58.1)
+1 FOR MR=0:0
SET MR=$ORDER(^PSI(58.1,MR))
if 'MR
QUIT
WRITE "."
FOR ITM=0:0
SET ITM=$ORDER(^PSI(58.1,MR,1,ITM))
if 'ITM
QUIT
IF $DATA(^(ITM,1,INVDA,0))
SET ^TMP("PSGW",$JOB,"PASF",MR,ITM)=""
+2 ;Check PHARMACY BACKORDER file (#58.3)
+3 FOR BO=0:0
SET BO=$ORDER(^PSI(58.3,"D",INVDT,BO))
if 'BO
QUIT
SET MR=$ORDER(^(BO,0))
IF MR
WRITE "."
SET ^TMP("PSGW",$JOB,"PBO",BO,MR)=""
+4 QUIT
PRT ;Print pointer entries
+1 SET $PIECE(LN,"-",80)=""
+2 IF $DATA(^TMP("PSGW",$JOB,"PASF"))
WRITE !!,"***> There are entries in the PHARMACY AOU STOCK FILE (#58.1) for this",!?5,"DATE/TIME FOR INVENTORY for MED ROOM(S):",!,LN
+3 IF $TEST
FOR MR=0:0
SET MR=$ORDER(^TMP("PSGW",$JOB,"PASF",MR))
if 'MR
QUIT
WRITE !,$PIECE(^PSI(58.1,MR,0),"^")
+4 IF $DATA(^TMP("PSGW",$JOB,"PBO"))
WRITE !!,"***> There are entries in the PHARMACY BACKORDER FILE (#58.3) for this",!?5,"DATE/TIME FOR INVENTORY for the following ITEMS:",!!?18,"ITEM",?50,"MED ROOM",!,LN
+5 IF $TEST
FOR BO=0:0
SET BO=$ORDER(^TMP("PSGW",$JOB,"PBO",BO))
if 'BO
QUIT
if $DATA(^PSI(58.3,BO,0))
SET BODRUG=+^(0)
if 'BODRUG
QUIT
FOR MR=0:0
SET MR=$ORDER(^TMP("PSGW",$JOB,"PBO",BO,MR))
if 'MR
QUIT
WRITE !,$PIECE(^PSDRUG(BODRUG,0),"^"),?45,$PIECE(^PSI(58.1,MR,0),"^")
+6 QUIT
