PRCPECPP ;WISC/RFJ-copy items from primary to secondary;1/4/99 1435
V ;;5.1;IFCAP;**1**;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" D QUIT
. W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT."
;
N %,A,D0,DA,DATA,DELETE,DI,DIC,DIE,DQ,DR,EACHONE,ITEMCNT,ITEMDA
N LASTONE,NUMBER,PIECE,PRCPINFR,PRCPINTO,PRCPFLVL,PRCPNL,PRCPSENT,X,Y,PRCPXX
S PRCPINFR=PRCP("I")
;
ASKTO ; ask inventory point to copy to
K X S X(1)="Select the SECONDARY inventory point to copy TO."
W ! D DISPLAY^PRCPUX2(1,40,.X)
S PRCPINTO=$$TO^PRCPUDPT(PRCP("I")) I 'PRCPINTO Q
I $P($G(^PRCP(445,PRCPINTO,0)),"^",2)="Y" D G ASKTO
. K X S X(1)="ERROR: THE SECONDARY INVENTORY POINT BEING COPIED TO CANNOT BE KEEPING A PERPETUAL INVENTORY."
. D DISPLAY^PRCPUX2(5,75,.X)
;
I '$D(^PRCP(445,PRCPINTO,4,DUZ)) D G ASKTO
. K X S X(1)="ERROR: YOU ARE NOT AN AUTHORIZED USER FOR THIS INVENTORY POINT."
. D DISPLAY^PRCPUX2(5,75,.X)
;
L +^PRCP(445,PRCPINTO,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINTO_"-1",0) Q
D ADD^PRCPULOC(445,PRCPINTO_"-1",0,"Item copying")
S ITEMCNT=+$P($G(^PRCP(445,PRCPINTO,1,0)),"^",4)
W !?5,"Number of items currently stored: ",ITEMCNT
S DELETE=0
I ITEMCNT D I 'DELETE G EXIT
. I $$ORDCHK^PRCPUITM(0,PRCPINTO,"RCE","") D S DELETE=2 QUIT
. . W !,$$INVNAME^PRCPUX1(PRCPINTO)," has outstanding orders. You may overwrite"
. . W !,"but cannot delete items already stored here."
. I DELETE=2 QUIT
. S XP="Since there are already items stored in the secondary inventory point you"
. S XP(1)="are copying TO, do you want to delete ALL items before making the copy"
. S XH="Enter YES to remove ALL items from "_$$INVNAME^PRCPUX1(PRCPINTO)_"."
. S XH(1)="Enter NO to OVERWRITE items currently stored in the inventory point."
. S XH(2)="Enter ^ to exit."
. W ! S DELETE=$$YN^PRCPUYN(2)
;
S PRCPFLVL=0
S XP="Do you want to copy the stock levels and reorder points"
S XH="Enter YES to copy the normal stock level, emergency stock level, standard"
S XH(1)="reorder point, and optional reorder point."
W ! I $$YN^PRCPUYN(2)=1 S PRCPFLVL=1
;
K X S X(1)="Copying from: "_$$INVNAME^PRCPUX1(PRCPINFR)_" to: "_$$INVNAME^PRCPUX1(PRCPINTO)
W !! D DISPLAY^PRCPUX2(5,75,.X)
S XP="Are you sure you want to copy the items"
S XH="Enter YES to start copying the items, NO or ^ to exit."
I $$YN^PRCPUYN(2)'=1 G EXIT
;
I $G(DELETE)=1 D
. W !!,"Deleting Items. . . ."
. ; S EACHONE=$$INPERCNT^PRCPUX2(ITEMCNT,"*",PRCP("RV1"),PRCP("RV0"))
. S ITEMDA=0
. F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCPINTO,1,ITEMDA)) Q:'ITEMDA D
. . D DELITEM^PRCPUITM(PRCPINTO,ITEMDA)
. . ; S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. ; D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
. W !,"Deletions completed",!
;
W !!!,"Copying Items. . . ."
; S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCPINFR,1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
I '$D(^PRCP(445,PRCPINTO,1,0)) S ^(0)="^445.01IP^^"
S ITEMDA=0
F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCPINFR,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D
. ; S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. I '$D(^PRCP(445,PRCPINTO,1,ITEMDA,0)) D ADDITEM^PRCPECPS(PRCPINTO,ITEMDA)
. I '$D(^PRCP(445,PRCPINTO,1,ITEMDA,0)) Q
. I $G(PRCPFLVL)>0 S PRCPNL=+$P(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",9)
. S DR=""
. F PIECE=5,14,15 I $P(DATA,"^",PIECE)'="" S DR=DR_$S(PIECE=5:4,PIECE=14:4.5,PIECE=15:4.7,1:PIECE)_"////"_$P(DATA,"^",PIECE)_";"
. I $G(PRCPFLVL)>0 F PIECE=4,9,10,11 I $P(DATA,"^",PIECE)'="" S DR=DR_$S(PIECE=4:10.3,1:PIECE)_"////"_$P(DATA,"^",PIECE)_";"
. I $P($G(^PRCP(445,PRCPINFR,1,ITEMDA,6)),"^")'="" S PRCPXX=$P(^(6),"^"),DR=DR_".7////^S X=PRCPXX"
. S (DIC,DIE)="^PRCP(445,"_PRCPINTO_",1,"
. S DA(1)=PRCPINTO,DA=ITEMDA
. D ^DIE
. D ADDVEN^PRCPUVEN(PRCPINTO,ITEMDA,PRCPINFR_";PRCP(445,",$P(DATA,"^",5),$P(DATA,"^",14),1)
. S $P(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",12)=PRCPINFR_";PRCP(445,"
. S ^PRCP(445,PRCPINTO,1,"AC",PRCPINFR_";PRCP(445,",ITEMDA)=""
. S PRCPSENT=0
. I $G(PRCPFLVL)>0,PRCPNL=0,$P(DATA,"^",9)>0 D
. . D BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINTO) ; send transaction to supply station
. . S PRCPSENT=1
. I 'PRCPSENT,$P(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",9)>0 D BLDSEG^PRCPHLFM(3,ITEMDA,PRCPINTO) ; send item info to supply station
; D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
;
W !!,"Copy Completed !"
EXIT D CLEAR^PRCPULOC(445,PRCPINTO_"-1",0)
L -^PRCP(445,PRCPINTO,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPECPP 4648 printed Sep 23, 2025@19:49:35 Page 2
PRCPECPP ;WISC/RFJ-copy items from primary to secondary;1/4/99 1435
V ;;5.1;IFCAP;**1**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 ;
+5 IF PRCP("DPTYPE")'="P"
Begin DoDot:1
+6 WRITE !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT."
End DoDot:1
QUIT
+7 ;
+8 NEW %,A,D0,DA,DATA,DELETE,DI,DIC,DIE,DQ,DR,EACHONE,ITEMCNT,ITEMDA
+9 NEW LASTONE,NUMBER,PIECE,PRCPINFR,PRCPINTO,PRCPFLVL,PRCPNL,PRCPSENT,X,Y,PRCPXX
+10 SET PRCPINFR=PRCP("I")
+11 ;
ASKTO ; ask inventory point to copy to
+1 KILL X
SET X(1)="Select the SECONDARY inventory point to copy TO."
+2 WRITE !
DO DISPLAY^PRCPUX2(1,40,.X)
+3 SET PRCPINTO=$$TO^PRCPUDPT(PRCP("I"))
IF 'PRCPINTO
QUIT
+4 IF $PIECE($GET(^PRCP(445,PRCPINTO,0)),"^",2)="Y"
Begin DoDot:1
+5 KILL X
SET X(1)="ERROR: THE SECONDARY INVENTORY POINT BEING COPIED TO CANNOT BE KEEPING A PERPETUAL INVENTORY."
+6 DO DISPLAY^PRCPUX2(5,75,.X)
End DoDot:1
GOTO ASKTO
+7 ;
+8 IF '$DATA(^PRCP(445,PRCPINTO,4,DUZ))
Begin DoDot:1
+9 KILL X
SET X(1)="ERROR: YOU ARE NOT AN AUTHORIZED USER FOR THIS INVENTORY POINT."
+10 DO DISPLAY^PRCPUX2(5,75,.X)
End DoDot:1
GOTO ASKTO
+11 ;
+12 LOCK +^PRCP(445,PRCPINTO,1):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPINTO_"-1",0)
QUIT
+13 DO ADD^PRCPULOC(445,PRCPINTO_"-1",0,"Item copying")
+14 SET ITEMCNT=+$PIECE($GET(^PRCP(445,PRCPINTO,1,0)),"^",4)
+15 WRITE !?5,"Number of items currently stored: ",ITEMCNT
+16 SET DELETE=0
+17 IF ITEMCNT
Begin DoDot:1
+18 IF $$ORDCHK^PRCPUITM(0,PRCPINTO,"RCE","")
Begin DoDot:2
+19 WRITE !,$$INVNAME^PRCPUX1(PRCPINTO)," has outstanding orders. You may overwrite"
+20 WRITE !,"but cannot delete items already stored here."
End DoDot:2
SET DELETE=2
QUIT
+21 IF DELETE=2
QUIT
+22 SET XP="Since there are already items stored in the secondary inventory point you"
+23 SET XP(1)="are copying TO, do you want to delete ALL items before making the copy"
+24 SET XH="Enter YES to remove ALL items from "_$$INVNAME^PRCPUX1(PRCPINTO)_"."
+25 SET XH(1)="Enter NO to OVERWRITE items currently stored in the inventory point."
+26 SET XH(2)="Enter ^ to exit."
+27 WRITE !
SET DELETE=$$YN^PRCPUYN(2)
End DoDot:1
IF 'DELETE
GOTO EXIT
+28 ;
+29 SET PRCPFLVL=0
+30 SET XP="Do you want to copy the stock levels and reorder points"
+31 SET XH="Enter YES to copy the normal stock level, emergency stock level, standard"
+32 SET XH(1)="reorder point, and optional reorder point."
+33 WRITE !
IF $$YN^PRCPUYN(2)=1
SET PRCPFLVL=1
+34 ;
+35 KILL X
SET X(1)="Copying from: "_$$INVNAME^PRCPUX1(PRCPINFR)_" to: "_$$INVNAME^PRCPUX1(PRCPINTO)
+36 WRITE !!
DO DISPLAY^PRCPUX2(5,75,.X)
+37 SET XP="Are you sure you want to copy the items"
+38 SET XH="Enter YES to start copying the items, NO or ^ to exit."
+39 IF $$YN^PRCPUYN(2)'=1
GOTO EXIT
+40 ;
+41 IF $GET(DELETE)=1
Begin DoDot:1
+42 WRITE !!,"Deleting Items. . . ."
+43 ; S EACHONE=$$INPERCNT^PRCPUX2(ITEMCNT,"*",PRCP("RV1"),PRCP("RV0"))
+44 SET ITEMDA=0
+45 FOR NUMBER=1:1
SET ITEMDA=$ORDER(^PRCP(445,PRCPINTO,1,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:2
+46 DO DELITEM^PRCPUITM(PRCPINTO,ITEMDA)
+47 ; S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
End DoDot:2
+48 ; D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
+49 WRITE !,"Deletions completed",!
End DoDot:1
+50 ;
+51 WRITE !!!,"Copying Items. . . ."
+52 ; S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCPINFR,1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
+53 IF '$DATA(^PRCP(445,PRCPINTO,1,0))
SET ^(0)="^445.01IP^^"
+54 SET ITEMDA=0
+55 FOR NUMBER=1:1
SET ITEMDA=$ORDER(^PRCP(445,PRCPINFR,1,ITEMDA))
if 'ITEMDA
QUIT
SET DATA=$GET(^(ITEMDA,0))
IF DATA'=""
Begin DoDot:1
+56 ; S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
+57 IF '$DATA(^PRCP(445,PRCPINTO,1,ITEMDA,0))
DO ADDITEM^PRCPECPS(PRCPINTO,ITEMDA)
+58 IF '$DATA(^PRCP(445,PRCPINTO,1,ITEMDA,0))
QUIT
+59 IF $GET(PRCPFLVL)>0
SET PRCPNL=+$PIECE(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",9)
+60 SET DR=""
+61 FOR PIECE=5,14,15
IF $PIECE(DATA,"^",PIECE)'=""
SET DR=DR_$SELECT(PIECE=5:4,PIECE=14:4.5,PIECE=15:4.7,1:PIECE)_"////"_$PIECE(DATA,"^",PIECE)_";"
+62 IF $GET(PRCPFLVL)>0
FOR PIECE=4,9,10,11
IF $PIECE(DATA,"^",PIECE)'=""
SET DR=DR_$SELECT(PIECE=4:10.3,1:PIECE)_"////"_$PIECE(DATA,"^",PIECE)_";"
+63 IF $PIECE($GET(^PRCP(445,PRCPINFR,1,ITEMDA,6)),"^")'=""
SET PRCPXX=$PIECE(^(6),"^")
SET DR=DR_".7////^S X=PRCPXX"
+64 SET (DIC,DIE)="^PRCP(445,"_PRCPINTO_",1,"
+65 SET DA(1)=PRCPINTO
SET DA=ITEMDA
+66 DO ^DIE
+67 DO ADDVEN^PRCPUVEN(PRCPINTO,ITEMDA,PRCPINFR_";PRCP(445,",$PIECE(DATA,"^",5),$PIECE(DATA,"^",14),1)
+68 SET $PIECE(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",12)=PRCPINFR_";PRCP(445,"
+69 SET ^PRCP(445,PRCPINTO,1,"AC",PRCPINFR_";PRCP(445,",ITEMDA)=""
+70 SET PRCPSENT=0
+71 IF $GET(PRCPFLVL)>0
IF PRCPNL=0
IF $PIECE(DATA,"^",9)>0
Begin DoDot:2
+72 ; send transaction to supply station
DO BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINTO)
+73 SET PRCPSENT=1
End DoDot:2
+74 ; send item info to supply station
IF 'PRCPSENT
IF $PIECE(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",9)>0
DO BLDSEG^PRCPHLFM(3,ITEMDA,PRCPINTO)
End DoDot:1
+75 ; D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
+76 ;
+77 WRITE !!,"Copy Completed !"
EXIT DO CLEAR^PRCPULOC(445,PRCPINTO_"-1",0)
+1 LOCK -^PRCP(445,PRCPINTO,1)
+2 QUIT
