- 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 Feb 18, 2025@23:33:25 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