| 1 | PRCPOPER ;WISC/RFJ/DGL-distribution order error report; ; 3/17/00 3:23pm
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | CHECKORD ; check order for errors (called from prcpopl protocol)
|
|---|
| 8 | D VARIABLE^PRCPOPU
|
|---|
| 9 | D EN^VALM("PRCP DIST ORDER CHECK ITEMS")
|
|---|
| 10 | D INIT^PRCPOPL
|
|---|
| 11 | S VALMBCK="R"
|
|---|
| 12 | Q
|
|---|
| 13 | ;
|
|---|
| 14 | ;
|
|---|
| 15 | INIT ; check order for errors and build array
|
|---|
| 16 | N DATA,ERROR,ITEMDA,QTYORDER,STATUS,QTYOH
|
|---|
| 17 | K ^TMP($J,"PRCPOPER")
|
|---|
| 18 | S VALMCNT=0
|
|---|
| 19 | I 'PRCPPRIM D SET^PRCPOPL("PRIMARY INVENTORY SOURCE MISSING. PLEASE RE-EDIT THE ORDER FIRST.") Q
|
|---|
| 20 | I 'PRCPSECO D SET^PRCPOPL("SECONDARY INVENTORY POINT IS MISSING, PLEASE RE-EDIT THE ORDER FIRST.") Q
|
|---|
| 21 | ;
|
|---|
| 22 | S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6)
|
|---|
| 23 | ; check items on order
|
|---|
| 24 | S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA,0) D
|
|---|
| 25 | . S QTYORDER=$P(DATA,"^",2)
|
|---|
| 26 | . I 'QTYORDER D BLDARRAY^PRCPOPL,SET^PRCPOPL(" ** THERE IS NO QUANTITY ORDERED, ITEM SHOULD BE DELETED FROM ORDER **") Q
|
|---|
| 27 | . S ERROR=$$ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA)
|
|---|
| 28 | . S X=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
|
|---|
| 29 | . I X]"" D
|
|---|
| 30 | . . S QTYOH=+$P(X,"^",7)
|
|---|
| 31 | . . I PRCP("DPTYPE")'="S",QTYOH<QTYORDER S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** QTY ORDERED ("_QTYORDER_") IS MORE THAN PRIMARY QTY ON HAND ("_QTYOH_") **"
|
|---|
| 32 | . . Q
|
|---|
| 33 | . I ERROR="" Q
|
|---|
| 34 | . D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
|
|---|
| 35 | . F %=1:1 Q:$P(ERROR,"^",%,99)="" I $P(ERROR,"^",%)'="" D SET^PRCPOPL($P(ERROR,"^",%))
|
|---|
| 36 | ;
|
|---|
| 37 | I VALMCNT=0 S VALMQUIT=1,VALMSG="* * * NO ERRORS FOUND * * *"
|
|---|
| 38 | Q
|
|---|
| 39 | ;
|
|---|
| 40 | ;
|
|---|
| 41 | EXIT ; exit and clean up
|
|---|
| 42 | K ^TMP($J,"PRCPOPER")
|
|---|
| 43 | Q
|
|---|
| 44 | ;
|
|---|
| 45 | ;
|
|---|
| 46 | EEITEMS ; called from protocol file to enter/edit invpt items
|
|---|
| 47 | D
|
|---|
| 48 | . N PRC,PRCP
|
|---|
| 49 | . S PRCP("DPTYPE")="PS"
|
|---|
| 50 | . D ^PRCPEILM
|
|---|
| 51 | D INIT
|
|---|
| 52 | S VALMBCK="R"
|
|---|
| 53 | I $G(VALMQUIT) K VALMBCK
|
|---|
| 54 | Q
|
|---|
| 55 | ;
|
|---|
| 56 | ;
|
|---|
| 57 | ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA) ; check items
|
|---|
| 58 | ; returns errors delimited by ^ or ""
|
|---|
| 59 | N ITEMDATA,ERROR,VDATA
|
|---|
| 60 | S ERROR=""
|
|---|
| 61 | S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
|
|---|
| 62 | I ITEMDATA="" S ERROR=" ** ITEM NOT STORED IN PRIMARY INVENTORY POINT ** ^ Either add item to primary or delete item from order."
|
|---|
| 63 | I '$D(^PRCP(445,PRCPSECO,1,ITEMDA,0)) S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** ITEM NOT STORED IN SECONDARY INVENTORY POINT **"
|
|---|
| 64 | ;
|
|---|
| 65 | S VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1)
|
|---|
| 66 | I 'VDATA S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** PRIMARY INVENTORY POINT IS NOT LISTED AS A SOURCE **"
|
|---|
| 67 | 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 **"
|
|---|
| 68 | Q ERROR
|
|---|
