source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPP0.m@ 1639

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

initial load of WorldVistAEHR
File size: 3.3 KB
RevLine 
[613]1PRCPWPP0 ;WISC/RFJ,DWA-primary receive issue book (options) ;20 Jan 94
2 ;;5.1;IFCAP;**4**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7EEITEMS ; called from protocol file to enter/edit invpt items
8 D FULL^VALM1
9 D EN^PRCPEILM
10 D REBUILD^PRCPWPPB
11 S VALMBCK="R"
12 Q
13 ;
14 ;
15REMAIN ; set qty to receive to remaining (outstanding) qty
16 D FULL^VALM1
17 S VALMBCK="R"
18 N DATA,ITEMDA,LINEDA,QTY,X
19 K X S X(1)="This option will set the QUANTITY TO RECEIVE equal to the difference between the QUANTITY ORDERED and the QUANTITY PRIMARY REC'D."
20 D DISPLAY^PRCPUX2(5,75,.X)
21 S XP="Do you want to set the QUANTITY TO RECEIVE",XH="Enter YES to set the QUANTITY TO RECEIVE, NO or ^ to return to the list."
22 I $$YN^PRCPUYN(1)'=1 Q
23 S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPPLLIST",LINEDA)) Q:'LINEDA S DATA=^(LINEDA) D
24 . S ITEMDA=+$P(DATA,"^"),QTY=+$P(DATA,"^",2)
25 . I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) S QTY=0
26 . S ^TMP($J,"PRCPWPPLPOST",LINEDA)=QTY
27 D REBUILD^PRCPWPPB
28 S VALMSG="QTY TO RECEIVE now set to remaining"
29 Q
30 ;
31 ;
32ENTER ; enter quantity to post
33 D FULL^VALM1
34 S VALMBCK="R"
35 N DATA,DIR,ITEMDA,INVDATA,LINEDA,ONHAND,QTYOUT,QTYPST,QTYREC,STATUS,QUIT,X,Y
36 S QUIT=0
37 F W ! S LINEDA=$$LINEITEM Q:LINEDA<1 D
38 . S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I DATA="" W !,"CANNOT FIND LINE ITEM." Q
39 . S ITEMDA=+$P(DATA,"^",5),STATUS=$P(DATA,"^",14),INVDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0))
40 . I INVDATA="" W !,"ITEM (#",ITEMDA,") NOT STORED IN THE INVENTORY POINT." Q
41 . I STATUS'="" W !,"ITEM IS CANCELLED",$S(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$P(STATUS,",",2,99),1:"") Q
42 . S ONHAND=+$P(INVDATA,"^",7),QTYOUT=+$P($G(^TMP($J,"PRCPWPPLLIST",LINEDA)),"^",2),QTYPST=+$P($G(^TMP($J,"PRCPWPPLLIST",LINEDA)),"^",3)
43 . W !!,ITEMDA,?5,$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,30)," ",$$NSN^PRCPUX1(ITEMDA)," U/I: ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"/")
44 . W !?5,"AVERAGE COST : ",$J(+$P(INVDATA,"^",22),0,2)
45 . W !?5,"LAST COST : ",$J(+$P(INVDATA,"^",15),0,2)
46 . W !
47 . W !?5,"QTY ON-HAND : ",ONHAND
48 . W !?5,"QTY ORDERED : ",+$P(DATA,"^",2)
49 . W !?5,"QTY POSTED : ",+$P(DATA,"^",12)
50 . W !?5,"QTY RECEIVED : ",+$P(DATA,"^",13)
51 . W !?5,"QTY OUTSTANDING: ",QTYOUT
52 . W !?5,"QTY TO RECEIVE : ",+$G(^TMP($J,"PRCPWPPLPOST",LINEDA))
53 . S DIR(0)="NA^0:"_QTYPST_":0",DIR("A")=" QUANTITY TO RECEIVE: ",DIR("B")=QTYPST
54 . S DIR("A",1)="Enter the quantity of this item to receive from 0 to "_QTYPST_"."
55 . W ! D ^DIR K DIR
56 . I Y!(Y=0) S ^TMP($J,"PRCPWPPLPOST",LINEDA)=+Y
57 . K X S X(1)="QUANTITY TO RECEIVE: "_+$G(^TMP($J,"PRCPWPPLPOST",LINEDA)),QTYREC=$TR($P(X(1),":",2)," ")
58 . I QTYREC>QTYOUT D
59 . . W !!
60 . . W !,?15,"*****************WARNING*********************"
61 . . W !,?15,"** Quantity RECEIVED greater than ORDERED. **"
62 . . W !,?15,"** Is that what you want to do? **"
63 . . W !,?15,"*********************************************",!!
64 . . S DIR(0)="E" D ^DIR
65 . . I 'Y S QUIT=1 K QTYREC,X(1)
66 . . Q
67 . D:'QUIT DISPLAY^PRCPUX2(3,32,.X)
68 D:'QUIT REBUILD^PRCPWPPB
69 Q
70 ;
71 ;
72LINEITEM() ; select line item for issue book
73 N DA,DIC,X,Y
74 S DIC="^PRCS(410,"_PRCPDA_",""IT"",",DA(1)=PRCPDA,DIC(0)="QEAMZ",DIC("A")="Select LINE ITEM Number: "
75 S DIC("W")="S PRCPNODE=13 D DICW^PRCPWPL0 K PRCPNODE"
76 D ^DIC
77 Q +Y
Note: See TracBrowser for help on using the repository browser.