PRCFAC3 ;WISC/CTB/CLH/SJG/AS-ACCOUNTING MODULE ;3/24/17 13:12
V ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
;Per VA Directive 6402, this routine should not be modified.
E10 ; Enter FMS Vendor Code Numbers into Vendor File
N TAG,PRCF
D HILO^PRCFQ
S PRCF("X")="AS" D ^PRCFSITE Q:'%
D SCREEN
S PRCFA("FISCVEND")=$P($G(PRC("PARAM")),U,20)
S TAG=$S(PRCFA("FISCVEND"):"E10B",'PRCFA("FISCVEND"):"E10A") D @TAG
OUT10 K %W,%X,%Y,D0,DA,DIC,DIE,DQ,DR,I,J,K,X,Y,DIRUT
K PRCTMP,IOINHI,IOINLOW,IOINORM,PRCFA
QUIT
E10A ; No adding by Fiscal/editing only
I 'PRCFA("FISCVEND") W !!,"Only Supply may add new Vendors to the Vendor File",!,"but Fiscal may edit payment information.",!!
E10A1 W ! S DIC(0)="AENMQ",DIC=440,DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
D ^DIC Q:Y<0
I Y>0 S (DA,PRCFA("VEND"))=+Y D INFO K PRCTMP D EDIT^PRCFAC31
Q:$D(DIRUT)
I 'Y W !!,"No further action is being taken on this Vendor.",! G E10A1
D SCREEN
L +^PRC(440,DA):5 E W !,$C(7),"Another user is editing this entry!" G E10A1
K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR
D WARN
S DIE=DIC,DR=$S($D(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT1B]",1:"[PRCF FMS VENEDIT1]")
D ^DIE K DIE,DR,ORDER W ! D VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))
L -^PRC(440,PRCFA("VEND"))
; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(PRCFA("VEND"))
G E10A1
QUIT
E10B ; Adding/editing by Fiscal
I PRCFA("FISCVEND") W !!,"Fiscal may add new Vendors to the Vendor File.",!!
N PRCIENB4
E10B1 W ! S DIC(0)="AENMQL",DLAYGO=440,DIC=440,DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
L +^PRC(440,0):30 S PRCIENB4=$P(^PRC(440,0),U,3) L -^PRC(440,0)
D ^DIC K DLAYGO Q:Y<0
I +Y>949999,$P(Y,U,3) L +^PRC(440,0):30 S $P(^PRC(440,0),U,3)=PRCIENB4 L -^PRC(440,0)
I Y>0 S (DA,PRCFA("VEND"))=+Y D INFO K PRCTMP D EDIT^PRCFAC31
Q:$D(DIRUT)
I 'Y W !!,"No further action is being taken on this Vendor.",! G E10B1
D SCREEN
L +^PRC(440,DA):5 E W !,$C(7),"Another user is editing this entry!" G E10B1
K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR
D WARN
S DIE=DIC,DR=$S($D(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT2B]",1:"[PRCF FMS VENEDIT2]")
D ^DIE K DIE,DR,ORDER W ! D VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))
L -^PRC(440,PRCFA("VEND"))
; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(PRCFA("VEND"))
G E10B1
QUIT
;
E11 ;LOOK VENDOR NUMBER
D HILO^PRCFQ
W !,"Select Vendor Name or PO Number: " R X:$S($D(DTIME):DTIME,1:30) G:X="" OUT11
S X1=X,DIC=440,DIC(0)="EMN" D ^DIC G:X="^" OUT11 I +Y>0 S (PRCFA("VEND"),DA)=+Y D INFO G E11
S X=X1,DIC=442,DIC(0)="EMN" D ^DIC G:X="?" E11 G:Y<0 E11 S (PRCFA("VEND"),DA)=$P($G(^PRC(442,+Y,1)),U,1) I DA="" W !!?25,$C(7),"No Vendor for this obligation number.",! G E11
W !,$P(^PRC(440,PRCFA("VEND"),0),"^") D INFO G E11
OUT11 K %,%W,%Y,DA,DIC,I,X,X1,Y
K PRCTMP,PRCFA,IOINHI,IOINLO,IONORM
QUIT
;
E12 ;;INQUIRE TO CODE SHEET ERROR MESSAGE
S DIC=421.3,DIC(0)="AEMNQ" D ^DIC I Y>0 S DA=+Y,DR=1 D EN^DIQ G E12
K %,%Y,A,D0,D1,DA,DIC,DIW,DIWF,DIWL,DIWR,DIWT,DL,DN,DR,DX,I,J,K,S,X,Y Q
E13 ;ADD/EDIT CODE SHEET ERROR MESSAGE
S DIC="^PRCF(421.3,",DIC(0)="AEMNLQ",DLAYGO=421.3 D ^DIC K DLAYGO I Y>0 S DIE=DIC,DA=+Y,DR=1 D ^DIE W ! G E13
K %,%DT,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,X,X1,Y Q
E14 ;INQUIRE TO TRANSMISSION RECORD
S:'$D(PRCFASYS) PRCFASYS="FEEFENIRSCLI"
S PRCFASYS=PRCFASYS_"RR"
S DIC=421.2,DIC(0)="AMENQ",DIC("S")="I PRCFASYS[$P(^(0),""-"",2)" D ^DIC I Y>0 S DA=+Y,DR="0;1" D EN^DIQ G E14
K %,A,D0,DA,DIC,DL,DR,DRX,DX,S,X,Y Q
INFO ; Get/Print Vendor Payment Information
I '$D(^PRC(440,PRCFA("VEND"),7)) W !!,$C(7),"No payment information in Vendor File.",!! Q
S DIR(0)="Y",DIR("A")="Review current payment information on this Vendor",DIR("B")="YES" W ! D ^DIR K DIR
I 'Y!($D(DIRUT)) Q
D GET^PRCFAC31(PRCFA("VEND")),DISPLAY^PRCFAC31(PRCFA("VEND"))
Q
SCREEN ; Control screen display
I $D(IOF) W @IOF
HDR ; Write Option Header
I $D(XQY0) W IOINHI,$P(XQY0,U,2),IOINORM,!
Q
WARN ;WARNING IF PENDING VRQ
I $P($G(^PRC(440,DA,3)),U,12)="P" W !!,"There is a FMS Vendor Request pending for this vendor.",!,"Any changes you make now may be overwritten when the Vendor",!,"Update is received.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC3 4413 printed Dec 13, 2024@02:01:52 Page 2
PRCFAC3 ;WISC/CTB/CLH/SJG/AS-ACCOUNTING MODULE ;3/24/17 13:12
V ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
+1 ;Per VA Directive 6402, this routine should not be modified.
E10 ; Enter FMS Vendor Code Numbers into Vendor File
+1 NEW TAG,PRCF
+2 DO HILO^PRCFQ
+3 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
+4 DO SCREEN
+5 SET PRCFA("FISCVEND")=$PIECE($GET(PRC("PARAM")),U,20)
+6 SET TAG=$SELECT(PRCFA("FISCVEND"):"E10B",'PRCFA("FISCVEND"):"E10A")
DO @TAG
OUT10 KILL %W,%X,%Y,D0,DA,DIC,DIE,DQ,DR,I,J,K,X,Y,DIRUT
+1 KILL PRCTMP,IOINHI,IOINLOW,IOINORM,PRCFA
+2 QUIT
E10A ; No adding by Fiscal/editing only
+1 IF 'PRCFA("FISCVEND")
WRITE !!,"Only Supply may add new Vendors to the Vendor File",!,"but Fiscal may edit payment information.",!!
E10A1 WRITE !
SET DIC(0)="AENMQ"
SET DIC=440
SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
+1 DO ^DIC
if Y<0
QUIT
+2 IF Y>0
SET (DA,PRCFA("VEND"))=+Y
DO INFO
KILL PRCTMP
DO EDIT^PRCFAC31
+3 if $DATA(DIRUT)
QUIT
+4 IF 'Y
WRITE !!,"No further action is being taken on this Vendor.",!
GOTO E10A1
+5 DO SCREEN
+6 LOCK +^PRC(440,DA):5
IF '$TEST
WRITE !,$CHAR(7),"Another user is editing this entry!"
GOTO E10A1
+7 KILL ^PRC(440.3,DA)
SET %X="^PRC(440,DA,"
SET %Y="^PRC(440.3,DA,"
DO %XY^%RCR
+8 DO WARN
+9 SET DIE=DIC
SET DR=$SELECT($DATA(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT1B]",1:"[PRCF FMS VENEDIT1]")
+10 DO ^DIE
KILL DIE,DR,ORDER
WRITE !
DO VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))
+11 LOCK -^PRC(440,PRCFA("VEND"))
+12 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
+13 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
DO ONECHK^PRCVNDR(PRCFA("VEND"))
+14 GOTO E10A1
+15 QUIT
E10B ; Adding/editing by Fiscal
+1 IF PRCFA("FISCVEND")
WRITE !!,"Fiscal may add new Vendors to the Vendor File.",!!
+2 NEW PRCIENB4
E10B1 WRITE !
SET DIC(0)="AENMQL"
SET DLAYGO=440
SET DIC=440
SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"
+1 LOCK +^PRC(440,0):30
SET PRCIENB4=$PIECE(^PRC(440,0),U,3)
LOCK -^PRC(440,0)
+2 DO ^DIC
KILL DLAYGO
if Y<0
QUIT
+3 IF +Y>949999
IF $PIECE(Y,U,3)
LOCK +^PRC(440,0):30
SET $PIECE(^PRC(440,0),U,3)=PRCIENB4
LOCK -^PRC(440,0)
+4 IF Y>0
SET (DA,PRCFA("VEND"))=+Y
DO INFO
KILL PRCTMP
DO EDIT^PRCFAC31
+5 if $DATA(DIRUT)
QUIT
+6 IF 'Y
WRITE !!,"No further action is being taken on this Vendor.",!
GOTO E10B1
+7 DO SCREEN
+8 LOCK +^PRC(440,DA):5
IF '$TEST
WRITE !,$CHAR(7),"Another user is editing this entry!"
GOTO E10B1
+9 KILL ^PRC(440.3,DA)
SET %X="^PRC(440,DA,"
SET %Y="^PRC(440.3,DA,"
DO %XY^%RCR
+10 DO WARN
+11 SET DIE=DIC
SET DR=$SELECT($DATA(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT2B]",1:"[PRCF FMS VENEDIT2]")
+12 DO ^DIE
KILL DIE,DR,ORDER
WRITE !
DO VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))
+13 LOCK -^PRC(440,PRCFA("VEND"))
+14 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
+15 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
DO ONECHK^PRCVNDR(PRCFA("VEND"))
+16 GOTO E10B1
+17 QUIT
+18 ;
E11 ;LOOK VENDOR NUMBER
+1 DO HILO^PRCFQ
+2 WRITE !,"Select Vendor Name or PO Number: "
READ X:$SELECT($DATA(DTIME):DTIME,1:30)
if X=""
GOTO OUT11
+3 SET X1=X
SET DIC=440
SET DIC(0)="EMN"
DO ^DIC
if X="^"
GOTO OUT11
IF +Y>0
SET (PRCFA("VEND"),DA)=+Y
DO INFO
GOTO E11
+4 SET X=X1
SET DIC=442
SET DIC(0)="EMN"
DO ^DIC
if X="?"
GOTO E11
if Y<0
GOTO E11
SET (PRCFA("VEND"),DA)=$PIECE($GET(^PRC(442,+Y,1)),U,1)
IF DA=""
WRITE !!?25,$CHAR(7),"No Vendor for this obligation number.",!
GOTO E11
+5 WRITE !,$PIECE(^PRC(440,PRCFA("VEND"),0),"^")
DO INFO
GOTO E11
OUT11 KILL %,%W,%Y,DA,DIC,I,X,X1,Y
+1 KILL PRCTMP,PRCFA,IOINHI,IOINLO,IONORM
+2 QUIT
+3 ;
E12 ;;INQUIRE TO CODE SHEET ERROR MESSAGE
+1 SET DIC=421.3
SET DIC(0)="AEMNQ"
DO ^DIC
IF Y>0
SET DA=+Y
SET DR=1
DO EN^DIQ
GOTO E12
+2 KILL %,%Y,A,D0,D1,DA,DIC,DIW,DIWF,DIWL,DIWR,DIWT,DL,DN,DR,DX,I,J,K,S,X,Y
QUIT
E13 ;ADD/EDIT CODE SHEET ERROR MESSAGE
+1 SET DIC="^PRCF(421.3,"
SET DIC(0)="AEMNLQ"
SET DLAYGO=421.3
DO ^DIC
KILL DLAYGO
IF Y>0
SET DIE=DIC
SET DA=+Y
SET DR=1
DO ^DIE
WRITE !
GOTO E13
+2 KILL %,%DT,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,X,X1,Y
QUIT
E14 ;INQUIRE TO TRANSMISSION RECORD
+1 if '$DATA(PRCFASYS)
SET PRCFASYS="FEEFENIRSCLI"
+2 SET PRCFASYS=PRCFASYS_"RR"
+3 SET DIC=421.2
SET DIC(0)="AMENQ"
SET DIC("S")="I PRCFASYS[$P(^(0),""-"",2)"
DO ^DIC
IF Y>0
SET DA=+Y
SET DR="0;1"
DO EN^DIQ
GOTO E14
+4 KILL %,A,D0,DA,DIC,DL,DR,DRX,DX,S,X,Y
QUIT
INFO ; Get/Print Vendor Payment Information
+1 IF '$DATA(^PRC(440,PRCFA("VEND"),7))
WRITE !!,$CHAR(7),"No payment information in Vendor File.",!!
QUIT
+2 SET DIR(0)="Y"
SET DIR("A")="Review current payment information on this Vendor"
SET DIR("B")="YES"
WRITE !
DO ^DIR
KILL DIR
+3 IF 'Y!($DATA(DIRUT))
QUIT
+4 DO GET^PRCFAC31(PRCFA("VEND"))
DO DISPLAY^PRCFAC31(PRCFA("VEND"))
+5 QUIT
SCREEN ; Control screen display
+1 IF $DATA(IOF)
WRITE @IOF
HDR ; Write Option Header
+1 IF $DATA(XQY0)
WRITE IOINHI,$PIECE(XQY0,U,2),IOINORM,!
+2 QUIT
WARN ;WARNING IF PENDING VRQ
+1 IF $PIECE($GET(^PRC(440,DA,3)),U,12)="P"
WRITE !!,"There is a FMS Vendor Request pending for this vendor.",!,"Any changes you make now may be overwritten when the Vendor",!,"Update is received.",!!
+2 QUIT
