source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFAC3.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
RevLine 
[613]1PRCFAC3 ;WISC/CTB/CLH/SJG/AS-ACCOUNTING MODULE ; 3/8/05
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4E10 ; Enter FMS Vendor Code Numbers into Vendor File
5 N TAG,PRCF
6 D HILO^PRCFQ
7 S PRCF("X")="AS" D ^PRCFSITE Q:'%
8 D SCREEN
9 S PRCFA("FISCVEND")=$P($G(PRC("PARAM")),U,20)
10 S TAG=$S(PRCFA("FISCVEND"):"E10B",'PRCFA("FISCVEND"):"E10A") D @TAG
11OUT10 K %W,%X,%Y,D0,DA,DIC,DIE,DQ,DR,I,J,K,X,Y,DIRUT
12 K PRCTMP,IOINHI,IOINLOW,IOINORM,PRCFA
13 QUIT
14E10A ; No adding by Fiscal/editing only
15 I 'PRCFA("FISCVEND") W !!,"Only Supply may add new Vendors to the Vendor File",!,"but Fiscal may edit payment information.",!!
16E10A1 W ! S DIC(0)="AENMQ",DIC=440 D ^DIC Q:Y<0
17 I Y>0 S (DA,PRCFA("VEND"))=+Y D INFO K PRCTMP D EDIT^PRCFAC31
18 Q:$D(DIRUT)
19 I 'Y W !!,"No further action is being taken on this Vendor.",! G E10A1
20 D SCREEN
21 L +^PRC(440,DA):5 E W !,$C(7),"Another user is editing this entry!" G E10A1
22 K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR
23 D WARN
24 S DIE=DIC,DR=$S($D(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT1B]",1:"[PRCF FMS VENEDIT1]")
25 D ^DIE K DIE,DR,ORDER W ! D VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))
26 L -^PRC(440,PRCFA("VEND"))
27 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
28 D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(PRCFA("VEND"))
29 G E10A1
30 QUIT
31E10B ; Adding/editing by Fiscal
32 I PRCFA("FISCVEND") W !!,"Fiscal may add new Vendors to the Vendor File.",!!
33E10B1 W ! S DIC(0)="AENMQL",DLAYGO=440,DIC=440 D ^DIC K DLAYGO Q:Y<0
34 I Y>0 S (DA,PRCFA("VEND"))=+Y D INFO K PRCTMP D EDIT^PRCFAC31
35 Q:$D(DIRUT)
36 I 'Y W !!,"No further action is being taken on this Vendor.",! G E10B1
37 D SCREEN
38 L +^PRC(440,DA):5 E W !,$C(7),"Another user is editing this entry!" G E10B1
39 K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR
40 D WARN
41 S DIE=DIC,DR=$S($D(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT2B]",1:"[PRCF FMS VENEDIT2]")
42 D ^DIE K DIE,DR,ORDER W ! D VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))
43 L -^PRC(440,PRCFA("VEND"))
44 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
45 D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(PRCFA("VEND"))
46 G E10B1
47 QUIT
48 ;
49E11 ;LOOK VENDOR NUMBER
50 D HILO^PRCFQ
51 W !,"Select Vendor Name or PO Number: " R X:$S($D(DTIME):DTIME,1:30) G:X="" OUT11
52 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
53 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
54 W !,$P(^PRC(440,PRCFA("VEND"),0),"^") D INFO G E11
55OUT11 K %,%W,%Y,DA,DIC,I,X,X1,Y
56 K PRCTMP,PRCFA,IOINHI,IOINLO,IONORM
57 QUIT
58 ;
59E12 ;;INQUIRE TO CODE SHEET ERROR MESSAGE
60 S DIC=421.3,DIC(0)="AEMNQ" D ^DIC I Y>0 S DA=+Y,DR=1 D EN^DIQ G E12
61 K %,%Y,A,D0,D1,DA,DIC,DIW,DIWF,DIWL,DIWR,DIWT,DL,DN,DR,DX,I,J,K,S,X,Y Q
62E13 ;ADD/EDIT CODE SHEET ERROR MESSAGE
63 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
64 K %,%DT,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,X,X1,Y Q
65E14 ;INQUIRE TO TRANSMISSION RECORD
66 S:'$D(PRCFASYS) PRCFASYS="FEEFENIRSCLI"
67 S PRCFASYS=PRCFASYS_"RR"
68 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
69 K %,A,D0,DA,DIC,DL,DR,DRX,DX,S,X,Y Q
70INFO ; Get/Print Vendor Payment Information
71 I '$D(^PRC(440,PRCFA("VEND"),7)) W !!,$C(7),"No payment information in Vendor File.",!! Q
72 S DIR(0)="Y",DIR("A")="Review current payment information on this Vendor",DIR("B")="YES" W ! D ^DIR K DIR
73 I 'Y!($D(DIRUT)) Q
74 D GET^PRCFAC31(PRCFA("VEND")),DISPLAY^PRCFAC31(PRCFA("VEND"))
75 Q
76SCREEN ; Control screen display
77 I $D(IOF) W @IOF
78HDR ; Write Option Header
79 I $D(XQY0) W IOINHI,$P(XQY0,U,2),IOINORM,!
80 Q
81WARN ;WARNING IF PENDING VRQ
82 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.",!!
83 Q
Note: See TracBrowser for help on using the repository browser.