162 lines
4.4 KiB
Mathematica
162 lines
4.4 KiB
Mathematica
PRCHE1 ;WISC/DJM/BGJ/AS-IFCAP EDIT VENDOR FILE ;3/8/05
|
|
V ;;5.1;IFCAP;**7,59,55,81**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, 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
|
|
;
|
|
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")
|
|
S DIC="^PRC(440,"
|
|
S DIC(0)="AELMQ"
|
|
S DLAYGO=440
|
|
S PRCHDA=-1
|
|
K PRCHPO
|
|
D ^DIC
|
|
Q:Y<0
|
|
S (IEN,DA)=+Y
|
|
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
|