source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCBVE.m@ 1638

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1PRCBVE ;WISC@ALTOONA/CLH-ADD/EDIT CALM VENDOR FILE ;9-21-89/09:27
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;MUST PASS VARIABLE PRCB("VEN") WHICH IS INTERNAL VENDOR NUMBER
5 ;PRC VARIABLES MUST BE SET IE. PRC("SITE")
6GN ;GET TEMP NUM
7 D WAIT^PRCFYN S DIC="^PRCF(421.6,",DLAYGO=421.6,DIC(0)="XOLM",X=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_$J,PRCBT=0
8 S:'$D(COUNT) COUNT=0 D ^DIC Q:+Y<0 I +$P(Y,U,3)'=1 S COUNT=COUNT+1 Q:COUNT=3 S DIK=DIC,DA=+Y D ^DIK K DIK G GN
9 S PRCB("TDA")=+Y,PRCBT=1
10 Q
11EN ;ADD VENDOR
12 I $D(^PRC(440,PRCB("VEN"),7)) S PRCBE=1,%A="Do you want to review the current information on this vendor",%B="",%=2 D ^PRCFYN D:%'=2 REVO
13 D GN S DIE=DIC,DA=PRCB("TDA"),DR="[PRCB VENDOR EDIT]"
14ENV D ^DIE D REVN S %A="Is this data correct",%B="",%=1 D ^PRCFYN I %'=1 S %A="Re-edit data",%B="",%=1 D ^PRCFYN G:%=1 ENV
15 I '$D(^PRC(440,PRCB("VEN"),7)) S %A(1)="This vendor does not appear to have been established in CALM Vendor File",%A(2)="Do you want to establish them at this time",%B="",%=1 D ^PRCFYN G:%=1 ADVEN G SET
16 I $P(^PRC(440,PRCB("VEN"),7),U,10)="" S %A(1)="This vendor does not appear to have a CALM ID Number",%A(2)="Do you want to establish them to the CALM Vendor File",%B="",%=1 D ^PRCFYN G:%=1 ADVEN G SET
17 I $D(PRCBE) S %A="Do you want to update the CALM vendor file at this time",%B="",%=1 D ^PRCFYN G:%'=1 SET
18 ;THIS AREA FOR UPDATING EXSITING VENDOR INFO IN CALM
19ADVEN ;AREA TO SET UP MSG FOR AUSTIN TO ESTABLISH NEW VENDOR
20 W !!,"Twix will be sent to establish vendor: ",$P(^PRC(440,PRCB("VEN"),0),U)," in the CALM Vendor File."
21SET ;MOVE TEMP INFO FROM 421.6 TO 440
22 W !!,"I'm going to update the your Vendor File..."
23 I '$D(^PRCF(421.6,PRCB("TDA"),3)) G OUT
24 I '$D(^PRC(440,PRCB("VEN"),7)) S OR="",$P(OR,U,1,11)=""
25 E S OR=$P(^PRC(440,PRCB("VEN"),7),U,1,99)
26 S NR=$P(^PRCF(421.6,PRCB("TDA"),3),U,1,99)
27 ;I $P(NR,U,3)
28 S ^PRC(440,PRCB("VEN"),7)=$P(NR,U,12)_U_$P(NR,U,11)_U_$P(NR,U,3,9)
29 W !!,"Finished. Hold on while I do some clean up...."
30OUT I $D(PRCB("TDA")) S DIK="^PRCF(421.6,",DA=PRCB("TDA") D ^DIK
31 K DIK,DIC,DIE,PRCB("TDA"),DA,X,COUNT,PRCBT,DLAYGO,%,REC,REC1,TEMP,TEMP1
32 Q
33REVO ;REVIEW OLD VENDOR INFO
34 I '$D(^PRC(440,PRCB("VEN"),0)) W !!,$C(7),"** No Vendor Information available **" Q
35 S REC=^PRC(440,PRCB("VEN"),0) I '$D(^PRC(440,PRCB("VEN"),7)) S REC1="",$P(REC1,U,1,11)=""
36 E S REC1=^PRC(440,PRCB("VEN"),7)
37 I $D(IOF) W @IOF
38 W !!?5,"Vendor Name: ",$P(REC,U,1),?48,"Vendor Number: ",PRCB("VEN")
39 W !!!?5,"Payment Information: "
40 W !!?19,"Calm ID Number: " I $P(REC1,U,10)'="" W $P(REC1,U,10)
41 W !?19,"Stub Name: " I $P(REC1,U,11)'="" W ?35,$P(REC1,U,11)
42 W !?19,"Address: " I $P(REC1,U,3)'="" W ?35,$P(REC1,U,3)
43 I $P(REC1,U,4)'="" W !?35,$P(REC1,U,4)
44 I $P(REC1,U,5)'="" W !?35,$P(REC1,U,5)
45 I $P(REC1,U,6)'="" W !?35,$P(REC1,U,6)
46 I $P(REC1,U,7)'="" W !?35,$P(REC1,U,7)_", ",$P(^DIC(5,$P(REC1,U,8),0),U)_" ",$P(REC1,U,9)
47 W !!?19,"Phone Number: " I $P(REC1,U,2)'="" W ?35,$P(REC1,U,2)
48 Q
49REVN ;REVIEW NEW VENDOR INFO
50 I '$D(^PRCF(421.6,PRCB("TDA"),3)) W !,$C(7)," - No Data Entered - " Q
51 E S TEMP1=^PRCF(421.6,PRCB("TDA"),3)
52 I $D(IOF) W @IOF
53 W !!?5,"Vendor Name: ",$P(^PRC(440,PRCB("VEN"),0),U)
54 W !!!?5,"Payment Information: "
55 W !!?19,"Calm ID Number: " I $P(TEMP1,U,1)'="" W $P(TEMP1,U,1)
56 W !?19,"Calm Stub Name: " I $P(TEMP1,U,10)'="" W ?35,$P(TEMP1,U,10)
57 W !?19,"Address: " I $P(TEMP1,U,3)'="" W ?35,$P(TEMP1,U,3)
58 I $P(TEMP1,U,4)'="" W !?35,$P(TEMP1,U,4)
59 I $P(TEMP1,U,5)'="" W !?35,$P(TEMP1,U,5)
60 I $P(TEMP1,U,6)'="" W !?35,$P(TEMP1,U,6)
61 I $P(TEMP1,U,7)'="" W !?35,$P(TEMP1,U,7)_", ",$P(TEMP1,U,8)_" ",$P(TEMP1,U,9)
62 Q
Note: See TracBrowser for help on using the repository browser.