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 ---[H[J[2J[HPRCPRPKG 992 printed Dec 13, 2024@02:15:25 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
