PRCPCSPX ;WISC/DXH - undo secondary to primary conversion ;10.7.99
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; expects prcp("i") as ien of inv pt to be undone
EN ;
N D0,DA,DATA,DI,DIC,DIE,DIR,DQ,DR,EACHONE,ITEMCNT,ITEMDA,LASTONE,NUMBER,PIECE,INVPT,VENDOR,X,Y,XP,XH,ESCAPE,PRIM,VENDA,VENDATA,STKDBY,FCPDA,NODEDA
S PRIM=$$INVNAME^PRCPUX1(PRCP("I"))
I '$D(^PRCP(445,PRCP("I"),"SEC")) W !!,"Inventory Point "_PRIM_" was never converted.",!,"Data base unchanged.",*7 D HOLD Q
S PRC=^PRCP(445,PRCP("I"),"SEC"),USER=$P(PRC,"|",2),DATE=$P(PRC,"|",3),NODE=$P(PRC,"|"),STCKDBY=$P(PRC,"|",4)
I USER,$G(^VA(200,USER,0))]"" S USERNM=$$GET1^DIQ(200,USER,.01)
I $G(USERNM)]"" D
. I DATE S Y=DATE X ^DD("DD") S DATEXT=Y
. W !!,"Inventory Point "_PRIM_" was converted to a primary by "
. W !,USERNM W:$G(DATEXT)]"" " on "_DATEXT W "."
S DA=0 F S DA=$O(^PRCP(445,PRCP("I"),1,DA)) Q:$G(ESCAPE)!('DA) D
. I $O(^PRCP(445,PRCP("I"),1,DA,7,0)) S ESCAPE=1
I $G(ESCAPE) W !!,"Inventory Point "_PRIM_" has at least one OUTSTANDING REQUEST",!,"It can not be converted and the data base remains unchanged.",*7 D HOLD Q
W !! K X S X(1)="This option will change "_PRIM_" from a primary to a secondary.",X(2)="INVENTORY PARAMETERS, STOCK LEVELS, MANDATORY SOURCES, and PROCUREMENT SOURCES"
S X(3)="will be restored to whatever they were when this Inventory Point was converted"
I $G(DATEXT)]"" S X(4)="on "_DATEXT_"."
E S X(3)=X(3)_"."
D DISPLAY^PRCPUX2(10,75,.X)
W !!,"Preparing to convert "_PRIM_" back to a secondary."
K XP,XH S XP="Are you sure you want to do that",XH="Enter 'YES' to start the conversion, NO or '^' to escape."
I $$YN^PRCPUYN(2)'=1 Q
;
CONVRT W !!!?20,"Converting "_PRIM_"."
S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),U,4),"*",PRCP("RV1"),PRCP("RV0"))
S DIE="^PRCP(445,",DA=PRCP("I"),DR=".7///^S X=""S""" D ^DIE K DR
S ^PRCP(445,PRCP("I"),0)=NODE ; it's a secondary again
K ^PRCP(445,PRCP("I"),1,"AC") ; existing x-ref won't work for secondary
S ITEMDA=0 F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $G(^(ITEMDA,0))'="" D
. S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. I '$D(^PRCP(445,PRCP("I"),"SECITM",ITEMDA)) D Q
.. ; delete line items added since conversion
.. S DIK="^PRCP(445,"_PRCP("I")_",1,",DA(1)=PRCP("I"),DA=ITEMDA
.. D ^DIK K DIK
. K ^PRCP(445,PRCP("I"),1,ITEMDA,5) ; won't work for secondary
. S ^PRCP(445,PRCP("I"),1,ITEMDA,0)=^PRCP(445,PRCP("I"),"SECITM",ITEMDA,0)
. S %X="^PRCP(445,"_PRCP("I")_",""SECITM"","_ITEMDA_",5,",%Y="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",5," D %XY^%RCR
. ; x-ref by mandatory source
. I $P(^PRCP(445,PRCP("I"),1,ITEMDA,0),U,12)]"" S DA=ITEMDA,DA(1)=PRCP("I"),DIK="^PRCP(445,"_PRCP("I")_",1,",DIK(1)=.4 D EN1^DIK K DIK
; restore mis costing
I $D(^PRCP(445,PRCP("I"),"SECMIS")) K ^PRCP(445,PRCP("I"),3) S %X="^PRCP(445,"_PRCP("I")_",""SECMIS"",",%Y="^PRCP(445,"_PRCP("I")_",3," D %XY^%RCR
; restore prcp(i) as distribution point for stckdby
I $G(STCKDBY) D
. N DIC,DA,DD,DO,DLAYGO,DINUM
. S DIC="^PRCP(445,"_STCKDBY_",2,",DIC(0)="L",DA(1)=STCKDBY,(X,DINUM)=PRCP("I"),DIC("P")=$P(^DD(445.03,.01,0),U,2),DLAYGO=445
. D FILE^DICN
; delete any dist points
I $D(^PRCP(445,PRCP("I"),2)) D K DIK
. N DA
. S DIK="^PRCP(445,PRCP(""I""),2,",DA(1)=PRCP("I"),DA=0
. F S DA=$O(^PRCP(445,PRCP("I"),2,DA)) Q:'DA D ^DIK
S PRCP("DPTYPE")="S" ; just like in the old days
; unlink fcp(s)
FCP S FCPDA=0 F S FCPDA=$O(^PRC(420,"AE",PRC("SITE"),PRCP("I"),FCPDA)) Q:'FCPDA D DEL^PRCPUFCP(FCPDA,PRCP("I"))
; destroy the evidence
F NODEDA="SEC","SECITM","SECMIS" K ^PRCP(445,PRCP("I"),NODEDA)
D HOLD
Q
;
HOLD ; can get here only from a crt
W !!,"Press <RETURN> to continue..." R X:DTIME
I '$T!($E(X)="^") S ESCAPE=1
Q
;PRCPCSPX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPCSPX 3899 printed Apr 09, 2024@21:09:08 Page 2
PRCPCSPX ;WISC/DXH - undo secondary to primary conversion ;10.7.99
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; expects prcp("i") as ien of inv pt to be undone
EN ;
+1 NEW D0,DA,DATA,DI,DIC,DIE,DIR,DQ,DR,EACHONE,ITEMCNT,ITEMDA,LASTONE,NUMBER,PIECE,INVPT,VENDOR,X,Y,XP,XH,ESCAPE,PRIM,VENDA,VENDATA,STKDBY,FCPDA,NODEDA
+2 SET PRIM=$$INVNAME^PRCPUX1(PRCP("I"))
+3 IF '$DATA(^PRCP(445,PRCP("I"),"SEC"))
WRITE !!,"Inventory Point "_PRIM_" was never converted.",!,"Data base unchanged.",*7
DO HOLD
QUIT
+4 SET PRC=^PRCP(445,PRCP("I"),"SEC")
SET USER=$PIECE(PRC,"|",2)
SET DATE=$PIECE(PRC,"|",3)
SET NODE=$PIECE(PRC,"|")
SET STCKDBY=$PIECE(PRC,"|",4)
+5 IF USER
IF $GET(^VA(200,USER,0))]""
SET USERNM=$$GET1^DIQ(200,USER,.01)
+6 IF $GET(USERNM)]""
Begin DoDot:1
+7 IF DATE
SET Y=DATE
XECUTE ^DD("DD")
SET DATEXT=Y
+8 WRITE !!,"Inventory Point "_PRIM_" was converted to a primary by "
+9 WRITE !,USERNM
if $GET(DATEXT)]""
WRITE " on "_DATEXT
WRITE "."
End DoDot:1
+10 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445,PRCP("I"),1,DA))
if $GET(ESCAPE)!('DA)
QUIT
Begin DoDot:1
+11 IF $ORDER(^PRCP(445,PRCP("I"),1,DA,7,0))
SET ESCAPE=1
End DoDot:1
+12 IF $GET(ESCAPE)
WRITE !!,"Inventory Point "_PRIM_" has at least one OUTSTANDING REQUEST",!,"It can not be converted and the data base remains unchanged.",*7
DO HOLD
QUIT
+13 WRITE !!
KILL X
SET X(1)="This option will change "_PRIM_" from a primary to a secondary."
SET X(2)="INVENTORY PARAMETERS, STOCK LEVELS, MANDATORY SOURCES, and PROCUREMENT SOURCES"
+14 SET X(3)="will be restored to whatever they were when this Inventory Point was converted"
+15 IF $GET(DATEXT)]""
SET X(4)="on "_DATEXT_"."
+16 IF '$TEST
SET X(3)=X(3)_"."
+17 DO DISPLAY^PRCPUX2(10,75,.X)
+18 WRITE !!,"Preparing to convert "_PRIM_" back to a secondary."
+19 KILL XP,XH
SET XP="Are you sure you want to do that"
SET XH="Enter 'YES' to start the conversion, NO or '^' to escape."
+20 IF $$YN^PRCPUYN(2)'=1
QUIT
+21 ;
CONVRT WRITE !!!?20,"Converting "_PRIM_"."
+1 SET EACHONE=$$INPERCNT^PRCPUX2(+$PIECE($GET(^PRCP(445,PRCP("I"),1,0)),U,4),"*",PRCP("RV1"),PRCP("RV0"))
+2 SET DIE="^PRCP(445,"
SET DA=PRCP("I")
SET DR=".7///^S X=""S"""
DO ^DIE
KILL DR
+3 ; it's a secondary again
SET ^PRCP(445,PRCP("I"),0)=NODE
+4 ; existing x-ref won't work for secondary
KILL ^PRCP(445,PRCP("I"),1,"AC")
+5 SET ITEMDA=0
FOR NUMBER=1:1
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
IF $GET(^(ITEMDA,0))'=""
Begin DoDot:1
+6 SET LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
+7 IF '$DATA(^PRCP(445,PRCP("I"),"SECITM",ITEMDA))
Begin DoDot:2
+8 ; delete line items added since conversion
+9 SET DIK="^PRCP(445,"_PRCP("I")_",1,"
SET DA(1)=PRCP("I")
SET DA=ITEMDA
+10 DO ^DIK
KILL DIK
End DoDot:2
QUIT
+11 ; won't work for secondary
KILL ^PRCP(445,PRCP("I"),1,ITEMDA,5)
+12 SET ^PRCP(445,PRCP("I"),1,ITEMDA,0)=^PRCP(445,PRCP("I"),"SECITM",ITEMDA,0)
+13 SET %X="^PRCP(445,"_PRCP("I")_",""SECITM"","_ITEMDA_",5,"
SET %Y="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",5,"
DO %XY^%RCR
+14 ; x-ref by mandatory source
+15 IF $PIECE(^PRCP(445,PRCP("I"),1,ITEMDA,0),U,12)]""
SET DA=ITEMDA
SET DA(1)=PRCP("I")
SET DIK="^PRCP(445,"_PRCP("I")_",1,"
SET DIK(1)=.4
DO EN1^DIK
KILL DIK
End DoDot:1
+16 ; restore mis costing
+17 IF $DATA(^PRCP(445,PRCP("I"),"SECMIS"))
KILL ^PRCP(445,PRCP("I"),3)
SET %X="^PRCP(445,"_PRCP("I")_",""SECMIS"","
SET %Y="^PRCP(445,"_PRCP("I")_",3,"
DO %XY^%RCR
+18 ; restore prcp(i) as distribution point for stckdby
+19 IF $GET(STCKDBY)
Begin DoDot:1
+20 NEW DIC,DA,DD,DO,DLAYGO,DINUM
+21 SET DIC="^PRCP(445,"_STCKDBY_",2,"
SET DIC(0)="L"
SET DA(1)=STCKDBY
SET (X,DINUM)=PRCP("I")
SET DIC("P")=$PIECE(^DD(445.03,.01,0),U,2)
SET DLAYGO=445
+22 DO FILE^DICN
End DoDot:1
+23 ; delete any dist points
+24 IF $DATA(^PRCP(445,PRCP("I"),2))
Begin DoDot:1
+25 NEW DA
+26 SET DIK="^PRCP(445,PRCP(""I""),2,"
SET DA(1)=PRCP("I")
SET DA=0
+27 FOR
SET DA=$ORDER(^PRCP(445,PRCP("I"),2,DA))
if 'DA
QUIT
DO ^DIK
End DoDot:1
KILL DIK
+28 ; just like in the old days
SET PRCP("DPTYPE")="S"
+29 ; unlink fcp(s)
FCP SET FCPDA=0
FOR
SET FCPDA=$ORDER(^PRC(420,"AE",PRC("SITE"),PRCP("I"),FCPDA))
if 'FCPDA
QUIT
DO DEL^PRCPUFCP(FCPDA,PRCP("I"))
+1 ; destroy the evidence
+2 FOR NODEDA="SEC","SECITM","SECMIS"
KILL ^PRCP(445,PRCP("I"),NODEDA)
+3 DO HOLD
+4 QUIT
+5 ;
HOLD ; can get here only from a crt
+1 WRITE !!,"Press <RETURN> to continue..."
READ X:DTIME
+2 IF '$TEST!($EXTRACT(X)="^")
SET ESCAPE=1
+3 QUIT
+4 ;PRCPCSPX
