PRCPRPKG.m

PRCPRPKG ;WISC/RFJ-packaging discrepancy report                     ;04 Oct 91

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 D ^PRCPUSEL Q:'$G(PRCP("I"))

 I "WP"'[PRCP("DPTYPE") W !,"THIS PROGRAM CAN ONLY BE USED BY THE WAREHOUSE OR PRIMARY INVENTORY POINTS." Q

 N WHSESRCE,X,Y

 S WHSESRCE=$O(^PRC(440,"AC","S",0)) I 'WHSESRCE W !!,"YOU DO NOT HAVE A VENDOR (FILE #440) ENTERED AS A SUPPLY WAREHOUSE.",! Q

 ;  get selected item list

 D ITEMSEL^PRCPURS4

 I '$O(^TMP($J,"PRCPURS4",0)),'$D(PRCPALLI) Q

 S %ZIS="Q" D ^%ZIS Q:POP  I $D(IO("Q")) D  D ^%ZTLOAD K IO("Q"),ZTSK D Q Q

 .   S ZTDESC="Packaging Discrepancy Report",ZTRTN="DQ^PRCPRPKG"

 .   S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPURS4"",")="",ZTSAVE("WHSESRCE")="",ZTSAVE("ZTREQ")="@"

 W !!,"<*> please wait <*>"

DQ ;  queue comes here

 ;  find errors

 D PROCESS^PRCPRPK1

 ;  print errors

 D PRINT^PRCPRPK2

Q K ^TMP($J,"PRCPURS4"),^TMP($J,"PRCPRPKG") D ^%ZISC

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCPRPKG   992     printed  Apr 09, 2024@21:06:55                                                                                                                                                                                                     Page 2

PRCPRPKG  ;WISC/RFJ-packaging discrepancy report                     ;04 Oct 91

 +1       ;;5.1;IFCAP;;Oct 20, 2000

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        DO ^PRCPUSEL

           if '$GET(PRCP("I"))

               QUIT 

 +4        IF "WP"'[PRCP("DPTYPE")

               WRITE !,"THIS PROGRAM CAN ONLY BE USED BY THE WAREHOUSE OR PRIMARY INVENTORY POINTS."

               QUIT 

 +5        NEW WHSESRCE,X,Y

 +6        SET WHSESRCE=$ORDER(^PRC(440,"AC","S",0))

           IF 'WHSESRCE

               WRITE !!,"YOU DO NOT HAVE A VENDOR (FILE #440) ENTERED AS A SUPPLY WAREHOUSE.",!

               QUIT 

 +7       ;  get selected item list

 +8        DO ITEMSEL^PRCPURS4

 +9        IF '$ORDER(^TMP($JOB,"PRCPURS4",0))

               IF '$DATA(PRCPALLI)

                   QUIT 

 +10       SET %ZIS="Q"

           DO ^%ZIS

           if POP

               QUIT 

           IF $DATA(IO("Q"))

               Begin DoDot:1

 +11               SET ZTDESC="Packaging Discrepancy Report"

                   SET ZTRTN="DQ^PRCPRPKG"

 +12               SET ZTSAVE("PRCP*")=""

                   SET ZTSAVE("^TMP($J,""PRCPURS4"",")=""

                   SET ZTSAVE("WHSESRCE")=""

                   SET ZTSAVE("ZTREQ")="@"

               End DoDot:1

               DO ^%ZTLOAD

               KILL IO("Q"),ZTSK

               DO Q

               QUIT 

 +13       WRITE !!,"<*> please wait <*>"

DQ        ;  queue comes here

 +1       ;  find errors

 +2        DO PROCESS^PRCPRPK1

 +3       ;  print errors

 +4        DO PRINT^PRCPRPK2

Q          KILL ^TMP($JOB,"PRCPURS4"),^TMP($JOB,"PRCPRPKG")

           DO ^%ZISC

 +1        QUIT