Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPCDIC

PRCPCDIC.m

Go to the documentation of this file.
  1. PRCPCDIC ;WISC/RFJ-disassemble case cart ;01 Sep 93
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. I PRCP("DPTYPE")'="P" W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT." Q
  1. N %,CCITEM,DATA,ITEMDA,ITEMDATA,NOTINVPT,ORDERNO,PRCPCDIC,PRCPID,QUANTITY,TOTVAL,X,Y
  1. I $$CHECK^PRCPCUT1(PRCP("I")) Q
  1. S IOP="HOME" D ^%ZIS K IOP
  1. K X S X(1)="The Disassemble Case Cart option will break down the case cart and return the individual disposable items back to stock."
  1. S X(2)="When a case cart is disassembled, the quantity on-hand for the case cart 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."
  1. S X(3)="The disposable item quantity to return to stock equals the quantity used for the item during assembly of the case cart."
  1. S X(4)="This quantity may be different from the case cart definition quantity since the case cart definition may have been altered after the case cart was assembled."
  1. D DISPLAY^PRCPUX2(40,79,.X)
  1. DISASMBL ; disassemble case cart
  1. K NOTINVPT,ORDERNO,PRCPFLAG
  1. W ! S ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I")) I ITEMDA<1 Q
  1. S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
  1. I ITEMDATA="" W !!,"Case Cart is not stored as an item in the inventory point." G DISASMBL
  1. I '$P(ITEMDATA,"^",7) W !!,"Case Cart has not been assembled (quantity on-hand is zero)." G DISASMBL
  1. W ! S QUANTITY=$$QUANTITY^PRCPCUT1($P(ITEMDATA,"^",7),"D") I 'QUANTITY G DISASMBL
  1. L +^PRCP(445.7,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.7,ITEMDA,0),EXIT G DISASMBL
  1. D ADD^PRCPULOC(445.7,ITEMDA,0,"Disassemble Case Cart")
  1. ;
  1. ; show items in cc
  1. D PRINT^PRCPCDIR(ITEMDA,QUANTITY)
  1. ; some items not in inventory point message
  1. I $G(NOTINVPT) D D EXIT G DISASMBL
  1. . K X S X(1)="WARNING -- Before disassembling a case cart, all items used to build the case cart must be contained in the inventory point."
  1. . D DISPLAY^PRCPUX2(20,60,.X)
  1. . D R^PRCPUREP
  1. ;
  1. ; no items to build list with
  1. I '$O(^TMP($J,"PRCPCDIR",0)) D D EXIT G DISASMBL
  1. . K X S X(1)="There are no items or defined quantities for disassembling the case cart."
  1. . D DISPLAY^PRCPUX2(20,60,.X)
  1. ;
  1. ; user entered '^' during list display
  1. I $G(PRCPFLAG) D D EXIT G DISASMBL
  1. . K X S X(1)="You must display the entire list of items for the case cart before you can disassemble it."
  1. . D DISPLAY^PRCPUX2(20,60,.X)
  1. S XP="ARE YOU SURE YOU WANT TO DISASSEMBLE THIS CASE CART",XH="Enter 'YES' to disassemble the case cart, 'NO' or '^' to exit."
  1. W ! I $$YN^PRCPUYN(2)'=1 D EXIT G DISASMBL
  1. ;
  1. S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
  1. S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCDIR",CCITEM)) Q:'CCITEM S DATA=^(CCITEM) D
  1. . K PRCPCDIC S PRCPCDIC("QTY")=$P(DATA,"^"),PRCPCDIC("INVVAL")=$J($P(DATA,"^",2),0,2),PRCPCDIC("REASON")="0:Disassembled Case Cart"
  1. . D ITEM^PRCPUUIP(PRCP("I"),CCITEM,"S",ORDERNO,.PRCPCDIC)
  1. ;
  1. ; decrement case cart item
  1. S ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0),TOTVAL=$J(QUANTITY*$P(ITEMDATA,"^",22),0,2)
  1. I $P(ITEMDATA,"^",7)=QUANTITY S TOTVAL=$P(ITEMDATA,"^",27) K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
  1. K PRCPCDIC S PRCPCDIC("QTY")=-QUANTITY,PRCPCDIC("INVVAL")=-TOTVAL,PRCPCDIC("REASON")="0:Disassembled Case Cart"
  1. D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIC)
  1. D EXIT G DISASMBL
  1. ;
  1. EXIT ; exit, unlock, clean up
  1. D CLEAR^PRCPULOC(445.7,ITEMDA,0)
  1. L -^PRCP(445.7,ITEMDA)
  1. K ^TMP($J,"PRCPCDIR")
  1. Q