PRCPCASK ;WISC/RFJ-assemble 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,NEGATIVE,NOTINVPT,ORDERNO,PRCPCASK,PRCPID,PRCPITEM,QUANTITY,X,Y
I $$CHECK^PRCPCUT1(PRCP("I")) Q
S IOP="HOME" D ^%ZIS K IOP
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."
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."
D DISPLAY^PRCPUX2(40,79,.X)
ASSEMBLE ; assemble instrument kit
K NEGATIVE,NOTINVPT,ORDERNO,PRCPFLAG
W ! S ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I")) I ITEMDA<1 Q
I '$D(^PRCP(445,PRCP("I"),1,ITEMDA,0)) W !!,"Instrument Kit is not stored as an item in the inventory point." G ASSEMBLE
W ! S QUANTITY=$$QUANTITY^PRCPCUT1(99,"A") I 'QUANTITY G ASSEMBLE
L +^PRCP(445.8,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.8,ITEMDA,0),EXIT G ASSEMBLE
D ADD^PRCPULOC(445.8,ITEMDA,0,"Assemble Intrument Kit")
D GETDEF^PRCPCUT1(445.8,ITEMDA)
;I '$O(^TMP($J,"PRCPLIST-DISP",0)) W !!,"No Disposable Items Stored in Instrument Kit." D EXIT G ASSEMBLE
;
I $P($G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),"^",7) D CHECK^PRCPCASR("I") I $G(PRCPFLAG) D EXIT G ASSEMBLE
;
; show items in ik
D PRINT^PRCPCASR(QUANTITY)
; some items not in inventory point message
I $G(NOTINVPT) D D EXIT G ASSEMBLE
. 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."
. D DISPLAY^PRCPUX2(20,60,.X)
. D R^PRCPUREP
;
; some items have new quantities less than zero
I $G(NEGATIVE) D
. 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."
. D DISPLAY^PRCPUX2(20,60,.X)
;
; no disposable items to build list with
I '$O(^TMP($J,"PRCPCASR",0)) D D EXIT G ASSEMBLE
. K X S X(1)="There are no disposable items or defined quantities for building the instrument kit."
. D DISPLAY^PRCPUX2(20,60,.X)
. K X S X(1)="Assembling Instrument Kit" D DISPLAY^PRCPUX2(1,79,.X)
. ; increment ik qty
. S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
. K PRCPCASK S PRCPCASK("QTY")=QUANTITY,PRCPCASK("INVVAL")=0,PRCPCASK("REASON")="0:Assembled Instrument Kit"
. D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASK)
;
; user entered '^' during list display
I $G(PRCPFLAG) D D EXIT G ASSEMBLE
. K X S X(1)="You must display the entire list of items for the instrument kit before you can assemble it."
. D DISPLAY^PRCPUX2(20,60,.X)
S XP="ARE YOU SURE YOU WANT TO ASSEMBLE THIS INSTRUMENT KIT",XH="Enter 'YES' to assemble the instrument kit, 'NO' or '^' to exit."
W ! I $$YN^PRCPUYN(2)'=1 D EXIT G ASSEMBLE
;
; reset instrument kit items in inventory point
K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
S IKITEM=0 F S IKITEM=$O(^TMP($J,"PRCPCASR",IKITEM)) Q:'IKITEM S DATA=^(IKITEM) D
. K PRCPCASK S PRCPCASK("QTY")=-$P(DATA,"^"),PRCPCASK("INVVAL")=-$J($P(DATA,"^",2),0,2),PRCPCASK("REASON")="0:Assembled Instrument Kit"
. D ITEM^PRCPUUIP(PRCP("I"),IKITEM,"S",ORDERNO,.PRCPCASK)
. ;
. ; add item to instrument kit in inventory point
. D ADDCCIK^PRCPCUT1(PRCP("I"),ITEMDA,IKITEM,^TMP($J,"PRCPLIST",IKITEM))
;
; increment instrument kit item
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"
D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASK)
D EXIT G ASSEMBLE
;
EXIT ; exit, unlock, clean up
D CLEAR^PRCPULOC(445.8,ITEMDA,0)
L -^PRCP(445.8,ITEMDA)
K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP"),^TMP($J,"PRCPCASR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCASK 4221 printed Apr 09, 2024@21:10:39 Page 2
PRCPCASK ;WISC/RFJ-assemble 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,NEGATIVE,NOTINVPT,ORDERNO,PRCPCASK,PRCPID,PRCPITEM,QUANTITY,X,Y
+6 IF $$CHECK^PRCPCUT1(PRCP("I"))
QUIT
+7 SET IOP="HOME"
DO ^%ZIS
KILL IOP
+8 KILL X
SET 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."
+9 SET 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."
+10 DO DISPLAY^PRCPUX2(40,79,.X)
ASSEMBLE ; assemble instrument kit
+1 KILL NEGATIVE,NOTINVPT,ORDERNO,PRCPFLAG
+2 WRITE !
SET ITEMDA=$$SELECT^PRCPCED0("K",0,PRCP("I"))
IF ITEMDA<1
QUIT
+3 IF '$DATA(^PRCP(445,PRCP("I"),1,ITEMDA,0))
WRITE !!,"Instrument Kit is not stored as an item in the inventory point."
GOTO ASSEMBLE
+4 WRITE !
SET QUANTITY=$$QUANTITY^PRCPCUT1(99,"A")
IF 'QUANTITY
GOTO ASSEMBLE
+5 LOCK +^PRCP(445.8,ITEMDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445.8,ITEMDA,0)
DO EXIT
GOTO ASSEMBLE
+6 DO ADD^PRCPULOC(445.8,ITEMDA,0,"Assemble Intrument Kit")
+7 DO GETDEF^PRCPCUT1(445.8,ITEMDA)
+8 ;I '$O(^TMP($J,"PRCPLIST-DISP",0)) W !!,"No Disposable Items Stored in Instrument Kit." D EXIT G ASSEMBLE
+9 ;
+10 IF $PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,0)),"^",7)
DO CHECK^PRCPCASR("I")
IF $GET(PRCPFLAG)
DO EXIT
GOTO ASSEMBLE
+11 ;
+12 ; show items in ik
+13 DO PRINT^PRCPCASR(QUANTITY)
+14 ; some items not in inventory point message
+15 IF $GET(NOTINVPT)
Begin DoDot:1
+16 KILL X
SET X(1)="WARNING -- Before assembling a instrument kit, all items used to build the instrument kit must be contained in the inventory point."
+17 DO DISPLAY^PRCPUX2(20,60,.X)
+18 DO R^PRCPUREP
End DoDot:1
DO EXIT
GOTO ASSEMBLE
+19 ;
+20 ; some items have new quantities less than zero
+21 IF $GET(NEGATIVE)
Begin DoDot:1
+22 KILL X
SET 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."
+23 DO DISPLAY^PRCPUX2(20,60,.X)
End DoDot:1
+24 ;
+25 ; no disposable items to build list with
+26 IF '$ORDER(^TMP($JOB,"PRCPCASR",0))
Begin DoDot:1
+27 KILL X
SET X(1)="There are no disposable items or defined quantities for building the instrument kit."
+28 DO DISPLAY^PRCPUX2(20,60,.X)
+29 KILL X
SET X(1)="Assembling Instrument Kit"
DO DISPLAY^PRCPUX2(1,79,.X)
+30 ; increment ik qty
+31 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+32 KILL PRCPCASK
SET PRCPCASK("QTY")=QUANTITY
SET PRCPCASK("INVVAL")=0
SET PRCPCASK("REASON")="0:Assembled Instrument Kit"
+33 DO ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASK)
End DoDot:1
DO EXIT
GOTO ASSEMBLE
+34 ;
+35 ; user entered '^' during list display
+36 IF $GET(PRCPFLAG)
Begin DoDot:1
+37 KILL X
SET X(1)="You must display the entire list of items for the instrument kit before you can assemble it."
+38 DO DISPLAY^PRCPUX2(20,60,.X)
End DoDot:1
DO EXIT
GOTO ASSEMBLE
+39 SET XP="ARE YOU SURE YOU WANT TO ASSEMBLE THIS INSTRUMENT KIT"
SET XH="Enter 'YES' to assemble the instrument kit, 'NO' or '^' to exit."
+40 WRITE !
IF $$YN^PRCPUYN(2)'=1
DO EXIT
GOTO ASSEMBLE
+41 ;
+42 ; reset instrument kit items in inventory point
+43 KILL ^PRCP(445,PRCP("I"),1,ITEMDA,8)
+44 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+45 SET IKITEM=0
FOR
SET IKITEM=$ORDER(^TMP($JOB,"PRCPCASR",IKITEM))
if 'IKITEM
QUIT
SET DATA=^(IKITEM)
Begin DoDot:1
+46 KILL PRCPCASK
SET PRCPCASK("QTY")=-$PIECE(DATA,"^")
SET PRCPCASK("INVVAL")=-$JUSTIFY($PIECE(DATA,"^",2),0,2)
SET PRCPCASK("REASON")="0:Assembled Instrument Kit"
+47 DO ITEM^PRCPUUIP(PRCP("I"),IKITEM,"S",ORDERNO,.PRCPCASK)
+48 ;
+49 ; add item to instrument kit in inventory point
+50 DO ADDCCIK^PRCPCUT1(PRCP("I"),ITEMDA,IKITEM,^TMP($JOB,"PRCPLIST",IKITEM))
End DoDot:1
+51 ;
+52 ; increment instrument kit item
+53 KILL PRCPCASK
SET PRCPCASK("QTY")=QUANTITY
SET PRCPCASK("INVVAL")=$JUSTIFY(QUANTITY*$PIECE($GET(^PRCP(445.8,ITEMDA,0)),"^",9),0,2)
SET PRCPCASK("REASON")="0:Assembled Instrument Kit"
+54 DO ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASK)
+55 DO EXIT
GOTO ASSEMBLE
+56 ;
EXIT ; exit, unlock, clean up
+1 DO CLEAR^PRCPULOC(445.8,ITEMDA,0)
+2 LOCK -^PRCP(445.8,ITEMDA)
+3 KILL ^TMP($JOB,"PRCPLIST"),^TMP($JOB,"PRCPLIST-DISP"),^TMP($JOB,"PRCPCASR")
+4 QUIT
