Routine: PSGWDEL

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)=""

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),"^")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWDEL   1935     printed  Feb 18, 2025@23:05:34                                                                                                                                                                                                     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

PSGWDEL.m