PRCPOPER ;WISC/RFJ/DGL - distribution order error report;3/17/00 3:23pm
V ;;5.1;IFCAP;**205**;Oct 20, 2000;Build 4
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
CHECKORD ; check order for errors (called from prcpopl protocol)
D VARIABLE^PRCPOPU
D EN^VALM("PRCP DIST ORDER CHECK ITEMS")
D INIT^PRCPOPL
S VALMBCK="R"
Q
;
;
INIT ; check order for errors and build array
N DATA,ERROR,ITEMDA,QTYORDER,STATUS,QTYOH
K ^TMP($J,"PRCPOPER")
S VALMCNT=0
I 'PRCPPRIM D SET^PRCPOPL("PRIMARY INVENTORY SOURCE MISSING. PLEASE RE-EDIT THE ORDER FIRST.") Q
I 'PRCPSECO D SET^PRCPOPL("SECONDARY INVENTORY POINT IS MISSING, PLEASE RE-EDIT THE ORDER FIRST.") Q
;
S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6)
; check items on order
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA,0) D
. S QTYORDER=$P(DATA,"^",2)
. I 'QTYORDER D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS),SET^PRCPOPL(" ** THERE IS NO QUANTITY ORDERED, ITEM SHOULD BE DELETED FROM ORDER **") Q
. S ERROR=$$ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA)
. S X=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
. I X]"" D
. . S QTYOH=+$P(X,"^",7)
. . I PRCP("DPTYPE")'="S",QTYOH<QTYORDER S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** QTY ORDERED ("_QTYORDER_") IS MORE THAN PRIMARY QTY ON HAND ("_QTYOH_") **"
. . Q
. I ERROR="" Q
. D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
. F %=1:1 Q:$P(ERROR,"^",%,99)="" I $P(ERROR,"^",%)'="" D SET^PRCPOPL($P(ERROR,"^",%))
;
I VALMCNT=0 S VALMQUIT=1,VALMSG="* * * NO ERRORS FOUND * * *"
Q
;
;
EXIT ; exit and clean up
K ^TMP($J,"PRCPOPER")
Q
;
;
EEITEMS ; called from protocol file to enter/edit invpt items
D
. N PRC,PRCP
. S PRCP("DPTYPE")="PS"
. D ^PRCPEILM
D INIT
S VALMBCK="R"
I $G(VALMQUIT) K VALMBCK
Q
;
;
ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA) ; check items
; returns errors delimited by ^ or ""
N ITEMDATA,ERROR,VDATA
S ERROR=""
S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
I ITEMDATA="" S ERROR=" ** ITEM NOT STORED IN PRIMARY INVENTORY POINT ** ^ Either add item to primary or delete item from order."
I '$D(^PRCP(445,PRCPSECO,1,ITEMDA,0)) S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** ITEM NOT STORED IN SECONDARY INVENTORY POINT **"
;
S VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1)
I 'VDATA S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** PRIMARY INVENTORY POINT IS NOT LISTED AS A SOURCE **"
I $P(VDATA,"^",2,3)'=($P(ITEMDATA,"^",5)_"^"_$P(ITEMDATA,"^",14)) S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** SECONDARY UNIT PER RECEIPT DOES NOT EQUAL PRIMARY UNIT PER ISSUE **"
Q ERROR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPER 2735 printed Jun 11, 2024@21:55:28 Page 2
PRCPOPER ;WISC/RFJ/DGL - distribution order error report;3/17/00 3:23pm
V ;;5.1;IFCAP;**205**;Oct 20, 2000;Build 4
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
CHECKORD ; check order for errors (called from prcpopl protocol)
+1 DO VARIABLE^PRCPOPU
+2 DO EN^VALM("PRCP DIST ORDER CHECK ITEMS")
+3 DO INIT^PRCPOPL
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
+7 ;
INIT ; check order for errors and build array
+1 NEW DATA,ERROR,ITEMDA,QTYORDER,STATUS,QTYOH
+2 KILL ^TMP($JOB,"PRCPOPER")
+3 SET VALMCNT=0
+4 IF 'PRCPPRIM
DO SET^PRCPOPL("PRIMARY INVENTORY SOURCE MISSING. PLEASE RE-EDIT THE ORDER FIRST.")
QUIT
+5 IF 'PRCPSECO
DO SET^PRCPOPL("SECONDARY INVENTORY POINT IS MISSING, PLEASE RE-EDIT THE ORDER FIRST.")
QUIT
+6 ;
+7 SET STATUS=$PIECE(^PRCP(445.3,ORDERDA,0),"^",6)
+8 ; check items on order
+9 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
if 'ITEMDA
QUIT
SET DATA=^(ITEMDA,0)
Begin DoDot:1
+10 SET QTYORDER=$PIECE(DATA,"^",2)
+11 IF 'QTYORDER
DO BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
DO SET^PRCPOPL(" ** THERE IS NO QUANTITY ORDERED, ITEM SHOULD BE DELETED FROM ORDER **")
QUIT
+12 SET ERROR=$$ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA)
+13 SET X=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
+14 IF X]""
Begin DoDot:2
+15 SET QTYOH=+$PIECE(X,"^",7)
+16 IF PRCP("DPTYPE")'="S"
IF QTYOH<QTYORDER
SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** QTY ORDERED ("_QTYORDER_") IS MORE THAN PRIMARY QTY ON HAND ("_QTYOH_") **"
+17 QUIT
End DoDot:2
+18 IF ERROR=""
QUIT
+19 DO BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
+20 FOR %=1:1
if $PIECE(ERROR,"^",%,99)=""
QUIT
IF $PIECE(ERROR,"^",%)'=""
DO SET^PRCPOPL($PIECE(ERROR,"^",%))
End DoDot:1
+21 ;
+22 IF VALMCNT=0
SET VALMQUIT=1
SET VALMSG="* * * NO ERRORS FOUND * * *"
+23 QUIT
+24 ;
+25 ;
EXIT ; exit and clean up
+1 KILL ^TMP($JOB,"PRCPOPER")
+2 QUIT
+3 ;
+4 ;
EEITEMS ; called from protocol file to enter/edit invpt items
+1 Begin DoDot:1
+2 NEW PRC,PRCP
+3 SET PRCP("DPTYPE")="PS"
+4 DO ^PRCPEILM
End DoDot:1
+5 DO INIT
+6 SET VALMBCK="R"
+7 IF $GET(VALMQUIT)
KILL VALMBCK
+8 QUIT
+9 ;
+10 ;
ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA) ; check items
+1 ; returns errors delimited by ^ or ""
+2 NEW ITEMDATA,ERROR,VDATA
+3 SET ERROR=""
+4 SET ITEMDATA=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
+5 IF ITEMDATA=""
SET ERROR=" ** ITEM NOT STORED IN PRIMARY INVENTORY POINT ** ^ Either add item to primary or delete item from order."
+6 IF '$DATA(^PRCP(445,PRCPSECO,1,ITEMDA,0))
SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** ITEM NOT STORED IN SECONDARY INVENTORY POINT **"
+7 ;
+8 SET VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1)
+9 IF 'VDATA
SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** PRIMARY INVENTORY POINT IS NOT LISTED AS A SOURCE **"
+10 IF $PIECE(VDATA,"^",2,3)'=($PIECE(ITEMDATA,"^",5)_"^"_$PIECE(ITEMDATA,"^",14))
SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** SECONDARY UNIT PER RECEIPT DOES NOT EQUAL PRIMARY UNIT PER ISSUE **"
+11 QUIT ERROR
