source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPL.m@ 1719

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

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1PRCPOPL ;WISC/RFJ/DGL-distribution order processing list manager ; 3/20/00 9:27am
2V ;;5.1;IFCAP;**1,41**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 I "PS"'[PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY OR SECONDARY INVENTORY POINT." Q
6 ;
7 N %,ORDERDA,PRCPFNEW,PRCPFONE,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO,VA,X,Y
8 ;
9 I PRCP("DPTYPE")="S" S PRCPPRIM=+$$FROMCHEK^PRCPUDPT(PRCP("I"),1) Q:'PRCPPRIM S PRCPSECO=PRCP("I")
10 I PRCP("DPTYPE")="P" S PRCPSECO=+$$TO^PRCPUDPT(PRCP("I")) Q:'PRCPSECO S PRCPPRIM=PRCP("I")
11 W !!,"** Distribution ",$S(PRCP("DPTYPE")="S":"from",1:"to")_" inventory point: ",$$INVNAME^PRCPUX1($S(PRCP("DPTYPE")="S":PRCPPRIM,1:PRCPSECO))," **"
12 ;
13 F W !! S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"*",1) Q:'ORDERDA D
14 . W !
15 . L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) D R^PRCPUREP Q
16 . D ADD^PRCPULOC(445.3,ORDERDA,0,"Distribution Order Processing")
17 . I $$TYPE^PRCPOPUS(ORDERDA) D UNLOCK Q
18 . W ! I $$REMARKS^PRCPOPUS(ORDERDA) D UNLOCK Q
19 . D VARIABLE^PRCPOPU
20 . D EN^VALM("PRCP DIST ORDER PROCESSING")
21 . D UNLOCK
22 Q
23 ;
24 ;
25UNLOCK ; unlock distribution order
26 D CLEAR^PRCPULOC(445.3,ORDERDA,0)
27 L -^PRCP(445.3,ORDERDA)
28 Q
29 ;
30 ;
31HDR ; build header
32 K VALMHDR
33 I $P($G(PRCPORD(2)),"^")'="" S VALMHDR(1)=$E("POST ITEMS TO: "_$P(PRCPORD(2),"^")_$J(" ",80),1,47)_" THRU SECONDARY: "_$E($P(PRCPORD(0),"^",3),1,15)
34 I $P($G(PRCPORD(2)),"^")="" S VALMHDR(1)="POST ITEMS TO SECONDARY: "_$P(PRCPORD(0),"^",3)
35 S VALMHDR(2)=$E(" "_$E($P(PRCPORD(0),"^",2),1,15)_" DISTRIBUTION ORDER: "_$P(PRCPORD(0),"^")_$J(" ",50),1,49)_"STATUS: "_$$STATUS^PRCPOPU(ORDERDA)
36 Q
37 ;
38 ;
39INIT ; init variables and build array
40 N DATA,ITEMDA,ITEMDATA,QTYOH,STATUS
41 K ^TMP($J,"PRCPOP")
42 S VALMCNT=0
43 I $P(^PRCP(445.3,ORDERDA,0),"^",10)]"" D SET(" ***This Order was sent to the supply station and cannot be updated. ***"),SET(" ")
44 S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6)
45 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D
46 . D BLDARRAY(PRCPPRIM,PRCPSECO,ITEMDA,$P(DATA,"^",2),STATUS)
47 . S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),QTYOH=+$P($G(ITEMDATA),"^",7)
48 . I ITEMDATA="" D SET(" *** WARNING -- ITEM IS NO LONGER STOCKED IN PRIMARY INVENTORY POINT *** ") Q
49 . I STATUS'="P"&($P(DATA,"^",2)>QTYOH),QTYOH'<0 D
50 . . D SET(" *** WARNING -- QTY ORDERED ("_$P(DATA,"^",2)_") IS MORE THAN QTY ON HAND ("_QTYOH_") ***")
51 . . D SET(" *** Quantity on hand will be posted unless quantity ordered is edited ***")
52 . I STATUS'="P"&($P(DATA,"^",2)>QTYOH),QTYOH<0 D
53 . . D SET(" *** WARNING -- QTY ORDERED ("_$P(DATA,"^",2)_") IS MORE THAN QTY ON HAND ("_QTYOH_") ***")
54 . . D SET(" *** A quantity of ZERO(0) will be posted unless quantity ordered is edited ***")
55 . I STATUS="P"&($P(DATA,"^",2)'=$P(DATA,"^",7)) D SET(" *** Actual posted quantity was "_$P(DATA,"^",7)_" ***")
56 ;
57 I VALMCNT=0 D SET(" "),SET(" * * * NO ITEMS ARE ON THIS ORDER * * *")
58 Q
59 ;
60 ;
61BLDARRAY(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS) ; build item array
62 S:'$D(STATUS) STATUS=0
63 S X=$$SETFLD^VALM1(" "_$E($$DESCR^PRCPUX1(PRCPPRIM,ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
64 S X=$$SETFLD^VALM1($P($$UNIT^PRCPUX1(PRCPPRIM,ITEMDA,"^"),"^",2),X,"UNIT")
65 S X=$$SETFLD^VALM1(QTYORDER,X,"ORDERED")
66 S X=$$SETFLD^VALM1($P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4),X,"CONV")
67 I STATUS'="P" S X=$$SETFLD^VALM1($P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7),X,"ONHAND")
68 S VALMCNT=VALMCNT+1
69 D SET^VALM10(VALMCNT,X,VALMCNT)
70 Q
71 ;
72 ;
73EXIT ; exit and clean up
74 K ^TMP($J,"PRCPOP")
75 Q
76 ;
77 ;
78EEITEMS ; called from protocol file to enter/edit invpt items
79 N PRC,PRCP
80 S PRCP("DPTYPE")="PS"
81 D ^PRCPEILM
82 D INIT
83 S VALMBCK="R"
84 Q
85 ;
86 ;
87CHECK(TYPE) ; called when screen displays and when protocol selected
88 ; causes () to be display around inappropriate protocol selections
89 ; type="edit" or "delete" or "release" or "picktick" or "post"
90 ; returns 1 for sucess, 0 for no
91 I '$D(^PRCP(445.3,$G(ORDERDA),0)) Q 0
92 N STATUS,SECID
93 S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6) S:STATUS="B" STATUS="R"
94 S SECID=$P(^PRCP(445.3,ORDERDA,0),"^",3)
95 I TYPE="EDIT",PRCP("DPTYPE")="S",STATUS'="" Q 0
96 I TYPE'="DELETE",TYPE'="PICKTICK",TYPE'="SEND",$P(^PRCP(445.3,ORDERDA,0),"^",10)]"" Q 0
97 I TYPE="EDIT",STATUS="P" Q 0
98 I TYPE="DELETE",PRCP("DPTYPE")="S",STATUS'="" Q 0
99 I TYPE="DELETE",STATUS="P" Q 0
100 I TYPE="RELEASE",STATUS'="" Q 0
101 I TYPE="POST",PRCP("DPTYPE")="S" Q 0
102 I TYPE="POST",STATUS="" Q 0
103 ;I TYPE="POST",$P(^PRCP(445.3,ORDERDA,0),"^",7)="" Q 0
104 I TYPE="POST",STATUS="P" Q 0
105 I TYPE="PICKTICK",STATUS="P" Q 1
106 I TYPE="PICKTICK" I STATUS'="R" Q 0
107 I TYPE="SEND",$P(^PRCP(445.3,ORDERDA,0),"^",8)'="R" Q 0
108 I TYPE="SEND",$P($G(^PRCP(445,SECID,5)),"^",1)']"" Q 0
109 I TYPE="SEND",STATUS'="R" Q 0
110 Q 1
111 ;
112 ;
113SET(STRING) ; set string in array
114 N %
115 S VALMCNT=VALMCNT+1
116 D SET^VALM10(VALMCNT,STRING)
117 Q
Note: See TracBrowser for help on using the repository browser.