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