Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHE1

PRCHE1.m

Go to the documentation of this file.
  1. PRCHE1 ;WISC/DJM/BGJ/AS-IFCAP EDIT VENDOR FILE ;3/24/17 12:32
  1. 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.
  1. ;NEW ENTER/EDIT VENDOR FILE CALLED FROM PRCHPC VEN EDIT OPTION
  1. N %,%X,%Y,DIE,DIK,DIR,DIRUT,DR,PRCF,SITE,DA,PRCHV3,FLAGN,FLAG
  1. N DIC,DLAYGO,IEN,Y,FISCAL,VRQ,STOP,INACT,NAME,EDIT,NEW
  1. N PRCIENB4
  1. ;
  1. VEDIT I '$D(PRC("PARAM")) D Q:'%
  1. . S PRCF("X")="AS"
  1. . D ^PRCFSITE
  1. . Q
  1. ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1,$D(IEN) D ONECHK^PRCVNDR(IEN)
  1. S SITE=PRC("SITE")
  1. L +^PRC(440,0):30 S PRCIENB4=$P(^PRC(440,0),U,3) L -^PRC(440,0)
  1. S DIC="^PRC(440,"
  1. S DIC(0)="AELMQ",DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
  1. S DLAYGO=440
  1. S PRCHDA=-1
  1. K PRCHPO
  1. D ^DIC
  1. Q:Y<0
  1. S (IEN,DA)=+Y
  1. I DA>949999,$P(Y,U,3) L +^PRC(440,0):30 S $P(^PRC(440,0),U,3)=PRCIENB4 L -^PRC(440,0)
  1. S (FLAGN,NEW)=$P(Y,U,3)
  1. G:'$D(DA) VEDIT
  1. D G:'$D(DA) VEDIT
  1. . L +^PRC(440,DA):0
  1. . E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
  1. . Q
  1. D I FLAG=0 L -^PRC(440,IEN) G VEDIT
  1. . S PRCHV3=$G(^PRC(440,DA,3))
  1. . S FLAG=0
  1. . ;
  1. . ;NO FMS VENDOR CODE - DO 'ADD' VENDOR REQUEST
  1. . I $P(PRCHV3,U,4)="" S FLAG=1
  1. . ;
  1. . ;FMS VENDOR CODE - DO 'CHANGE' VENDOR REQUEST
  1. . I $P(PRCHV3,U,4)]"" S FLAG=2
  1. . ;
  1. . I $P(PRCHV3,U,12)="P" D
  1. . . W !!,"There is a FMS Vendor Request pending for this vendor."
  1. . . W !,"Any changes you make now may be overwritten when the Vendor"
  1. . . W !,"Update is received.",!!
  1. . . Q
  1. . Q
  1. K ^PRC(440.3,DA)
  1. I FLAGN="" D
  1. . S %X="^PRC(440,DA,"
  1. . S %Y="^PRC(440.3,DA,"
  1. . D %XY^%RCR
  1. . Q
  1. ;
  1. S EDIT="[PRCHVENDOR1]"
  1. ;
  1. ; NOW LETS FIND OUT IF USER WANTS TO 'REACTIVATE VENDOR', IF
  1. ; APPROPRIATE.
  1. ;
  1. S INACT=$P($G(^PRC(440,DA,10)),U,5)
  1. I INACT=1 D
  1. . S DIR("A")="Do you want to 'Reactivate' this vendor"
  1. . S DIR("A",1)=" "
  1. . S DIR("A",2)=" "
  1. . S DIR(0)="Y"
  1. . S DIR("B")="NO"
  1. . D ^DIR
  1. . I Y'=1 S EDIT="[PRCHVENDORNOREACT]" Q
  1. . ; OK USER WANTS TO REACTIVATE VENDOR.
  1. . S DIE="^PRC(440,"
  1. . S NAME=$P($G(^PRC(440,DA,0)),U,1)
  1. . I $E(NAME,1,2)="**" S NAME=$E(NAME,3,99)
  1. . S DR=".01////^S X=NAME;15////@;31.5////@"
  1. . D ^DIE
  1. . W !!
  1. . Q
  1. . ; NOW THE VENDOR IS REACTIVATED.
  1. ;
  1. S DR=EDIT
  1. S DIE=DIC
  1. D ^DIE
  1. ; $D(Y)=TRUE (1) -- USER '^' OUT OF TEMPLATE
  1. I $D(Y) D I FLAG=0 L -^PRC(440,IEN) G VEDIT
  1. . ; CHECK TO SEE IF BUSINESS TYPE (FPDS) FIELD HAS BEEN ENTERED
  1. . I $P($G(^PRC(440,DA,2)),"^",3)="" D
  1. . . W $C(7),!!,"*** NOT ALL REQUIRED FIELDS HAVE BEEN ENTERED ***"
  1. . . W !,"Failure to enter required data may affect Purchase Order"
  1. . . W " processing",!
  1. . . ;
  1. . . ;See NOIS:V13-0802-N1396
  1. . I $P($G(^PRC(440,DA,1.1,0)),"^",3)="" D
  1. . . KILL ^PRC(440,DA,1.1)
  1. . . W $C(7),!!,"*** SOCIOECONOMIC GROUP IS MISSING ***"
  1. . . W !,"Failure to enter required data may affect Purchase Order"
  1. . . W " processing",!
  1. . ;
  1. . S DIR("A")="Do you want to keep the VENDOR changes"
  1. . S DIR(0)="Y"
  1. . S DIR("B")="YES"
  1. . D ^DIR
  1. . ; KILL VARIABLES SET TO USE THE READER
  1. . K DIR
  1. . ; DIRUT SET IF USER TIMES OUT OR ENTERS '^'.
  1. . Q:$D(DIRUT)
  1. . ; Y=1 -- USER WANTS TO KEEP VENDOR CHANGES
  1. . Q:Y=1
  1. . ; USER DECIDED **NOT** TO KEEP VENDOR CHANGES
  1. . ; FLAGN=1 MEANS THIS IS A NEW VENDOR (NEW DURING THIS EDIT SESSION)
  1. . I FLAGN=1 S DIK="^PRC(440," D ^DIK S FLAG=0 Q
  1. . S %X="^PRC(440.3,DA,"
  1. . S %Y="^PRC(440,DA,"
  1. . D %XY^%RCR
  1. . S FLAG=0
  1. . W !!
  1. . K ^PRC(440.3,DA)
  1. . S NAME=$P($G(^PRC(440,DA,0)),U,1)
  1. . W "Name: "_NAME,!,"DA: "_DA,!
  1. . S N1=$E(NAME,1,2)
  1. . Q:N1'["**"
  1. . S N1=$E(NAME,3,99)
  1. . K ^PRC(440,"B",N1,DA)
  1. . S ^PRC(440,"B",NAME,DA)=""
  1. . Q
  1. S FISCAL=$G(^PRC(411,PRC("SITE"),9))
  1. I $P(FISCAL,U,3)="Y" D G VEDIT
  1. . Q:$$NEW^PRCOVTST(DA,PRC("SITE"),FLAG)
  1. . ;
  1. . ; SEE IF THIS IS A NEW VENDOR -- IF SO NOW MOVE THE ENTRY
  1. . ; OVER TO FILE 440.3
  1. . ;
  1. . I NEW D
  1. . . S %X="^PRC(440,DA,"
  1. . . S %Y="^PRC(440.3,DA,"
  1. . . D %XY^%RCR
  1. . . Q
  1. . ;
  1. . ; NOW SET UP TO REVIEW THIS NEW VENDOR
  1. . ;
  1. . S DIE="^PRC(440.3,"
  1. . S DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
  1. . D ^DIE
  1. . Q
  1. ;
  1. GENERATE ;GO CREATE A VRQ ANS SEND IT TO AUSTIN
  1. D Q:$G(STOP)=1
  1. . I FLAG=1 D NEW^PRCOVRQ(DA,SITE) Q
  1. . I FLAG=2 D UPDATE^PRCOVRQ1(DA,SITE) Q
  1. G VEDIT
  1. ;
  1. ;
  1. SEND(IEN) ;SEND OFF THE VRQ TO AUSTIN -- CALLED FROM SEND^PRCORV1
  1. S VRQ=$G(^PRC(440.3,IEN,"VRQ"))
  1. S FLAG=$P(VRQ,U)
  1. S DA=$P(VRQ,U,2)
  1. S SITE=$P(VRQ,U,3)
  1. S STOP=1
  1. D GENERATE
  1. Q:$G(^PRC(440.3,IEN,0))]""
  1. S VRQ=$O(^PRCF(422.2,"B","123-VRQ-01",0))
  1. S COUNT=$P(^PRCF(422.2,VRQ,0),U,2)
  1. S COUNT=$S(COUNT-1>0:COUNT-1,1:0)
  1. S $P(^PRCF(422.2,VRQ,0),U,2)=COUNT
  1. K ^PRC(440.3,"AD",IEN,IEN)
  1. Q
  1. ;
  1. NOK(PRCN) ; Check permission to add/edit vendor entry at that ien
  1. ; '0' is returned if okay; '1' is returned if prohibited
  1. N PRCX,XQOPT S PRCX=1
  1. S:PRCN<950000 PRCX=0
  1. I PRCX,$D(^XUSEC("PRCHVEN",$G(DUZ,0))) S PRCX=0
  1. I PRCX D OP^XQCHK I ";PRCHITEM_LOAD;PRCHITEM_BULK_LOAD_VIA_HFS;"[(";"_$P(XQOPT,U)_";") S PRCX=0
  1. Q PRCX