PRCHE1 ;WISC/DJM/BGJ/AS-IFCAP EDIT VENDOR FILE ;3/24/17 12:32
V ;;5.1;IFCAP;**7,59,55,81,198**;Oct 20, 2000;Build 6
;Per VA Directive 6402, this routine should not be modified.
;NEW ENTER/EDIT VENDOR FILE CALLED FROM PRCHPC VEN EDIT OPTION
N %,%X,%Y,DIE,DIK,DIR,DIRUT,DR,PRCF,SITE,DA,PRCHV3,FLAGN,FLAG
N DIC,DLAYGO,IEN,Y,FISCAL,VRQ,STOP,INACT,NAME,EDIT,NEW
N PRCIENB4
;
VEDIT I '$D(PRC("PARAM")) D Q:'%
. S PRCF("X")="AS"
. D ^PRCFSITE
. Q
; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1,$D(IEN) D ONECHK^PRCVNDR(IEN)
S SITE=PRC("SITE")
L +^PRC(440,0):30 S PRCIENB4=$P(^PRC(440,0),U,3) L -^PRC(440,0)
S DIC="^PRC(440,"
S DIC(0)="AELMQ",DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
S DLAYGO=440
S PRCHDA=-1
K PRCHPO
D ^DIC
Q:Y<0
S (IEN,DA)=+Y
I DA>949999,$P(Y,U,3) L +^PRC(440,0):30 S $P(^PRC(440,0),U,3)=PRCIENB4 L -^PRC(440,0)
S (FLAGN,NEW)=$P(Y,U,3)
G:'$D(DA) VEDIT
D G:'$D(DA) VEDIT
. L +^PRC(440,DA):0
. E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
. Q
D I FLAG=0 L -^PRC(440,IEN) G VEDIT
. S PRCHV3=$G(^PRC(440,DA,3))
. S FLAG=0
. ;
. ;NO FMS VENDOR CODE - DO 'ADD' VENDOR REQUEST
. I $P(PRCHV3,U,4)="" S FLAG=1
. ;
. ;FMS VENDOR CODE - DO 'CHANGE' VENDOR REQUEST
. I $P(PRCHV3,U,4)]"" S FLAG=2
. ;
. I $P(PRCHV3,U,12)="P" D
. . W !!,"There is a FMS Vendor Request pending for this vendor."
. . W !,"Any changes you make now may be overwritten when the Vendor"
. . W !,"Update is received.",!!
. . Q
. Q
K ^PRC(440.3,DA)
I FLAGN="" D
. S %X="^PRC(440,DA,"
. S %Y="^PRC(440.3,DA,"
. D %XY^%RCR
. Q
;
S EDIT="[PRCHVENDOR1]"
;
; NOW LETS FIND OUT IF USER WANTS TO 'REACTIVATE VENDOR', IF
; APPROPRIATE.
;
S INACT=$P($G(^PRC(440,DA,10)),U,5)
I INACT=1 D
. S DIR("A")="Do you want to 'Reactivate' this vendor"
. S DIR("A",1)=" "
. S DIR("A",2)=" "
. S DIR(0)="Y"
. S DIR("B")="NO"
. D ^DIR
. I Y'=1 S EDIT="[PRCHVENDORNOREACT]" Q
. ; OK USER WANTS TO REACTIVATE VENDOR.
. S DIE="^PRC(440,"
. S NAME=$P($G(^PRC(440,DA,0)),U,1)
. I $E(NAME,1,2)="**" S NAME=$E(NAME,3,99)
. S DR=".01////^S X=NAME;15////@;31.5////@"
. D ^DIE
. W !!
. Q
. ; NOW THE VENDOR IS REACTIVATED.
;
S DR=EDIT
S DIE=DIC
D ^DIE
; $D(Y)=TRUE (1) -- USER '^' OUT OF TEMPLATE
I $D(Y) D I FLAG=0 L -^PRC(440,IEN) G VEDIT
. ; CHECK TO SEE IF BUSINESS TYPE (FPDS) FIELD HAS BEEN ENTERED
. I $P($G(^PRC(440,DA,2)),"^",3)="" D
. . W $C(7),!!,"*** NOT ALL REQUIRED FIELDS HAVE BEEN ENTERED ***"
. . W !,"Failure to enter required data may affect Purchase Order"
. . W " processing",!
. . ;
. . ;See NOIS:V13-0802-N1396
. I $P($G(^PRC(440,DA,1.1,0)),"^",3)="" D
. . KILL ^PRC(440,DA,1.1)
. . W $C(7),!!,"*** SOCIOECONOMIC GROUP IS MISSING ***"
. . W !,"Failure to enter required data may affect Purchase Order"
. . W " processing",!
. ;
. S DIR("A")="Do you want to keep the VENDOR changes"
. S DIR(0)="Y"
. S DIR("B")="YES"
. D ^DIR
. ; KILL VARIABLES SET TO USE THE READER
. K DIR
. ; DIRUT SET IF USER TIMES OUT OR ENTERS '^'.
. Q:$D(DIRUT)
. ; Y=1 -- USER WANTS TO KEEP VENDOR CHANGES
. Q:Y=1
. ; USER DECIDED **NOT** TO KEEP VENDOR CHANGES
. ; FLAGN=1 MEANS THIS IS A NEW VENDOR (NEW DURING THIS EDIT SESSION)
. I FLAGN=1 S DIK="^PRC(440," D ^DIK S FLAG=0 Q
. S %X="^PRC(440.3,DA,"
. S %Y="^PRC(440,DA,"
. D %XY^%RCR
. S FLAG=0
. W !!
. K ^PRC(440.3,DA)
. S NAME=$P($G(^PRC(440,DA,0)),U,1)
. W "Name: "_NAME,!,"DA: "_DA,!
. S N1=$E(NAME,1,2)
. Q:N1'["**"
. S N1=$E(NAME,3,99)
. K ^PRC(440,"B",N1,DA)
. S ^PRC(440,"B",NAME,DA)=""
. Q
S FISCAL=$G(^PRC(411,PRC("SITE"),9))
I $P(FISCAL,U,3)="Y" D G VEDIT
. Q:$$NEW^PRCOVTST(DA,PRC("SITE"),FLAG)
. ;
. ; SEE IF THIS IS A NEW VENDOR -- IF SO NOW MOVE THE ENTRY
. ; OVER TO FILE 440.3
. ;
. I NEW D
. . S %X="^PRC(440,DA,"
. . S %Y="^PRC(440.3,DA,"
. . D %XY^%RCR
. . Q
. ;
. ; NOW SET UP TO REVIEW THIS NEW VENDOR
. ;
. S DIE="^PRC(440.3,"
. S DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
. D ^DIE
. Q
;
GENERATE ;GO CREATE A VRQ ANS SEND IT TO AUSTIN
D Q:$G(STOP)=1
. I FLAG=1 D NEW^PRCOVRQ(DA,SITE) Q
. I FLAG=2 D UPDATE^PRCOVRQ1(DA,SITE) Q
G VEDIT
;
;
SEND(IEN) ;SEND OFF THE VRQ TO AUSTIN -- CALLED FROM SEND^PRCORV1
S VRQ=$G(^PRC(440.3,IEN,"VRQ"))
S FLAG=$P(VRQ,U)
S DA=$P(VRQ,U,2)
S SITE=$P(VRQ,U,3)
S STOP=1
D GENERATE
Q:$G(^PRC(440.3,IEN,0))]""
S VRQ=$O(^PRCF(422.2,"B","123-VRQ-01",0))
S COUNT=$P(^PRCF(422.2,VRQ,0),U,2)
S COUNT=$S(COUNT-1>0:COUNT-1,1:0)
S $P(^PRCF(422.2,VRQ,0),U,2)=COUNT
K ^PRC(440.3,"AD",IEN,IEN)
Q
;
NOK(PRCN) ; Check permission to add/edit vendor entry at that ien
; '0' is returned if okay; '1' is returned if prohibited
N PRCX,XQOPT S PRCX=1
S:PRCN<950000 PRCX=0
I PRCX,$D(^XUSEC("PRCHVEN",$G(DUZ,0))) S PRCX=0
I PRCX D OP^XQCHK I ";PRCHITEM_LOAD;PRCHITEM_BULK_LOAD_VIA_HFS;"[(";"_$P(XQOPT,U)_";") S PRCX=0
Q PRCX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHE1 5207 printed Apr 09, 2024@21:20:17 Page 2
PRCHE1 ;WISC/DJM/BGJ/AS-IFCAP EDIT VENDOR FILE ;3/24/17 12:32
V ;;5.1;IFCAP;**7,59,55,81,198**;Oct 20, 2000;Build 6
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;NEW ENTER/EDIT VENDOR FILE CALLED FROM PRCHPC VEN EDIT OPTION
+3 NEW %,%X,%Y,DIE,DIK,DIR,DIRUT,DR,PRCF,SITE,DA,PRCHV3,FLAGN,FLAG
+4 NEW DIC,DLAYGO,IEN,Y,FISCAL,VRQ,STOP,INACT,NAME,EDIT,NEW
+5 NEW PRCIENB4
+6 ;
VEDIT IF '$DATA(PRC("PARAM"))
Begin DoDot:1
+1 SET PRCF("X")="AS"
+2 DO ^PRCFSITE
+3 QUIT
End DoDot:1
if '%
QUIT
+4 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
+5 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
IF $DATA(IEN)
DO ONECHK^PRCVNDR(IEN)
+6 SET SITE=PRC("SITE")
+7 LOCK +^PRC(440,0):30
SET PRCIENB4=$PIECE(^PRC(440,0),U,3)
LOCK -^PRC(440,0)
+8 SET DIC="^PRC(440,"
+9 SET DIC(0)="AELMQ"
SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
+10 SET DLAYGO=440
+11 SET PRCHDA=-1
+12 KILL PRCHPO
+13 DO ^DIC
+14 if Y<0
QUIT
+15 SET (IEN,DA)=+Y
+16 IF DA>949999
IF $PIECE(Y,U,3)
LOCK +^PRC(440,0):30
SET $PIECE(^PRC(440,0),U,3)=PRCIENB4
LOCK -^PRC(440,0)
+17 SET (FLAGN,NEW)=$PIECE(Y,U,3)
+18 if '$DATA(DA)
GOTO VEDIT
+19 Begin DoDot:1
+20 LOCK +^PRC(440,DA):0
+21 IF '$TEST
WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
KILL DA
+22 QUIT
End DoDot:1
if '$DATA(DA)
GOTO VEDIT
+23 Begin DoDot:1
+24 SET PRCHV3=$GET(^PRC(440,DA,3))
+25 SET FLAG=0
+26 ;
+27 ;NO FMS VENDOR CODE - DO 'ADD' VENDOR REQUEST
+28 IF $PIECE(PRCHV3,U,4)=""
SET FLAG=1
+29 ;
+30 ;FMS VENDOR CODE - DO 'CHANGE' VENDOR REQUEST
+31 IF $PIECE(PRCHV3,U,4)]""
SET FLAG=2
+32 ;
+33 IF $PIECE(PRCHV3,U,12)="P"
Begin DoDot:2
+34 WRITE !!,"There is a FMS Vendor Request pending for this vendor."
+35 WRITE !,"Any changes you make now may be overwritten when the Vendor"
+36 WRITE !,"Update is received.",!!
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
IF FLAG=0
LOCK -^PRC(440,IEN)
GOTO VEDIT
+39 KILL ^PRC(440.3,DA)
+40 IF FLAGN=""
Begin DoDot:1
+41 SET %X="^PRC(440,DA,"
+42 SET %Y="^PRC(440.3,DA,"
+43 DO %XY^%RCR
+44 QUIT
End DoDot:1
+45 ;
+46 SET EDIT="[PRCHVENDOR1]"
+47 ;
+48 ; NOW LETS FIND OUT IF USER WANTS TO 'REACTIVATE VENDOR', IF
+49 ; APPROPRIATE.
+50 ;
+51 SET INACT=$PIECE($GET(^PRC(440,DA,10)),U,5)
+52 IF INACT=1
Begin DoDot:1
+53 SET DIR("A")="Do you want to 'Reactivate' this vendor"
+54 SET DIR("A",1)=" "
+55 SET DIR("A",2)=" "
+56 SET DIR(0)="Y"
+57 SET DIR("B")="NO"
+58 DO ^DIR
+59 IF Y'=1
SET EDIT="[PRCHVENDORNOREACT]"
QUIT
+60 ; OK USER WANTS TO REACTIVATE VENDOR.
+61 SET DIE="^PRC(440,"
+62 SET NAME=$PIECE($GET(^PRC(440,DA,0)),U,1)
+63 IF $EXTRACT(NAME,1,2)="**"
SET NAME=$EXTRACT(NAME,3,99)
+64 SET DR=".01////^S X=NAME;15////@;31.5////@"
+65 DO ^DIE
+66 WRITE !!
+67 QUIT
+68 ; NOW THE VENDOR IS REACTIVATED.
End DoDot:1
+69 ;
+70 SET DR=EDIT
+71 SET DIE=DIC
+72 DO ^DIE
+73 ; $D(Y)=TRUE (1) -- USER '^' OUT OF TEMPLATE
+74 IF $DATA(Y)
Begin DoDot:1
+75 ; CHECK TO SEE IF BUSINESS TYPE (FPDS) FIELD HAS BEEN ENTERED
+76 IF $PIECE($GET(^PRC(440,DA,2)),"^",3)=""
Begin DoDot:2
+77 WRITE $CHAR(7),!!,"*** NOT ALL REQUIRED FIELDS HAVE BEEN ENTERED ***"
+78 WRITE !,"Failure to enter required data may affect Purchase Order"
+79 WRITE " processing",!
+80 ;
+81 ;See NOIS:V13-0802-N1396
End DoDot:2
+82 IF $PIECE($GET(^PRC(440,DA,1.1,0)),"^",3)=""
Begin DoDot:2
+83 KILL ^PRC(440,DA,1.1)
+84 WRITE $CHAR(7),!!,"*** SOCIOECONOMIC GROUP IS MISSING ***"
+85 WRITE !,"Failure to enter required data may affect Purchase Order"
+86 WRITE " processing",!
End DoDot:2
+87 ;
+88 SET DIR("A")="Do you want to keep the VENDOR changes"
+89 SET DIR(0)="Y"
+90 SET DIR("B")="YES"
+91 DO ^DIR
+92 ; KILL VARIABLES SET TO USE THE READER
+93 KILL DIR
+94 ; DIRUT SET IF USER TIMES OUT OR ENTERS '^'.
+95 if $DATA(DIRUT)
QUIT
+96 ; Y=1 -- USER WANTS TO KEEP VENDOR CHANGES
+97 if Y=1
QUIT
+98 ; USER DECIDED **NOT** TO KEEP VENDOR CHANGES
+99 ; FLAGN=1 MEANS THIS IS A NEW VENDOR (NEW DURING THIS EDIT SESSION)
+100 IF FLAGN=1
SET DIK="^PRC(440,"
DO ^DIK
SET FLAG=0
QUIT
+101 SET %X="^PRC(440.3,DA,"
+102 SET %Y="^PRC(440,DA,"
+103 DO %XY^%RCR
+104 SET FLAG=0
+105 WRITE !!
+106 KILL ^PRC(440.3,DA)
+107 SET NAME=$PIECE($GET(^PRC(440,DA,0)),U,1)
+108 WRITE "Name: "_NAME,!,"DA: "_DA,!
+109 SET N1=$EXTRACT(NAME,1,2)
+110 if N1'["**"
QUIT
+111 SET N1=$EXTRACT(NAME,3,99)
+112 KILL ^PRC(440,"B",N1,DA)
+113 SET ^PRC(440,"B",NAME,DA)=""
+114 QUIT
End DoDot:1
IF FLAG=0
LOCK -^PRC(440,IEN)
GOTO VEDIT
+115 SET FISCAL=$GET(^PRC(411,PRC("SITE"),9))
+116 IF $PIECE(FISCAL,U,3)="Y"
Begin DoDot:1
+117 if $$NEW^PRCOVTST(DA,PRC("SITE"),FLAG)
QUIT
+118 ;
+119 ; SEE IF THIS IS A NEW VENDOR -- IF SO NOW MOVE THE ENTRY
+120 ; OVER TO FILE 440.3
+121 ;
+122 IF NEW
Begin DoDot:2
+123 SET %X="^PRC(440,DA,"
+124 SET %Y="^PRC(440.3,DA,"
+125 DO %XY^%RCR
+126 QUIT
End DoDot:2
+127 ;
+128 ; NOW SET UP TO REVIEW THIS NEW VENDOR
+129 ;
+130 SET DIE="^PRC(440.3,"
+131 SET DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
+132 DO ^DIE
+133 QUIT
End DoDot:1
GOTO VEDIT
+134 ;
GENERATE ;GO CREATE A VRQ ANS SEND IT TO AUSTIN
+1 Begin DoDot:1
+2 IF FLAG=1
DO NEW^PRCOVRQ(DA,SITE)
QUIT
+3 IF FLAG=2
DO UPDATE^PRCOVRQ1(DA,SITE)
QUIT
End DoDot:1
if $GET(STOP)=1
QUIT
+4 GOTO VEDIT
+5 ;
+6 ;
SEND(IEN) ;SEND OFF THE VRQ TO AUSTIN -- CALLED FROM SEND^PRCORV1
+1 SET VRQ=$GET(^PRC(440.3,IEN,"VRQ"))
+2 SET FLAG=$PIECE(VRQ,U)
+3 SET DA=$PIECE(VRQ,U,2)
+4 SET SITE=$PIECE(VRQ,U,3)
+5 SET STOP=1
+6 DO GENERATE
+7 if $GET(^PRC(440.3,IEN,0))]""
QUIT
+8 SET VRQ=$ORDER(^PRCF(422.2,"B","123-VRQ-01",0))
+9 SET COUNT=$PIECE(^PRCF(422.2,VRQ,0),U,2)
+10 SET COUNT=$SELECT(COUNT-1>0:COUNT-1,1:0)
+11 SET $PIECE(^PRCF(422.2,VRQ,0),U,2)=COUNT
+12 KILL ^PRC(440.3,"AD",IEN,IEN)
+13 QUIT
+14 ;
NOK(PRCN) ; Check permission to add/edit vendor entry at that ien
+1 ; '0' is returned if okay; '1' is returned if prohibited
+2 NEW PRCX,XQOPT
SET PRCX=1
+3 if PRCN<950000
SET PRCX=0
+4 IF PRCX
IF $DATA(^XUSEC("PRCHVEN",$GET(DUZ,0)))
SET PRCX=0
+5 IF PRCX
DO OP^XQCHK
IF ";PRCHITEM_LOAD;PRCHITEM_BULK_LOAD_VIA_HFS;"[(";"_$PIECE(XQOPT,U)_";")
SET PRCX=0
+6 QUIT PRCX
