source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCASC.m@ 1314

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

initial load of FOIAVistA 6/30/08 version
File size: 3.6 KB
Line 
1PRCPCASC ;WISC/RFJ-assemble case cart ;01 Sep 93
2 ;;5.1;IFCAP;;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 PRCP("DPTYPE")'="P" W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT." Q
6 N %,CCITEM,DATA,ITEMDA,NEGATIVE,NOTINVPT,ORDERNO,PRCPCASC,PRCPID,PRCPITEM,QUANTITY,X,Y
7 I $$CHECK^PRCPCUT1(PRCP("I")) Q
8 S IOP="HOME" D ^%ZIS K IOP
9 K X S X(1)="The Assemble Case Cart option will build the selected case cart by the case cart definition. The case cart definition describes the items and quantities which are used in building the case cart."
10 S X(2)="If a case cart has previously been built by the inventory point and the definition has been altered, the previously built case cart will have to be disassembled first."
11 D DISPLAY^PRCPUX2(40,79,.X)
12ASSEMBLE ; assemble case cart
13 K NEGATIVE,NOTINVPT,ORDERNO,PRCPFLAG
14 W ! S ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I")) I ITEMDA<1 Q
15 I '$D(^PRCP(445,PRCP("I"),1,ITEMDA,0)) W !!,"Case Cart is not stored as an item in the inventory point." G ASSEMBLE
16 W ! S QUANTITY=$$QUANTITY^PRCPCUT1(99,"A") I 'QUANTITY G ASSEMBLE
17 L +^PRCP(445.7,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.7,ITEMDA,0),EXIT G ASSEMBLE
18 D ADD^PRCPULOC(445.7,ITEMDA,0,"Assemble Case Cart")
19 D GETDEF^PRCPCUT1(445.7,ITEMDA)
20 I '$O(^TMP($J,"PRCPLIST-DISP",0)) W !!,"No Disposable Items Stored in Case Cart." D EXIT G ASSEMBLE
21 ;
22 I $P($G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),"^",7) D CHECK^PRCPCASR("C") I $G(PRCPFLAG) D EXIT G ASSEMBLE
23 ;
24 ; show items in cc
25 D PRINT^PRCPCASR(QUANTITY)
26 ; some items not in inventory point message
27 I $G(NOTINVPT) D D EXIT G ASSEMBLE
28 . K X S X(1)="WARNING -- Before assembling a case cart, all items used to build the case cart must be contained in the inventory point."
29 . D DISPLAY^PRCPUX2(20,60,.X)
30 . D R^PRCPUREP
31 ;
32 ; some items have new quantities less than zero
33 I $G(NEGATIVE) D
34 . K X S X(1)="WARNING -- After assembling the case cart, some of the items contained within the case cart will have a quantity on-hand less than zero."
35 . D DISPLAY^PRCPUX2(20,60,.X)
36 ;
37 ; no disposable items to build list with
38 I '$O(^TMP($J,"PRCPCASR",0)) D D EXIT G ASSEMBLE
39 . K X S X(1)="There are no disposable items or defined quantities for building the case cart."
40 . D DISPLAY^PRCPUX2(20,60,.X)
41 ;
42 ; user entered '^' during list display
43 I $G(PRCPFLAG) D D EXIT G ASSEMBLE
44 . K X S X(1)="You must display the entire list of items for the case cart before you can assemble it."
45 . D DISPLAY^PRCPUX2(20,60,.X)
46 S XP="ARE YOU SURE YOU WANT TO ASSEMBLE THIS CASE CART",XH="Enter 'YES' to assemble the case cart, 'NO' or '^' to exit."
47 W ! I $$YN^PRCPUYN(2)'=1 D EXIT G ASSEMBLE
48 ;
49 ; reset case cart items in inventory point
50 K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
51 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
52 S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCASR",CCITEM)) Q:'CCITEM S DATA=^(CCITEM) D
53 . K PRCPCASC S PRCPCASC("QTY")=-$P(DATA,"^"),PRCPCASC("INVVAL")=-$J($P(DATA,"^",2),0,2),PRCPCASC("REASON")="0:Assembled Case Cart"
54 . D ITEM^PRCPUUIP(PRCP("I"),CCITEM,"S",ORDERNO,.PRCPCASC)
55 . ;
56 . ; add item to case cart in inventory point
57 . D ADDCCIK^PRCPCUT1(PRCP("I"),ITEMDA,CCITEM,^TMP($J,"PRCPLIST",CCITEM))
58 ;
59 ; increment case cart item
60 K PRCPCASC S PRCPCASC("QTY")=QUANTITY,PRCPCASC("INVVAL")=$J(QUANTITY*$P($G(^PRCP(445.7,ITEMDA,0)),"^",7),0,2),PRCPCASC("REASON")="0:Assembled Case Cart"
61 D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASC)
62 D EXIT G ASSEMBLE
63 ;
64EXIT ; exit, unlock, clean up
65 D CLEAR^PRCPULOC(445.7,ITEMDA,0)
66 L -^PRCP(445.7,ITEMDA)
67 K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP"),^TMP($J,"PRCPCASR")
68 Q
Note: See TracBrowser for help on using the repository browser.