| 1 | PRCPCDIK ;WISC/RFJ-disassemble 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,ITEMDATA,NOTINVPT,ORDERNO,PRCPCDIK,PRCPID,QUANTITY,TOTVAL,X,Y
|
---|
| 7 | I $$CHECK^PRCPCUT1(PRCP("I")) Q
|
---|
| 8 | S IOP="HOME" D ^%ZIS K IOP
|
---|
| 9 | K X S X(1)="The Disassemble Instrument Kit option will break down the instrument kit and return the individual disposable items back to stock."
|
---|
| 10 | S X(2)="When a instrument kit is disassembled, the quantity on-hand for the instrument kit will be decremented and the quantity on-hand for the disposable items will be incremented. The quantity on-hand for reusable items will not change."
|
---|
| 11 | S X(3)="The disposable item quantity to return to stock equals the quantity used for the item during assembly of the instrument kit."
|
---|
| 12 | S X(4)="This quantity may be different from the instrument kit definition quantity since the instrument kit definition may have been altered after the instrument kit was assembled."
|
---|
| 13 | D DISPLAY^PRCPUX2(40,79,.X)
|
---|
| 14 | DISASMBL ; disassemble instrument kit
|
---|
| 15 | K NOTINVPT,ORDERNO,PRCPFLAG
|
---|
| 16 | W ! S ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I")) I ITEMDA<1 Q
|
---|
| 17 | S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
|
---|
| 18 | I ITEMDATA="" W !!,"Instrument Kit is not stored as an item in the inventory point." G DISASMBL
|
---|
| 19 | I '$P(ITEMDATA,"^",7) W !!,"Instrument Kit has not been assembled (quantity on-hand is zero)." G DISASMBL
|
---|
| 20 | W ! S QUANTITY=$$QUANTITY^PRCPCUT1($P(ITEMDATA,"^",7),"D") I 'QUANTITY G DISASMBL
|
---|
| 21 | L +^PRCP(445.8,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.8,ITEMDA,0),EXIT G DISASMBL
|
---|
| 22 | D ADD^PRCPULOC(445.8,ITEMDA,0,"Disassemble Instrument Kit")
|
---|
| 23 | ;
|
---|
| 24 | ; show items in ik
|
---|
| 25 | D PRINT^PRCPCDIR(ITEMDA,QUANTITY)
|
---|
| 26 | ; some items not in inventory point message
|
---|
| 27 | I $G(NOTINVPT) D D EXIT G DISASMBL
|
---|
| 28 | . K X S X(1)="WARNING -- Before disassembling 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 | ; no items to build list with
|
---|
| 33 | I '$O(^TMP($J,"PRCPCDIR",0)) D D EXIT G DISASMBL
|
---|
| 34 | . K X S X(1)="There are no items or defined quantities for disassembling the instrument kit."
|
---|
| 35 | . D DISPLAY^PRCPUX2(20,60,.X)
|
---|
| 36 | . K X S X(1)="Disassembling Instrument Kit" D DISPLAY^PRCPUX2(1,79,.X)
|
---|
| 37 | . ; decrement instrument kit item
|
---|
| 38 | . S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
|
---|
| 39 | . S ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0),TOTVAL=$J(QUANTITY*$P(ITEMDATA,"^",22),0,2)
|
---|
| 40 | . K PRCPCDIK S PRCPCDIK("QTY")=-QUANTITY,PRCPCDIK("INVVAL")=-TOTVAL,PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
|
---|
| 41 | . D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIK)
|
---|
| 42 | ;
|
---|
| 43 | ; user entered '^' during list display
|
---|
| 44 | I $G(PRCPFLAG) D D EXIT G DISASMBL
|
---|
| 45 | . K X S X(1)="You must display the entire list of items for the instrument kit before you can disassemble it."
|
---|
| 46 | . D DISPLAY^PRCPUX2(20,60,.X)
|
---|
| 47 | S XP="ARE YOU SURE YOU WANT TO DISASSEMBLE THIS INSTRUMENT KIT",XH="Enter 'YES' to disassemble the instrument kit, 'NO' or '^' to exit."
|
---|
| 48 | W ! I $$YN^PRCPUYN(2)'=1 D EXIT G DISASMBL
|
---|
| 49 | ;
|
---|
| 50 | S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
|
---|
| 51 | S IKITEM=0 F S IKITEM=$O(^TMP($J,"PRCPCDIR",IKITEM)) Q:'IKITEM S DATA=^(IKITEM) D
|
---|
| 52 | . K PRCPCDIK S PRCPCDIK("QTY")=$P(DATA,"^"),PRCPCDIK("INVVAL")=$J($P(DATA,"^",2),0,2),PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
|
---|
| 53 | . D ITEM^PRCPUUIP(PRCP("I"),IKITEM,"S",ORDERNO,.PRCPCDIK)
|
---|
| 54 | ;
|
---|
| 55 | ; decrement instrument kit item
|
---|
| 56 | S ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0),TOTVAL=$J(QUANTITY*$P(ITEMDATA,"^",22),0,2)
|
---|
| 57 | ; do not remove node 8 since other ccs may contain the ik
|
---|
| 58 | ;I $P(ITEMDATA,"^",7)=QUANTITY S TOTVAL=$P(ITEMDATA,"^",27) K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
|
---|
| 59 | K PRCPCDIK S PRCPCDIK("QTY")=-QUANTITY,PRCPCDIK("INVVAL")=-TOTVAL,PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
|
---|
| 60 | D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIK)
|
---|
| 61 | D EXIT G DISASMBL
|
---|
| 62 | ;
|
---|
| 63 | EXIT ; exit, unlock, clean up
|
---|
| 64 | D CLEAR^PRCPULOC(445.8,ITEMDA,0)
|
---|
| 65 | L -^PRCP(445.8,ITEMDA)
|
---|
| 66 | K ^TMP($J,"PRCPCDIR")
|
---|
| 67 | Q
|
---|