PRCHEA1 ;SF-ISC/TKW/DST/AS-MORE EDIT ROUTINES FOR SUPPLY SYSTEM ;3/17/17 18:48
V ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
;Per VA Directive 6402, this routine should not be modified.
;
EN0 ;REACTIVATE VENDOR
;
S PRCHREAV="I $D(^(10)),$P(^(10),U,5)"
S DIC="^PRC(440,"
S DIE=DIC
S DIC(0)="AEMQZ",DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
D ^DIC
G Q:Y<0
S DA=+Y
L +^PRC(440,DA):0 E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
G Q:'$D(DA)
;
;NOW THE RECORD IS LOCKED
;
S PRCHY=$P(Y(0),U,1)
I $E(PRCHY,1,2)="**" S PRCHY=$E(PRCHY,3,99)
S IEN=" "_DA
S IEN=$E(IEN,$L(IEN)-5,99)
W !,"Sure you want to RE-activate Vendor "_PRCHY_", NO:"_IEN
S %B=""
S %=2
D ^PRCFYN
I %=1 D
. S DR=".01////^S X=PRCHY;15////@;31.5////@"
. D ^DIE
. ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
. D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(DA)
. Q
;
;UNLOCK THE RECORD
;
L -^PRC(440,DA)
D Q
G EN0
;
EN1 ;INACTIVATE VENDOR
;
K PRCHREAV
I '$D(DT) D
. D NOW^%DTC
. S DT=$P(%,".",1)
. Q
N DIC
S DIC="^PRC(440,"
S DIC(0)="AEMQZ",DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
D ^DIC
G Q:Y<0
I $D(^PRC(440,+Y,10)),$P(^(10),U,5)=1 W $C(7),!,"Please choose another vendor that is not inactivated." G EN1
S (PRCHOLD,DA)=+Y
S PRCHY=$P(Y(0),U,1)
L +^PRC(440,DA):0 E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
G Q:'$D(DA)
;
;NOW THE RECORD IS LOCKED
;
W !!,"Enter the Vendor you want to substitute for the inactivated vendor "
S DIC("S")="I $S(PRCHOLD=+Y:0,'$D(^(10)):1,+$P(^(10),U,5)=0:1,1:0)"
S DIC("A")="Select REPLACEMENT VENDOR: "
S PRCHX=""
S PRCHY="**"_$E($P(Y(0),U,1),1,34)
D ^DIC
S:Y>0 PRCHX=+Y
S IENS=" "_PRCHX
S IENS=$E(IENS,$L(IENS)-5,99)
S IENO=" "_PRCHOLD
S IENO=$E(IENO,$L(IENO)-5,99)
W !!,"Sure you want to inactivate Vendor "_$P(^PRC(440,PRCHOLD,0),U)_", NO:"_IENO
W:PRCHX !," and substitute vendor "_$P(^PRC(440,PRCHX,0),U)_", NO:"_IENS
S %B=""
S %=2
D ^PRCFYN
I %=1 D
. S DIE="^PRC(440,"
. S DA=PRCHOLD
. S DR=".01////^S X=PRCHY;15////^S X=PRCHX;31.5///^S X=1"
. D ^DIE
. ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
. D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(DA)
. Q
;
;UNLOCK THE RECORD
;
L -^PRC(440,DA)
D Q
G EN1
;
EN2 ;INACTIVATE ITEM
;
K PRCHREAV
I '$D(DT) D
. D NOW^%DTC
. S DT=$P(%,".",1)
. Q
K DIC
S DIC="^PRC(441,"
S DIC(0)="AEMQZ",DIC("S")="I (+Y<20000000)!$D(^XUSEC(""PRCHITEM SUPER"",DUZ))"
D ^DIC
G Q:Y<0
I $P(Y(0),"^",2)["*" W $C(7),!," ITEM ALREADY INACTIVE" G EN2
S DA=+Y
L +^PRC(441,DA):0 E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
G Q:'$D(DA)
;
;NOW THE RECORD IS LOCKED
;
S PRCHOLD=DA
W !!,"Enter the item you want to substitute for the inactivated item "
S DIC("A")="SELECT Substitute Item: "
S PRCHY="**"_$E($P(Y(0),U,2),1,58)
D ^DIC
S PRCHZ=$S(+Y>0:+Y,1:"")
W !!,"Sure you want to inactivate Item ",PRCHOLD
W:+Y>0 " and substitute Item ",+Y
S %B=""
S %=2
D ^PRCFYN
I %=1 D
. S DIE="^PRC(441,"
. S DA=PRCHOLD
. S DR=".05////^S X=PRCHY;16////^S X=1"
. S:PRCHZ DR=DR_";16.5////^S X=PRCHZ"
. D ^DIE
. ; Send ITEM Master File updated info to DYNAMED
. D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 ONECHK^PRCVIT(DA)
. Q
;
;UNLOCK THE RECORD
;
L -^PRC(441,DA)
D Q
G EN2
;
EN3 ;REACTIVATE ITEM
;
S PRCHREAV="I $D(^(3)),+^(3)"
S DIC="^PRC(441,"
S DIE=DIC
S DIC(0)="AEMQZ",DIC("S")="I (+Y<20000000)!$D(^XUSEC(""PRCHITEM SUPER"",DUZ))"
D ^DIC
G Q:Y<0
S DA=+Y
L +^PRC(441,DA):0 E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
G Q:'$D(DA)
;
;NOW THE RECORD IS LOCKED
;
S PRCHY=$P(Y(0),U,2)
I $E(PRCHY,1,2)="**" S PRCHY=$E(PRCHY,3,99)
W !,"Sure you want to RE-activate Item number ",DA
S %B=""
S %=2
D ^PRCFYN
I %=1 D
. S DR=".05////^S X=PRCHY;16////@;16.5////@"
. D ^DIE
. ; Send ITEM Master File updated info to DYNAMED
. D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 ONECHK^PRCVIT(DA)
. Q
;
;UNLOCK THE RECORD
;
L -^PRC(441,DA)
D Q
G EN3
;
Q K DIC,DIE,DR,DA,PRCHOLD,PRCHREAV,PRCHX,PRCHY,PRCHZ
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHEA1 4323 printed Apr 09, 2024@21:11:47 Page 2
PRCHEA1 ;SF-ISC/TKW/DST/AS-MORE EDIT ROUTINES FOR SUPPLY SYSTEM ;3/17/17 18:48
V ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
EN0 ;REACTIVATE VENDOR
+1 ;
+2 SET PRCHREAV="I $D(^(10)),$P(^(10),U,5)"
+3 SET DIC="^PRC(440,"
+4 SET DIE=DIC
+5 SET DIC(0)="AEMQZ"
SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
+6 DO ^DIC
+7 if Y<0
GOTO Q
+8 SET DA=+Y
+9 LOCK +^PRC(440,DA):0
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+10 if '$DATA(DA)
GOTO Q
+11 ;
+12 ;NOW THE RECORD IS LOCKED
+13 ;
+14 SET PRCHY=$PIECE(Y(0),U,1)
+15 IF $EXTRACT(PRCHY,1,2)="**"
SET PRCHY=$EXTRACT(PRCHY,3,99)
+16 SET IEN=" "_DA
+17 SET IEN=$EXTRACT(IEN,$LENGTH(IEN)-5,99)
+18 WRITE !,"Sure you want to RE-activate Vendor "_PRCHY_", NO:"_IEN
+19 SET %B=""
+20 SET %=2
+21 DO ^PRCFYN
+22 IF %=1
Begin DoDot:1
+23 SET DR=".01////^S X=PRCHY;15////@;31.5////@"
+24 DO ^DIE
+25 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
+26 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
DO ONECHK^PRCVNDR(DA)
+27 QUIT
End DoDot:1
+28 ;
+29 ;UNLOCK THE RECORD
+30 ;
+31 LOCK -^PRC(440,DA)
+32 DO Q
+33 GOTO EN0
+34 ;
EN1 ;INACTIVATE VENDOR
+1 ;
+2 KILL PRCHREAV
+3 IF '$DATA(DT)
Begin DoDot:1
+4 DO NOW^%DTC
+5 SET DT=$PIECE(%,".",1)
+6 QUIT
End DoDot:1
+7 NEW DIC
+8 SET DIC="^PRC(440,"
+9 SET DIC(0)="AEMQZ"
SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
+10 DO ^DIC
+11 if Y<0
GOTO Q
+12 IF $DATA(^PRC(440,+Y,10))
IF $PIECE(^(10),U,5)=1
WRITE $CHAR(7),!,"Please choose another vendor that is not inactivated."
GOTO EN1
+13 SET (PRCHOLD,DA)=+Y
+14 SET PRCHY=$PIECE(Y(0),U,1)
+15 LOCK +^PRC(440,DA):0
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+16 if '$DATA(DA)
GOTO Q
+17 ;
+18 ;NOW THE RECORD IS LOCKED
+19 ;
+20 WRITE !!,"Enter the Vendor you want to substitute for the inactivated vendor "
+21 SET DIC("S")="I $S(PRCHOLD=+Y:0,'$D(^(10)):1,+$P(^(10),U,5)=0:1,1:0)"
+22 SET DIC("A")="Select REPLACEMENT VENDOR: "
+23 SET PRCHX=""
+24 SET PRCHY="**"_$EXTRACT($PIECE(Y(0),U,1),1,34)
+25 DO ^DIC
+26 if Y>0
SET PRCHX=+Y
+27 SET IENS=" "_PRCHX
+28 SET IENS=$EXTRACT(IENS,$LENGTH(IENS)-5,99)
+29 SET IENO=" "_PRCHOLD
+30 SET IENO=$EXTRACT(IENO,$LENGTH(IENO)-5,99)
+31 WRITE !!,"Sure you want to inactivate Vendor "_$PIECE(^PRC(440,PRCHOLD,0),U)_", NO:"_IENO
+32 if PRCHX
WRITE !," and substitute vendor "_$PIECE(^PRC(440,PRCHX,0),U)_", NO:"_IENS
+33 SET %B=""
+34 SET %=2
+35 DO ^PRCFYN
+36 IF %=1
Begin DoDot:1
+37 SET DIE="^PRC(440,"
+38 SET DA=PRCHOLD
+39 SET DR=".01////^S X=PRCHY;15////^S X=PRCHX;31.5///^S X=1"
+40 DO ^DIE
+41 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
+42 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
DO ONECHK^PRCVNDR(DA)
+43 QUIT
End DoDot:1
+44 ;
+45 ;UNLOCK THE RECORD
+46 ;
+47 LOCK -^PRC(440,DA)
+48 DO Q
+49 GOTO EN1
+50 ;
EN2 ;INACTIVATE ITEM
+1 ;
+2 KILL PRCHREAV
+3 IF '$DATA(DT)
Begin DoDot:1
+4 DO NOW^%DTC
+5 SET DT=$PIECE(%,".",1)
+6 QUIT
End DoDot:1
+7 KILL DIC
+8 SET DIC="^PRC(441,"
+9 SET DIC(0)="AEMQZ"
SET DIC("S")="I (+Y<20000000)!$D(^XUSEC(""PRCHITEM SUPER"",DUZ))"
+10 DO ^DIC
+11 if Y<0
GOTO Q
+12 IF $PIECE(Y(0),"^",2)["*"
WRITE $CHAR(7),!," ITEM ALREADY INACTIVE"
GOTO EN2
+13 SET DA=+Y
+14 LOCK +^PRC(441,DA):0
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+15 if '$DATA(DA)
GOTO Q
+16 ;
+17 ;NOW THE RECORD IS LOCKED
+18 ;
+19 SET PRCHOLD=DA
+20 WRITE !!,"Enter the item you want to substitute for the inactivated item "
+21 SET DIC("A")="SELECT Substitute Item: "
+22 SET PRCHY="**"_$EXTRACT($PIECE(Y(0),U,2),1,58)
+23 DO ^DIC
+24 SET PRCHZ=$SELECT(+Y>0:+Y,1:"")
+25 WRITE !!,"Sure you want to inactivate Item ",PRCHOLD
+26 if +Y>0
WRITE " and substitute Item ",+Y
+27 SET %B=""
+28 SET %=2
+29 DO ^PRCFYN
+30 IF %=1
Begin DoDot:1
+31 SET DIE="^PRC(441,"
+32 SET DA=PRCHOLD
+33 SET DR=".05////^S X=PRCHY;16////^S X=1"
+34 if PRCHZ
SET DR=DR_";16.5////^S X=PRCHZ"
+35 DO ^DIE
+36 ; Send ITEM Master File updated info to DYNAMED
+37 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
DO ONECHK^PRCVIT(DA)
+38 QUIT
End DoDot:1
+39 ;
+40 ;UNLOCK THE RECORD
+41 ;
+42 LOCK -^PRC(441,DA)
+43 DO Q
+44 GOTO EN2
+45 ;
EN3 ;REACTIVATE ITEM
+1 ;
+2 SET PRCHREAV="I $D(^(3)),+^(3)"
+3 SET DIC="^PRC(441,"
+4 SET DIE=DIC
+5 SET DIC(0)="AEMQZ"
SET DIC("S")="I (+Y<20000000)!$D(^XUSEC(""PRCHITEM SUPER"",DUZ))"
+6 DO ^DIC
+7 if Y<0
GOTO Q
+8 SET DA=+Y
+9 LOCK +^PRC(441,DA):0
IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+10 if '$DATA(DA)
GOTO Q
+11 ;
+12 ;NOW THE RECORD IS LOCKED
+13 ;
+14 SET PRCHY=$PIECE(Y(0),U,2)
+15 IF $EXTRACT(PRCHY,1,2)="**"
SET PRCHY=$EXTRACT(PRCHY,3,99)
+16 WRITE !,"Sure you want to RE-activate Item number ",DA
+17 SET %B=""
+18 SET %=2
+19 DO ^PRCFYN
+20 IF %=1
Begin DoDot:1
+21 SET DR=".05////^S X=PRCHY;16////@;16.5////@"
+22 DO ^DIE
+23 ; Send ITEM Master File updated info to DYNAMED
+24 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
DO ONECHK^PRCVIT(DA)
+25 QUIT
End DoDot:1
+26 ;
+27 ;UNLOCK THE RECORD
+28 ;
+29 LOCK -^PRC(441,DA)
+30 DO Q
+31 GOTO EN3
+32 ;
Q KILL DIC,DIE,DR,DA,PRCHOLD,PRCHREAV,PRCHX,PRCHY,PRCHZ
+1 WRITE !
+2 QUIT
