source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCASK.m@ 691

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1PRCPCASK ;WISC/RFJ-assemble instrument kit ;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 %,IKITEM,DATA,ITEMDA,NEGATIVE,NOTINVPT,ORDERNO,PRCPCASK,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 Instrument Kit option will build the selected instrument kit by the instrument kit definition. The instrument kit definition describes the items and quantities which are used in building the instrument kit."
10 S X(2)="If a instrument kit has previously been built by the inventory point and the definition has been altered, the previously built instrument kit will have to be disassembled first."
11 D DISPLAY^PRCPUX2(40,79,.X)
12ASSEMBLE ; assemble instrument kit
13 K NEGATIVE,NOTINVPT,ORDERNO,PRCPFLAG
14 W ! S ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I")) I ITEMDA<1 Q
15 I '$D(^PRCP(445,PRCP("I"),1,ITEMDA,0)) W !!,"Instrument Kit 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.8,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.8,ITEMDA,0),EXIT G ASSEMBLE
18 D ADD^PRCPULOC(445.8,ITEMDA,0,"Assemble Intrument Kit")
19 D GETDEF^PRCPCUT1(445.8,ITEMDA)
20 ;I '$O(^TMP($J,"PRCPLIST-DISP",0)) W !!,"No Disposable Items Stored in Instrument Kit." D EXIT G ASSEMBLE
21 ;
22 I $P($G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),"^",7) D CHECK^PRCPCASR("I") I $G(PRCPFLAG) D EXIT G ASSEMBLE
23 ;
24 ; show items in ik
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 instrument kit, all items used to build the instrument kit 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 instrument kit, some of the items contained within the instrument kit 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 instrument kit."
40 . D DISPLAY^PRCPUX2(20,60,.X)
41 . K X S X(1)="Assembling Instrument Kit" D DISPLAY^PRCPUX2(1,79,.X)
42 . ; increment ik qty
43 . S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
44 . K PRCPCASK S PRCPCASK("QTY")=QUANTITY,PRCPCASK("INVVAL")=0,PRCPCASK("REASON")="0:Assembled Instrument Kit"
45 . D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASK)
46 ;
47 ; user entered '^' during list display
48 I $G(PRCPFLAG) D D EXIT G ASSEMBLE
49 . K X S X(1)="You must display the entire list of items for the instrument kit before you can assemble it."
50 . D DISPLAY^PRCPUX2(20,60,.X)
51 S XP="ARE YOU SURE YOU WANT TO ASSEMBLE THIS INSTRUMENT KIT",XH="Enter 'YES' to assemble the instrument kit, 'NO' or '^' to exit."
52 W ! I $$YN^PRCPUYN(2)'=1 D EXIT G ASSEMBLE
53 ;
54 ; reset instrument kit items in inventory point
55 K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
56 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
57 S IKITEM=0 F S IKITEM=$O(^TMP($J,"PRCPCASR",IKITEM)) Q:'IKITEM S DATA=^(IKITEM) D
58 . K PRCPCASK S PRCPCASK("QTY")=-$P(DATA,"^"),PRCPCASK("INVVAL")=-$J($P(DATA,"^",2),0,2),PRCPCASK("REASON")="0:Assembled Instrument Kit"
59 . D ITEM^PRCPUUIP(PRCP("I"),IKITEM,"S",ORDERNO,.PRCPCASK)
60 . ;
61 . ; add item to instrument kit in inventory point
62 . D ADDCCIK^PRCPCUT1(PRCP("I"),ITEMDA,IKITEM,^TMP($J,"PRCPLIST",IKITEM))
63 ;
64 ; increment instrument kit item
65 K PRCPCASK S PRCPCASK("QTY")=QUANTITY,PRCPCASK("INVVAL")=$J(QUANTITY*$P($G(^PRCP(445.8,ITEMDA,0)),"^",9),0,2),PRCPCASK("REASON")="0:Assembled Instrument Kit"
66 D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASK)
67 D EXIT G ASSEMBLE
68 ;
69EXIT ; exit, unlock, clean up
70 D CLEAR^PRCPULOC(445.8,ITEMDA,0)
71 L -^PRCP(445.8,ITEMDA)
72 K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP"),^TMP($J,"PRCPCASR")
73 Q
Note: See TracBrowser for help on using the repository browser.