source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPER.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1PRCPOPER ;WISC/RFJ/DGL-distribution order error report; ; 3/17/00 3:23pm
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7CHECKORD ; 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 ;
15INIT ; 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 ;
41EXIT ; exit and clean up
42 K ^TMP($J,"PRCPOPER")
43 Q
44 ;
45 ;
46EEITEMS ; 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 ;
57ITEMCHK(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
Note: See TracBrowser for help on using the repository browser.