PRCPCDIK ;WISC/RFJ-disassemble instrument kit ;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 %,IKITEM,DATA,ITEMDA,ITEMDATA,NOTINVPT,ORDERNO,PRCPCDIK,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 Instrument Kit option will break down the instrument kit and return the individual disposable items back to stock."
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."
S X(3)="The disposable item quantity to return to stock equals the quantity used for the item during assembly of the instrument kit."
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."
D DISPLAY^PRCPUX2(40,79,.X)
DISASMBL ; disassemble instrument kit
K NOTINVPT,ORDERNO,PRCPFLAG
W ! S ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I")) I ITEMDA<1 Q
S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
I ITEMDATA="" W !!,"Instrument Kit is not stored as an item in the inventory point." G DISASMBL
I '$P(ITEMDATA,"^",7) W !!,"Instrument Kit 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.8,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.8,ITEMDA,0),EXIT G DISASMBL
D ADD^PRCPULOC(445.8,ITEMDA,0,"Disassemble Instrument Kit")
;
; show items in ik
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 instrument kit, all items used to build the instrument kit 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 instrument kit."
. D DISPLAY^PRCPUX2(20,60,.X)
. K X S X(1)="Disassembling Instrument Kit" D DISPLAY^PRCPUX2(1,79,.X)
. ; decrement instrument kit item
. S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
. S ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0),TOTVAL=$J(QUANTITY*$P(ITEMDATA,"^",22),0,2)
. K PRCPCDIK S PRCPCDIK("QTY")=-QUANTITY,PRCPCDIK("INVVAL")=-TOTVAL,PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
. D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIK)
;
; 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 instrument kit before you can disassemble it."
. D DISPLAY^PRCPUX2(20,60,.X)
S XP="ARE YOU SURE YOU WANT TO DISASSEMBLE THIS INSTRUMENT KIT",XH="Enter 'YES' to disassemble the instrument kit, 'NO' or '^' to exit."
W ! I $$YN^PRCPUYN(2)'=1 D EXIT G DISASMBL
;
S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
S IKITEM=0 F S IKITEM=$O(^TMP($J,"PRCPCDIR",IKITEM)) Q:'IKITEM S DATA=^(IKITEM) D
. K PRCPCDIK S PRCPCDIK("QTY")=$P(DATA,"^"),PRCPCDIK("INVVAL")=$J($P(DATA,"^",2),0,2),PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
. D ITEM^PRCPUUIP(PRCP("I"),IKITEM,"S",ORDERNO,.PRCPCDIK)
;
; decrement instrument kit item
S ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0),TOTVAL=$J(QUANTITY*$P(ITEMDATA,"^",22),0,2)
; do not remove node 8 since other ccs may contain the ik
;I $P(ITEMDATA,"^",7)=QUANTITY S TOTVAL=$P(ITEMDATA,"^",27) K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
K PRCPCDIK S PRCPCDIK("QTY")=-QUANTITY,PRCPCDIK("INVVAL")=-TOTVAL,PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIK)
D EXIT G DISASMBL
;
EXIT ; exit, unlock, clean up
D CLEAR^PRCPULOC(445.8,ITEMDA,0)
L -^PRCP(445.8,ITEMDA)
K ^TMP($J,"PRCPCDIR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCDIK 4180 printed Sep 23, 2025@19:49:12 Page 2
PRCPCDIK ;WISC/RFJ-disassemble instrument kit ;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 %,IKITEM,DATA,ITEMDA,ITEMDATA,NOTINVPT,ORDERNO,PRCPCDIK,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 Instrument Kit option will break down the instrument kit and return the individual disposable items back to stock."
+9 SET 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."
+10 SET X(3)="The disposable item quantity to return to stock equals the quantity used for the item during assembly of the instrument kit."
+11 SET 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."
+12 DO DISPLAY^PRCPUX2(40,79,.X)
DISASMBL ; disassemble instrument kit
+1 KILL NOTINVPT,ORDERNO,PRCPFLAG
+2 WRITE !
SET ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I"))
IF ITEMDA<1
QUIT
+3 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
+4 IF ITEMDATA=""
WRITE !!,"Instrument Kit is not stored as an item in the inventory point."
GOTO DISASMBL
+5 IF '$PIECE(ITEMDATA,"^",7)
WRITE !!,"Instrument Kit 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.8,ITEMDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445.8,ITEMDA,0)
DO EXIT
GOTO DISASMBL
+8 DO ADD^PRCPULOC(445.8,ITEMDA,0,"Disassemble Instrument Kit")
+9 ;
+10 ; show items in ik
+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 instrument kit, all items used to build the instrument kit 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 instrument kit."
+21 DO DISPLAY^PRCPUX2(20,60,.X)
+22 KILL X
SET X(1)="Disassembling Instrument Kit"
DO DISPLAY^PRCPUX2(1,79,.X)
+23 ; decrement instrument kit item
+24 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+25 SET ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0)
SET TOTVAL=$JUSTIFY(QUANTITY*$PIECE(ITEMDATA,"^",22),0,2)
+26 KILL PRCPCDIK
SET PRCPCDIK("QTY")=-QUANTITY
SET PRCPCDIK("INVVAL")=-TOTVAL
SET PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
+27 DO ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIK)
End DoDot:1
DO EXIT
GOTO DISASMBL
+28 ;
+29 ; user entered '^' during list display
+30 IF $GET(PRCPFLAG)
Begin DoDot:1
+31 KILL X
SET X(1)="You must display the entire list of items for the instrument kit before you can disassemble it."
+32 DO DISPLAY^PRCPUX2(20,60,.X)
End DoDot:1
DO EXIT
GOTO DISASMBL
+33 SET XP="ARE YOU SURE YOU WANT TO DISASSEMBLE THIS INSTRUMENT KIT"
SET XH="Enter 'YES' to disassemble the instrument kit, 'NO' or '^' to exit."
+34 WRITE !
IF $$YN^PRCPUYN(2)'=1
DO EXIT
GOTO DISASMBL
+35 ;
+36 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+37 SET IKITEM=0
FOR
SET IKITEM=$ORDER(^TMP($JOB,"PRCPCDIR",IKITEM))
if 'IKITEM
QUIT
SET DATA=^(IKITEM)
Begin DoDot:1
+38 KILL PRCPCDIK
SET PRCPCDIK("QTY")=$PIECE(DATA,"^")
SET PRCPCDIK("INVVAL")=$JUSTIFY($PIECE(DATA,"^",2),0,2)
SET PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
+39 DO ITEM^PRCPUUIP(PRCP("I"),IKITEM,"S",ORDERNO,.PRCPCDIK)
End DoDot:1
+40 ;
+41 ; decrement instrument kit item
+42 SET ITEMDATA=^PRCP(445,PRCP("I"),1,ITEMDA,0)
SET TOTVAL=$JUSTIFY(QUANTITY*$PIECE(ITEMDATA,"^",22),0,2)
+43 ; do not remove node 8 since other ccs may contain the ik
+44 ;I $P(ITEMDATA,"^",7)=QUANTITY S TOTVAL=$P(ITEMDATA,"^",27) K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
+45 KILL PRCPCDIK
SET PRCPCDIK("QTY")=-QUANTITY
SET PRCPCDIK("INVVAL")=-TOTVAL
SET PRCPCDIK("REASON")="0:Disassembled Instrument Kit"
+46 DO ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCDIK)
+47 DO EXIT
GOTO DISASMBL
+48 ;
EXIT ; exit, unlock, clean up
+1 DO CLEAR^PRCPULOC(445.8,ITEMDA,0)
+2 LOCK -^PRCP(445.8,ITEMDA)
+3 KILL ^TMP($JOB,"PRCPCDIR")
+4 QUIT
