- 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 Mar 13, 2025@21:18:06 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
