PRCPOPEC ;WISC/RFJ-distribution order error report for cc,ik items ;27 Sep 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
INIT ; check order for errors and build array
N DATA,ITEMDA,QTYORDER
K ^TMP($J,"PRCPOPER")
S VALMCNT=0
S CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM D
. S QTYORDER=$P($G(^PRCP(445.3,ORDERDA,1,CCIKITEM,0)),"^",2)
. D SETERROR(CCIKITEM)
. ; check items to post
. S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA S QTYORDER=$P(^(ITEMDA),"^")-$P(^(ITEMDA),"^",2) I QTYORDER D
. . ; do not check cc/ik items twice
. . I $D(^TMP($J,"PRCPOPPC-ITEMS",ITEMDA)) Q
. . D SETERROR(ITEMDA)
;
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
N PRC,PRCP
S PRCP("DPTYPE")="PS"
D ^PRCPEILM
D INIT
S VALMBCK="R"
I $G(VALMQUIT) K VALMBCK
Q
;
;
SETERROR(ITEMDA) ; set error in list for itemda
N ERROR
S ERROR=$$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)
I $P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)<QTYORDER S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** PRIMARY QUANTITY ON-HAND LESS THAN QUANTITY ON ORDER **"
I ERROR="" Q
D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER)
F %=1:1 Q:$P(ERROR,"^",%,99)="" I $P(ERROR,"^",%)'="" D SET^PRCPOPL($P(ERROR,"^",%))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPEC 1541 printed Oct 16, 2024@18:14:55 Page 2
PRCPOPEC ;WISC/RFJ-distribution order error report for cc,ik items ;27 Sep 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
INIT ; check order for errors and build array
+1 NEW DATA,ITEMDA,QTYORDER
+2 KILL ^TMP($JOB,"PRCPOPER")
+3 SET VALMCNT=0
+4 SET CCIKITEM=0
FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM))
if 'CCIKITEM
QUIT
Begin DoDot:1
+5 SET QTYORDER=$PIECE($GET(^PRCP(445.3,ORDERDA,1,CCIKITEM,0)),"^",2)
+6 DO SETERROR(CCIKITEM)
+7 ; check items to post
+8 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
if 'ITEMDA
QUIT
SET QTYORDER=$PIECE(^(ITEMDA),"^")-$PIECE(^(ITEMDA),"^",2)
IF QTYORDER
Begin DoDot:2
+9 ; do not check cc/ik items twice
+10 IF $DATA(^TMP($JOB,"PRCPOPPC-ITEMS",ITEMDA))
QUIT
+11 DO SETERROR(ITEMDA)
End DoDot:2
End DoDot:1
+12 ;
+13 IF VALMCNT=0
SET VALMQUIT=1
SET VALMSG="* * * NO ERRORS FOUND * * *"
+14 QUIT
+15 ;
+16 ;
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 NEW PRC,PRCP
+2 SET PRCP("DPTYPE")="PS"
+3 DO ^PRCPEILM
+4 DO INIT
+5 SET VALMBCK="R"
+6 IF $GET(VALMQUIT)
KILL VALMBCK
+7 QUIT
+8 ;
+9 ;
SETERROR(ITEMDA) ; set error in list for itemda
+1 NEW ERROR
+2 SET ERROR=$$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)
+3 IF $PIECE($GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)<QTYORDER
SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** PRIMARY QUANTITY ON-HAND LESS THAN QUANTITY ON ORDER **"
+4 IF ERROR=""
QUIT
+5 DO BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER)
+6 FOR %=1:1
if $PIECE(ERROR,"^",%,99)=""
QUIT
IF $PIECE(ERROR,"^",%)'=""
DO SET^PRCPOPL($PIECE(ERROR,"^",%))
+7 QUIT
