PRCPCASC ;WISC/RFJ-assemble 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,NEGATIVE,NOTINVPT,ORDERNO,PRCPCASC,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 Case Cart option will build the selected case cart by the case cart definition. The case cart definition describes the items and quantities which are used in building the case cart."
S X(2)="If a case cart has previously been built by the inventory point and the definition has been altered, the previously built case cart will have to be disassembled first."
D DISPLAY^PRCPUX2(40,79,.X)
ASSEMBLE ; assemble case cart
K NEGATIVE,NOTINVPT,ORDERNO,PRCPFLAG
W ! S ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I")) I ITEMDA<1 Q
I '$D(^PRCP(445,PRCP("I"),1,ITEMDA,0)) W !!,"Case Cart 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.7,ITEMDA):5 I '$T D SHOWWHO^PRCPULOC(445.7,ITEMDA,0),EXIT G ASSEMBLE
D ADD^PRCPULOC(445.7,ITEMDA,0,"Assemble Case Cart")
D GETDEF^PRCPCUT1(445.7,ITEMDA)
I '$O(^TMP($J,"PRCPLIST-DISP",0)) W !!,"No Disposable Items Stored in Case Cart." D EXIT G ASSEMBLE
;
I $P($G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),"^",7) D CHECK^PRCPCASR("C") I $G(PRCPFLAG) D EXIT G ASSEMBLE
;
; show items in cc
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 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
;
; some items have new quantities less than zero
I $G(NEGATIVE) D
. K X S X(1)="WARNING -- After assembling the case cart, some of the items contained within the case cart 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 case cart."
. D DISPLAY^PRCPUX2(20,60,.X)
;
; 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 case cart before you can assemble it."
. D DISPLAY^PRCPUX2(20,60,.X)
S XP="ARE YOU SURE YOU WANT TO ASSEMBLE THIS CASE CART",XH="Enter 'YES' to assemble the case cart, 'NO' or '^' to exit."
W ! I $$YN^PRCPUYN(2)'=1 D EXIT G ASSEMBLE
;
; reset case cart items in inventory point
K ^PRCP(445,PRCP("I"),1,ITEMDA,8)
S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCASR",CCITEM)) Q:'CCITEM S DATA=^(CCITEM) D
. K PRCPCASC S PRCPCASC("QTY")=-$P(DATA,"^"),PRCPCASC("INVVAL")=-$J($P(DATA,"^",2),0,2),PRCPCASC("REASON")="0:Assembled Case Cart"
. D ITEM^PRCPUUIP(PRCP("I"),CCITEM,"S",ORDERNO,.PRCPCASC)
. ;
. ; add item to case cart in inventory point
. D ADDCCIK^PRCPCUT1(PRCP("I"),ITEMDA,CCITEM,^TMP($J,"PRCPLIST",CCITEM))
;
; increment case cart item
K PRCPCASC S PRCPCASC("QTY")=QUANTITY,PRCPCASC("INVVAL")=$J(QUANTITY*$P($G(^PRCP(445.7,ITEMDA,0)),"^",7),0,2),PRCPCASC("REASON")="0:Assembled Case Cart"
D ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASC)
D EXIT G ASSEMBLE
;
EXIT ; exit, unlock, clean up
D CLEAR^PRCPULOC(445.7,ITEMDA,0)
L -^PRCP(445.7,ITEMDA)
K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP"),^TMP($J,"PRCPCASR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCASC 3782 printed Apr 09, 2024@21:06:19 Page 2
PRCPCASC ;WISC/RFJ-assemble 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,NEGATIVE,NOTINVPT,ORDERNO,PRCPCASC,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 Case Cart option will build the selected case cart by the case cart definition. The case cart definition describes the items and quantities which are used in building the case cart."
+9 SET X(2)="If a case cart has previously been built by the inventory point and the definition has been altered, the previously built case cart will have to be disassembled first."
+10 DO DISPLAY^PRCPUX2(40,79,.X)
ASSEMBLE ; assemble case cart
+1 KILL NEGATIVE,NOTINVPT,ORDERNO,PRCPFLAG
+2 WRITE !
SET ITEMDA=$$SELECT^PRCPCED0("C",0,PRCP("I"))
IF ITEMDA<1
QUIT
+3 IF '$DATA(^PRCP(445,PRCP("I"),1,ITEMDA,0))
WRITE !!,"Case Cart 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.7,ITEMDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445.7,ITEMDA,0)
DO EXIT
GOTO ASSEMBLE
+6 DO ADD^PRCPULOC(445.7,ITEMDA,0,"Assemble Case Cart")
+7 DO GETDEF^PRCPCUT1(445.7,ITEMDA)
+8 IF '$ORDER(^TMP($JOB,"PRCPLIST-DISP",0))
WRITE !!,"No Disposable Items Stored in Case Cart."
DO EXIT
GOTO ASSEMBLE
+9 ;
+10 IF $PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,0)),"^",7)
DO CHECK^PRCPCASR("C")
IF $GET(PRCPFLAG)
DO EXIT
GOTO ASSEMBLE
+11 ;
+12 ; show items in cc
+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 case cart, all items used to build the case cart 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 case cart, some of the items contained within the case cart 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 case cart."
+28 DO DISPLAY^PRCPUX2(20,60,.X)
End DoDot:1
DO EXIT
GOTO ASSEMBLE
+29 ;
+30 ; user entered '^' during list display
+31 IF $GET(PRCPFLAG)
Begin DoDot:1
+32 KILL X
SET X(1)="You must display the entire list of items for the case cart before you can assemble it."
+33 DO DISPLAY^PRCPUX2(20,60,.X)
End DoDot:1
DO EXIT
GOTO ASSEMBLE
+34 SET XP="ARE YOU SURE YOU WANT TO ASSEMBLE THIS CASE CART"
SET XH="Enter 'YES' to assemble the case cart, 'NO' or '^' to exit."
+35 WRITE !
IF $$YN^PRCPUYN(2)'=1
DO EXIT
GOTO ASSEMBLE
+36 ;
+37 ; reset case cart items in inventory point
+38 KILL ^PRCP(445,PRCP("I"),1,ITEMDA,8)
+39 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+40 SET CCITEM=0
FOR
SET CCITEM=$ORDER(^TMP($JOB,"PRCPCASR",CCITEM))
if 'CCITEM
QUIT
SET DATA=^(CCITEM)
Begin DoDot:1
+41 KILL PRCPCASC
SET PRCPCASC("QTY")=-$PIECE(DATA,"^")
SET PRCPCASC("INVVAL")=-$JUSTIFY($PIECE(DATA,"^",2),0,2)
SET PRCPCASC("REASON")="0:Assembled Case Cart"
+42 DO ITEM^PRCPUUIP(PRCP("I"),CCITEM,"S",ORDERNO,.PRCPCASC)
+43 ;
+44 ; add item to case cart in inventory point
+45 DO ADDCCIK^PRCPCUT1(PRCP("I"),ITEMDA,CCITEM,^TMP($JOB,"PRCPLIST",CCITEM))
End DoDot:1
+46 ;
+47 ; increment case cart item
+48 KILL PRCPCASC
SET PRCPCASC("QTY")=QUANTITY
SET PRCPCASC("INVVAL")=$JUSTIFY(QUANTITY*$PIECE($GET(^PRCP(445.7,ITEMDA,0)),"^",7),0,2)
SET PRCPCASC("REASON")="0:Assembled Case Cart"
+49 DO ITEM^PRCPUUIP(PRCP("I"),ITEMDA,"S",ORDERNO,.PRCPCASC)
+50 DO EXIT
GOTO ASSEMBLE
+51 ;
EXIT ; exit, unlock, clean up
+1 DO CLEAR^PRCPULOC(445.7,ITEMDA,0)
+2 LOCK -^PRCP(445.7,ITEMDA)
+3 KILL ^TMP($JOB,"PRCPLIST"),^TMP($JOB,"PRCPLIST-DISP"),^TMP($JOB,"PRCPCASR")
+4 QUIT
