PRCPCSP1 ;WISC/RFJ/DXH - convert secondary to primary ;10.14.99
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
CONVRT W !!,"Preparing to convert: "_$$INVNAME^PRCPUX1(INVPT)_" to a primary."
K XP,XH S XP="Are you sure this is what you want to do",XH="Enter YES to start converting, NO or ^ to exit."
I $$YN^PRCPUYN(2)'=1 S ESCAPE=1 Q
;
L +^PRCP(445,INVPT):5 I '$T W !,"Sorry, another user is editing this inventory point. Please try again later." S ESCAPE=1 Q
; store some data in case user decides to 'undo' conversion
S ^PRCP(445,INVPT,"SEC")=^PRCP(445,INVPT,0)_"|"_$G(DUZ)_"|"_$G(DT)_"|"_PRCP("I")
I $O(^PRCP(445,INVPT,3,0)) S %X="^PRCP(445,"_INVPT_",3,",%Y="^PRCP(445,"_INVPT_",""SECMIS""," D %XY^%RCR ; mis costing sections
S DIE="^PRCP(445,",DA=INVPT
S DR=".5;.6;.9" D ^DIE K DR I $D(DTOUT)!($D(Y)) D L -^PRCP(445,INVPT) Q
. I $D(DTOUT) W *7,!,"You have timed out "
. E W *7,!,"You have escaped "
. W "and may need to edit this inventory point using the"
. W !,"'Enter/Edit Inventory and Distribution Points' option under 'Secondary",!,"Inventory Point Main Menu' to restore order."
. W ! D HOLD K ^PRCP(445,INVPT,"SEC"),^("SECMIS")
S DR=".7///^S X=""P""" D ^DIE K DR
S DIK="^PRCP(445,"_PRCP("I")_",2,",DA(1)=PRCP("I"),DA=INVPT D ^DIK K DIK ; remove the secondary as a distribution point
K ^PRCP(445,INVPT,1,"AC") ; sub-file x-ref on mand source
S PRCPINPT=INVPT,PRCPTYPE="P",PRCP("CONVRT")=1 D FCP^PRCPENE1
;
ITEMS W !!!?30,"Converting Items"
S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,INVPT,1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
S ITEMDA=0 F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D Q:$G(ESCAPE) D IPVND Q:$G(ESCAPE)
. S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. S ^PRCP(445,INVPT,"SECITM",ITEMDA,0)=$G(^PRCP(445,INVPT,1,ITEMDA,0))
. S %X="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,",%Y="^PRCP(445,"_INVPT_",""SECITM"","_ITEMDA_",5," D %XY^%RCR
. K ^PRCP(445,INVPT,1,ITEMDA,5) ; clear data that may not be overwritten
. ; by conversion process
. S $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),U,12) ; mandatory source from prcp("i")
. I $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12) D
.. S DA=ITEMDA,DA(1)=INVPT,DIK="^PRCP(445,"_DA(1)_",1,",DIK(1)=".4"
.. D EN1^DIK K DIK ; re-xref by mand source
. I $O(^PRCP(445,PRCP("I"),1,ITEMDA,5,0)) S %X="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",5,",%Y="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5," D %XY^%RCR D D MNDSRC Q
.. S VENDA=0 F S VENDA=$O(^PRCP(445,INVPT,1,ITEMDA,5,VENDA)) Q:'VENDA S DATA=^(VENDA,0),VENDATA=$G(^PRC(441,ITEMDA,2,VENDA,0)) D
... S UP=$$UNITVAL^PRCPUX1($P(VENDATA,U,8),$P(VENDATA,U,7),""),UR=$$UNITVAL^PRCPUX1($P(DATA,U,3),$P(DATA,U,2),"")
... I UP'=UR,UP'["?" S $P(DATA,U,3)=$P(VENDATA,U,8),$P(DATA,U,2)=$P(VENDATA,U,7)
... I '$P(DATA,U,4) S PRC=$P($G(^PRCP(445,INVPT,1,ITEMDA,0)),U,14) S:PRC="" PRC=1 S $P(DATA,U,4)=($P(DATA,U,3)/PRC)\1 S:'$P(DATA,U,4) $P(DATA,U,4)=1
... S ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
. ;
. ; will have to go to the item master
. S VENDA=$P($G(^PRC(441,ITEMDA,0)),U,8) I VENDA S $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=VENDA_";PRC(440,",VENDATA=$G(^PRC(441,ITEMDA,2,VENDA,0)) D S ESCAPE=1 Q
.. D ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",$P(VENDATA,U,7),$P(VENDATA,U,8),$P(VENDATA,U,10))
.. S DA=ITEMDA,DA(1)=INVPT,DIK="^PRCP(445,"_DA(1)_",1,",DIK(1)=.4 D EN1^DIK K DIK ; x-ref new mandatory source
. S VENDA=0 F S VENDA=$O(^PRC(441,ITEMDA,2,VENDA)) Q:'VENDA S VENDATA=$G(^PRC(441,ITEMDA,2,VENDA,0)) D
.. D ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",$P(VENDATA,U,7),$P(VENDATA,U,8),$P(VENDATA,U,10))
;
LEVELS ; change the stock levels?
W ! S DIR(0)="Y",DIR("A")="Would you like to edit item levels and/or mandatory source",DIR("B")="NO"
S DIR("?",1)="Enter 'YES' if you would like to edit the NORMAL STOCK LEVEL, EMERGENCY"
S DIR("?",2)="STOCK LEVEL, TEMPORARY STOCK LEVEL, STANDARD REORDER POINT, OPTIONAL REORDER"
S DIR("?",3)="POINT, and/or MANDATORY SOURCE for some or all of the items in this"
S DIR("?")="inventory point."
D ^DIR K DIR I $D(DIRUT) Q
I 'Y W !!,"Conversion Completed !" Q ; leave everything as it was when inventory point was secondary
;
; can either step thru the inventory point or prompt for lookups
;
S DIR(0)="SOM^1:Prompt for ITEMS that may need changes;2:Display all ITEMS and prompt for changes",DIR("A")="How shall items be presented? "
S DIR("B")="1"
S DIR("?",1)="Enter '2' if you want the system to step through the inventory point and"
S DIR("?")="prompt you for changes to all of the items."
D ^DIR K DIR Q:$D(DIRUT)
S DIE="^PRCP(445,",DR="[PRCP LEVELS]"
I Y=2 D W !!?10,"<Done>" D HOLD Q ; step thru inventory point
. S ITEMDA=0 F D:ITEMDA HOLD S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA!($G(ESCAPE)) I $D(^(ITEMDA,0)) D EDIT Q:$G(ESCAPE)
; prompt for user lookups
S DIC("S")="I $D(^PRCP(445,INVPT,1,+Y,0))"
F W !! S DIC="^PRCP(445,"_INVPT_",1,",DIC(0)="AEQM" D ^DIC Q:Y'>0 S ITEMDA=+Y D EDIT Q:$G(ESCAPE)
W !!?10,"<Done>" D HOLD
Q ; end user lookups
;
EDIT ; edit stock levels
W !!,"ITEM MASTER #: "_ITEMDA,?30,$E($P($G(^PRCP(445,INVPT,1,ITEMDA,6)),U),1,50)
W ! S DA=INVPT,PRCPITEM=$C(96)_ITEMDA
D ^DIE I $D(DTOUT) S ESCAPE=1
Q
;
IPVND ; add old 'stocked by' inv pt as vendor if appropriate
; try to find it in the vendor file
S PRIM(0)=$P(PRIM,"-",2) S IPVND("DA")=$O(^PRC(440,"B",PRIM(0),0)) I '$G(IPVND("DA")) S IPVND("DA")=$O(^PRC(440,"C",PRIM(0),0))
Q:'$G(IPVND("DA")) S PRCP("DA")=0 F S PRCP("DA")=$O(^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"))) Q:'PRCP("DA")!(+^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"),0)=PRCP("I"))
D:PRCP("DA") ; if it's there, add it
. S DATA=$G(^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"),0))
. D ADDVEN^PRCPUVEN(INVPT,ITEMDA,IPVND("DA")_";PRC(440,",$P(DATA,U,2),$P(DATA,U,3),$P(DATA,U,4))
. I '$D(^PRC(441,ITEMDA,2,"B",IPVND("DA"),0)) D
.. N DIC,DA,DLAYGO,DD,DO,DINUM
.. S DIC="^PRC(441,ITEMDA,2,",(X,DINUM)=IPVND("DA"),DA(1)=ITEMDA,DIC(0)="L",DLAYGO=441,DIC("P")=$P(^DD(441,6,0),U,2)
.. D FILE^DICN
Q
;
MNDSRC ; look for mand srce in imf if not picked up from prcp("i")
Q:$P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)]"" ; already have it
S PRCP("MS")=$P($G(^PRC(441,ITEMDA,0)),U,8)_";PRC(440,"
I +PRCP("MS"),('$D(^PRCP(445,INVPT,1,ITEMDA,5,"B",PRCP("MS")))) D
. S IMFDATA=$G(^PRC(441,ITEMDA,2,+PRCP("MS"),0))
. D ADDVEN^PRCPUVEN(INVPT,ITEMDA,PRCP("MS"),$P(IMFDATA,U,7),$P(IMFDATA,U,8),$P(IMFDATA,U,10))
I +PRCP("MS") S $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=PRCP("MS"),DA=ITEMDA,DA(1)=INVPT,DIK="^PRCP(445,"_DA(1)_",1,",DIK(1)=.4 D EN1^DIK K DIK ; set mand srce and x-ref
Q
;
HOLD W !!,"Press <RETURN> to continue, '^' to escape..." R X:DTIME
I '$T!($E(X)="^") S ESCAPE=1
Q
;PRCPCSP1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCSP1 6967 printed Dec 13, 2024@02:13:19 Page 2
PRCPCSP1 ;WISC/RFJ/DXH - convert secondary to primary ;10.14.99
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CONVRT WRITE !!,"Preparing to convert: "_$$INVNAME^PRCPUX1(INVPT)_" to a primary."
+1 KILL XP,XH
SET XP="Are you sure this is what you want to do"
SET XH="Enter YES to start converting, NO or ^ to exit."
+2 IF $$YN^PRCPUYN(2)'=1
SET ESCAPE=1
QUIT
+3 ;
+4 LOCK +^PRCP(445,INVPT):5
IF '$TEST
WRITE !,"Sorry, another user is editing this inventory point. Please try again later."
SET ESCAPE=1
QUIT
+5 ; store some data in case user decides to 'undo' conversion
+6 SET ^PRCP(445,INVPT,"SEC")=^PRCP(445,INVPT,0)_"|"_$GET(DUZ)_"|"_$GET(DT)_"|"_PRCP("I")
+7 ; mis costing sections
IF $ORDER(^PRCP(445,INVPT,3,0))
SET %X="^PRCP(445,"_INVPT_",3,"
SET %Y="^PRCP(445,"_INVPT_",""SECMIS"","
DO %XY^%RCR
+8 SET DIE="^PRCP(445,"
SET DA=INVPT
+9 SET DR=".5;.6;.9"
DO ^DIE
KILL DR
IF $DATA(DTOUT)!($DATA(Y))
Begin DoDot:1
+10 IF $DATA(DTOUT)
WRITE *7,!,"You have timed out "
+11 IF '$TEST
WRITE *7,!,"You have escaped "
+12 WRITE "and may need to edit this inventory point using the"
+13 WRITE !,"'Enter/Edit Inventory and Distribution Points' option under 'Secondary",!,"Inventory Point Main Menu' to restore order."
+14 WRITE !
DO HOLD
KILL ^PRCP(445,INVPT,"SEC"),^("SECMIS")
End DoDot:1
LOCK -^PRCP(445,INVPT)
QUIT
+15 SET DR=".7///^S X=""P"""
DO ^DIE
KILL DR
+16 ; remove the secondary as a distribution point
SET DIK="^PRCP(445,"_PRCP("I")_",2,"
SET DA(1)=PRCP("I")
SET DA=INVPT
DO ^DIK
KILL DIK
+17 ; sub-file x-ref on mand source
KILL ^PRCP(445,INVPT,1,"AC")
+18 SET PRCPINPT=INVPT
SET PRCPTYPE="P"
SET PRCP("CONVRT")=1
DO FCP^PRCPENE1
+19 ;
ITEMS WRITE !!!?30,"Converting Items"
+1 SET EACHONE=$$INPERCNT^PRCPUX2(+$PIECE($GET(^PRCP(445,INVPT,1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
+2 SET ITEMDA=0
FOR NUMBER=1:1
SET ITEMDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA))
if 'ITEMDA
QUIT
SET DATA=$GET(^(ITEMDA,0))
IF DATA'=""
Begin DoDot:1
+3 SET LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
+4 SET ^PRCP(445,INVPT,"SECITM",ITEMDA,0)=$GET(^PRCP(445,INVPT,1,ITEMDA,0))
+5 SET %X="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,"
SET %Y="^PRCP(445,"_INVPT_",""SECITM"","_ITEMDA_",5,"
DO %XY^%RCR
+6 ; clear data that may not be overwritten
KILL ^PRCP(445,INVPT,1,ITEMDA,5)
+7 ; by conversion process
+8 ; mandatory source from prcp("i")
SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=$PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,0)),U,12)
+9 IF $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),U,12)
Begin DoDot:2
+10 SET DA=ITEMDA
SET DA(1)=INVPT
SET DIK="^PRCP(445,"_DA(1)_",1,"
SET DIK(1)=".4"
+11 ; re-xref by mand source
DO EN1^DIK
KILL DIK
End DoDot:2
+12 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,5,0))
SET %X="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",5,"
SET %Y="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,"
DO %XY^%RCR
Begin DoDot:2
+13 SET VENDA=0
FOR
SET VENDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA,5,VENDA))
if 'VENDA
QUIT
SET DATA=^(VENDA,0)
SET VENDATA=$GET(^PRC(441,ITEMDA,2,VENDA,0))
Begin DoDot:3
+14 SET UP=$$UNITVAL^PRCPUX1($PIECE(VENDATA,U,8),$PIECE(VENDATA,U,7),"")
SET UR=$$UNITVAL^PRCPUX1($PIECE(DATA,U,3),$PIECE(DATA,U,2),"")
+15 IF UP'=UR
IF UP'["?"
SET $PIECE(DATA,U,3)=$PIECE(VENDATA,U,8)
SET $PIECE(DATA,U,2)=$PIECE(VENDATA,U,7)
+16 IF '$PIECE(DATA,U,4)
SET PRC=$PIECE($GET(^PRCP(445,INVPT,1,ITEMDA,0)),U,14)
if PRC=""
SET PRC=1
SET $PIECE(DATA,U,4)=($PIECE(DATA,U,3)/PRC)\1
if '$PIECE(DATA,U,4)
SET $PIECE(DATA,U,4)=1
+17 SET ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
End DoDot:3
End DoDot:2
DO MNDSRC
QUIT
+18 ;
+19 ; will have to go to the item master
+20 SET VENDA=$PIECE($GET(^PRC(441,ITEMDA,0)),U,8)
IF VENDA
SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=VENDA_";PRC(440,"
SET VENDATA=$GET(^PRC(441,ITEMDA,2,VENDA,0))
Begin DoDot:2
+21 DO ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",$PIECE(VENDATA,U,7),$PIECE(VENDATA,U,8),$PIECE(VENDATA,U,10))
+22 ; x-ref new mandatory source
SET DA=ITEMDA
SET DA(1)=INVPT
SET DIK="^PRCP(445,"_DA(1)_",1,"
SET DIK(1)=.4
DO EN1^DIK
KILL DIK
End DoDot:2
SET ESCAPE=1
QUIT
+23 SET VENDA=0
FOR
SET VENDA=$ORDER(^PRC(441,ITEMDA,2,VENDA))
if 'VENDA
QUIT
SET VENDATA=$GET(^PRC(441,ITEMDA,2,VENDA,0))
Begin DoDot:2
+24 DO ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",$PIECE(VENDATA,U,7),$PIECE(VENDATA,U,8),$PIECE(VENDATA,U,10))
End DoDot:2
End DoDot:1
if $GET(ESCAPE)
QUIT
DO IPVND
if $GET(ESCAPE)
QUIT
+25 ;
LEVELS ; change the stock levels?
+1 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Would you like to edit item levels and/or mandatory source"
SET DIR("B")="NO"
+2 SET DIR("?",1)="Enter 'YES' if you would like to edit the NORMAL STOCK LEVEL, EMERGENCY"
+3 SET DIR("?",2)="STOCK LEVEL, TEMPORARY STOCK LEVEL, STANDARD REORDER POINT, OPTIONAL REORDER"
+4 SET DIR("?",3)="POINT, and/or MANDATORY SOURCE for some or all of the items in this"
+5 SET DIR("?")="inventory point."
+6 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+7 ; leave everything as it was when inventory point was secondary
IF 'Y
WRITE !!,"Conversion Completed !"
QUIT
+8 ;
+9 ; can either step thru the inventory point or prompt for lookups
+10 ;
+11 SET DIR(0)="SOM^1:Prompt for ITEMS that may need changes;2:Display all ITEMS and prompt for changes"
SET DIR("A")="How shall items be presented? "
+12 SET DIR("B")="1"
+13 SET DIR("?",1)="Enter '2' if you want the system to step through the inventory point and"
+14 SET DIR("?")="prompt you for changes to all of the items."
+15 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+16 SET DIE="^PRCP(445,"
SET DR="[PRCP LEVELS]"
+17 ; step thru inventory point
IF Y=2
Begin DoDot:1
+18 SET ITEMDA=0
FOR
if ITEMDA
DO HOLD
SET ITEMDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA))
if 'ITEMDA!($GET(ESCAPE))
QUIT
IF $DATA(^(ITEMDA,0))
DO EDIT
if $GET(ESCAPE)
QUIT
End DoDot:1
WRITE !!?10,"<Done>"
DO HOLD
QUIT
+19 ; prompt for user lookups
+20 SET DIC("S")="I $D(^PRCP(445,INVPT,1,+Y,0))"
+21 FOR
WRITE !!
SET DIC="^PRCP(445,"_INVPT_",1,"
SET DIC(0)="AEQM"
DO ^DIC
if Y'>0
QUIT
SET ITEMDA=+Y
DO EDIT
if $GET(ESCAPE)
QUIT
+22 WRITE !!?10,"<Done>"
DO HOLD
+23 ; end user lookups
QUIT
+24 ;
EDIT ; edit stock levels
+1 WRITE !!,"ITEM MASTER #: "_ITEMDA,?30,$EXTRACT($PIECE($GET(^PRCP(445,INVPT,1,ITEMDA,6)),U),1,50)
+2 WRITE !
SET DA=INVPT
SET PRCPITEM=$CHAR(96)_ITEMDA
+3 DO ^DIE
IF $DATA(DTOUT)
SET ESCAPE=1
+4 QUIT
+5 ;
IPVND ; add old 'stocked by' inv pt as vendor if appropriate
+1 ; try to find it in the vendor file
+2 SET PRIM(0)=$PIECE(PRIM,"-",2)
SET IPVND("DA")=$ORDER(^PRC(440,"B",PRIM(0),0))
IF '$GET(IPVND("DA"))
SET IPVND("DA")=$ORDER(^PRC(440,"C",PRIM(0),0))
+3 if '$GET(IPVND("DA"))
QUIT
SET PRCP("DA")=0
FOR
SET PRCP("DA")=$ORDER(^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA")))
if 'PRCP("DA")!(+^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"),0)=PRCP("I"))
QUIT
+4 ; if it's there, add it
if PRCP("DA")
Begin DoDot:1
+5 SET DATA=$GET(^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"),0))
+6 DO ADDVEN^PRCPUVEN(INVPT,ITEMDA,IPVND("DA")_";PRC(440,",$PIECE(DATA,U,2),$PIECE(DATA,U,3),$PIECE(DATA,U,4))
+7 IF '$DATA(^PRC(441,ITEMDA,2,"B",IPVND("DA"),0))
Begin DoDot:2
+8 NEW DIC,DA,DLAYGO,DD,DO,DINUM
+9 SET DIC="^PRC(441,ITEMDA,2,"
SET (X,DINUM)=IPVND("DA")
SET DA(1)=ITEMDA
SET DIC(0)="L"
SET DLAYGO=441
SET DIC("P")=$PIECE(^DD(441,6,0),U,2)
+10 DO FILE^DICN
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
MNDSRC ; look for mand srce in imf if not picked up from prcp("i")
+1 ; already have it
if $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),U,12)]""
QUIT
+2 SET PRCP("MS")=$PIECE($GET(^PRC(441,ITEMDA,0)),U,8)_";PRC(440,"
+3 IF +PRCP("MS")
IF ('$DATA(^PRCP(445,INVPT,1,ITEMDA,5,"B",PRCP("MS"))))
Begin DoDot:1
+4 SET IMFDATA=$GET(^PRC(441,ITEMDA,2,+PRCP("MS"),0))
+5 DO ADDVEN^PRCPUVEN(INVPT,ITEMDA,PRCP("MS"),$PIECE(IMFDATA,U,7),$PIECE(IMFDATA,U,8),$PIECE(IMFDATA,U,10))
End DoDot:1
+6 ; set mand srce and x-ref
IF +PRCP("MS")
SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=PRCP("MS")
SET DA=ITEMDA
SET DA(1)=INVPT
SET DIK="^PRCP(445,"_DA(1)_",1,"
SET DIK(1)=.4
DO EN1^DIK
KILL DIK
+7 QUIT
+8 ;
HOLD WRITE !!,"Press <RETURN> to continue, '^' to escape..."
READ X:DTIME
+1 IF '$TEST!($EXTRACT(X)="^")
SET ESCAPE=1
+2 QUIT
+3 ;PRCPCSP1
