- PRCPCDIC ;WISC/RFJ-disassemble case cart ;01 Sep 93
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- I PRCP("DPTYPE")'="P" W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT." Q
- N %,CCITEM,DATA,ITEMDA,ITEMDATA,NOTINVPT,ORDERNO,PRCPCDIC,PRCPID,QUANTITY,TOTVAL,X,Y
- I $$CHECK^PRCPCUT1(PRCP("I")) Q
- S IOP="HOME" D ^%ZIS K IOP
- 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."
- 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."
- S X(3)="The disposable item quantity to return to stock equals the quantity used for the item during assembly of the case cart."
- 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."
- D DISPLAY^PRCPUX2(40,79,.X)
- DISASMBL ; disassemble case cart
- K NOTINVPT,ORDERNO,PRCPFLAG
- W ! S ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I")) I ITEMDA<1 Q
- S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- I ITEMDATA="" W !!,"Case Cart is not stored as an item in the inventory point." G DISASMBL
- I '$P(ITEMDATA,"^",7) W !!,"Case Cart has not been assembled (quantity on-hand is zero)." G DISASMBL
- W ! S QUANTITY=$$QUANTITY^PRCPCUT1($P(ITEMDATA,"^",7),"D") I 'QUANTITY G DISASMBL
- L +^PRCP(445.7,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.7,ITEMDA,0),EXIT G DISASMBL
- D ADD^PRCPULOC(445.7,ITEMDA,0,"Disassemble Case Cart")
- ;
- ; show items in cc
- D PRINT^PRCPCDIR(ITEMDA,QUANTITY)
- ; some items not in inventory point message
- I $G(NOTINVPT) D D EXIT G DISASMBL
- . 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."
- . D DISPLAY^PRCPUX2(20,60,.X)
- . D R^PRCPUREP
- ;
- ; no items to build list with
- I '$O(^TMP($J,"PRCPCDIR",0)) D D EXIT G DISASMBL
- . K X S X(1)="There are no items or defined quantities for disassembling the case cart."
- . D DISPLAY^PRCPUX2(20,60,.X)
- ;
- ; user entered '^' during list display
- I $G(PRCPFLAG) D D EXIT G DISASMBL
- . K X S X(1)="You must display the entire list of items for the case cart before you can disassemble it."
- . D DISPLAY^PRCPUX2(20,60,.X)
- S XP="ARE YOU SURE YOU WANT TO DISASSEMBLE THIS CASE CART",XH="Enter 'YES' to disassemble the case cart, 'NO' or '^' to exit."
- W ! I $$YN^PRCPUYN(2)'=1 D EXIT G DISASMBL
- ;
- S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
- S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCDIR",CCITEM)) Q:'CCITEM S DATA=^(CCITEM) D
- . K PRCPCDIC S PRCPCDIC("QTY")=$P(DATA,"^"),PRCPCDIC("INVVAL")=$J($P(DATA,"^",2),0,2),PRCPCDIC("REASON")="0:Disassembled Case Cart"
- . D ITEM^PRCPUUIP(PRCP("I"),CCITEM,"S",ORDERNO,.PRCPCDIC)
- ;
- ; decrement case cart item
- S ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0),TOTVAL=$J(QUANTITY*$P(ITEMDATA,"^",22),0,2)
- I $P(ITEMDATA,"^",7)=QUANTITY S TOTVAL=$P(ITEMDATA,"^",27) K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
- K PRCPCDIC S PRCPCDIC("QTY")=-QUANTITY,PRCPCDIC("INVVAL")=-TOTVAL,PRCPCDIC("REASON")="0:Disassembled Case Cart"
- D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIC)
- D EXIT G DISASMBL
- ;
- EXIT ; exit, unlock, clean up
- D CLEAR^PRCPULOC(445.7,ITEMDA,0)
- L -^PRCP(445.7,ITEMDA)
- K ^TMP($J,"PRCPCDIR")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCDIC 3575 printed Feb 18, 2025@23:39:29 Page 2
- PRCPCDIC ;WISC/RFJ-disassemble case cart ;01 Sep 93
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +4 IF PRCP("DPTYPE")'="P"
- WRITE !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT."
- QUIT
- +5 NEW %,CCITEM,DATA,ITEMDA,ITEMDATA,NOTINVPT,ORDERNO,PRCPCDIC,PRCPID,QUANTITY,TOTVAL,X,Y
- +6 IF $$CHECK^PRCPCUT1(PRCP("I"))
- QUIT
- +7 SET IOP="HOME"
- DO ^%ZIS
- KILL IOP
- +8 KILL X
- SET X(1)="The Disassemble Case Cart option will break down the case cart and return the individual disposable items back to stock."
- +9 SET 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."
- +10 SET X(3)="The disposable item quantity to return to stock equals the quantity used for the item during assembly of the case cart."
- +11 SET 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."
- +12 DO DISPLAY^PRCPUX2(40,79,.X)
- DISASMBL ; disassemble case cart
- +1 KILL NOTINVPT,ORDERNO,PRCPFLAG
- +2 WRITE !
- SET ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I"))
- IF ITEMDA<1
- QUIT
- +3 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- +4 IF ITEMDATA=""
- WRITE !!,"Case Cart is not stored as an item in the inventory point."
- GOTO DISASMBL
- +5 IF '$PIECE(ITEMDATA,"^",7)
- WRITE !!,"Case Cart has not been assembled (quantity on-hand is zero)."
- GOTO DISASMBL
- +6 WRITE !
- SET QUANTITY=$$QUANTITY^PRCPCUT1($PIECE(ITEMDATA,"^",7),"D")
- IF 'QUANTITY
- GOTO DISASMBL
- +7 LOCK +^PRCP(445.7,ITEMDA):5
- IF '$TEST
- DO SHOWWHO^PRCPULOC(445.7,ITEMDA,0)
- DO EXIT
- GOTO DISASMBL
- +8 DO ADD^PRCPULOC(445.7,ITEMDA,0,"Disassemble Case Cart")
- +9 ;
- +10 ; show items in cc
- +11 DO PRINT^PRCPCDIR(ITEMDA,QUANTITY)
- +12 ; some items not in inventory point message
- +13 IF $GET(NOTINVPT)
- Begin DoDot:1
- +14 KILL X
- SET X(1)="WARNING -- Before disassembling a case cart, all items used to build the case cart must be contained in the inventory point."
- +15 DO DISPLAY^PRCPUX2(20,60,.X)
- +16 DO R^PRCPUREP
- End DoDot:1
- DO EXIT
- GOTO DISASMBL
- +17 ;
- +18 ; no items to build list with
- +19 IF '$ORDER(^TMP($JOB,"PRCPCDIR",0))
- Begin DoDot:1
- +20 KILL X
- SET X(1)="There are no items or defined quantities for disassembling the case cart."
- +21 DO DISPLAY^PRCPUX2(20,60,.X)
- End DoDot:1
- DO EXIT
- GOTO DISASMBL
- +22 ;
- +23 ; user entered '^' during list display
- +24 IF $GET(PRCPFLAG)
- Begin DoDot:1
- +25 KILL X
- SET X(1)="You must display the entire list of items for the case cart before you can disassemble it."
- +26 DO DISPLAY^PRCPUX2(20,60,.X)
- End DoDot:1
- DO EXIT
- GOTO DISASMBL
- +27 SET XP="ARE YOU SURE YOU WANT TO DISASSEMBLE THIS CASE CART"
- SET XH="Enter 'YES' to disassemble the case cart, 'NO' or '^' to exit."
- +28 WRITE !
- IF $$YN^PRCPUYN(2)'=1
- DO EXIT
- GOTO DISASMBL
- +29 ;
- +30 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
- +31 SET CCITEM=0
- FOR
- SET CCITEM=$ORDER(^TMP($JOB,"PRCPCDIR",CCITEM))
- if 'CCITEM
- QUIT
- SET DATA=^(CCITEM)
- Begin DoDot:1
- +32 KILL PRCPCDIC
- SET PRCPCDIC("QTY")=$PIECE(DATA,"^")
- SET PRCPCDIC("INVVAL")=$JUSTIFY($PIECE(DATA,"^",2),0,2)
- SET PRCPCDIC("REASON")="0:Disassembled Case Cart"
- +33 DO ITEM^PRCPUUIP(PRCP("I"),CCITEM,"S",ORDERNO,.PRCPCDIC)
- End DoDot:1
- +34 ;
- +35 ; decrement case cart item
- +36 SET ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0)
- SET TOTVAL=$JUSTIFY(QUANTITY*$PIECE(ITEMDATA,"^",22),0,2)
- +37 IF $PIECE(ITEMDATA,"^",7)=QUANTITY
- SET TOTVAL=$PIECE(ITEMDATA,"^",27)
- KILL ^PRCP(445,PRCP("I"),1,ITEMDA,8)
- +38 KILL PRCPCDIC
- SET PRCPCDIC("QTY")=-QUANTITY
- SET PRCPCDIC("INVVAL")=-TOTVAL
- SET PRCPCDIC("REASON")="0:Disassembled Case Cart"
- +39 DO ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIC)
- +40 DO EXIT
- GOTO DISASMBL
- +41 ;
- EXIT ; exit, unlock, clean up
- +1 DO CLEAR^PRCPULOC(445.7,ITEMDA,0)
- +2 LOCK -^PRCP(445.7,ITEMDA)
- +3 KILL ^TMP($JOB,"PRCPCDIR")
- +4 QUIT