source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU15.m@ 862

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

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1PRCFFU15 ;WISC/SJG-1358 & PO OBLIGATION UTILITY, CONT ;8/15/94 17:47
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; No top level entry
6 QUIT
7 ;
8VENCONO(IEN) ; Display vendor and contract information on org entry
9 ; IEN - Internal entry number from 410
10 K PRCTMP N VENDOR
11DISP S (VENDOR,CONT,CONTEND,VENCONT,CONTIEN)=""
12 D GENDIQ^PRCFFU7(410,IEN,"11;12;13;52","IEN","")
13 S VENDOR=$G(PRCTMP(410,IEN,11,"E"))
14 I VENDOR]"" W !,IOINLOW,"VENDOR: ",IOINHI,VENDOR,IOINORM,!
15 S CONT=$G(PRCTMP(410,IEN,13,"E")) Q:CONT=""
16 I CONT]"" D CONTNUM Q:CONTEND=""
17 I CONTEND]"" D
18 .W IOINLOW,"CONTRACT: ",IOINHI,CONT,IOINORM,!
19 .W IOINLOW,"CONTRACT ENDING DATE: ",IOINHI,CONTEND,IOINORM,!
20 Q
21VENCONM(IEN) ; Display vendor and contract information on adjustment
22 ; IEN - Internal entry number from 442
23 K PRCTMP N VENDOR,PRRQST
24 D GENDIQ^PRCFFU7(442,+PO,.07,"I","")
25 S PRRQST=$G(PRCTMP(442,+IEN,.07,"I"))
26 Q:PRRQST=""
27 I PRRQST]"" S POIEN=IEN,IEN=PRRQST D DISP
28 Q
29POVENO(IEN) ; Display vendor and contract information
30 ; IEN - Internal entry number from 442
31 K PRCTMP N VENNM,VENIEN
32 D GENDIQ^PRCFFU7(442,IEN,5,"IEN","")
33 S VENNM=$G(PRCTMP(442,IEN,5,"E")),VENIEN=$G(PRCTMP(442,IEN,5,"I"))
34 I VENNM]"" W !,"VENDOR: ",VENNM,!
35 I '$D(^PRC(442,+IEN,2,"AC")) W "CONTRACT: ** NONE ON THIS ORDER **",!
36PO1 I $D(^PRC(442,+IEN,2,"AC")) D W !
37 .S (PRCFMOD,NEWADD)=0
38 .W ! K MSG S MSG(1)="One or more of the following contracts are associated with the line items"
39 .S MSG(2)="on this Purchase Order for Services for this Vendor: "
40 .D EN^DDIOL(.MSG) K MSG
41 .S CONT="" F S CONT=$O(^PRC(442,+IEN,2,"AC",CONT)) Q:CONT="" D ADDCONT
42 .K PRCFMOD,NEWADD
43 .Q
44PO2 I $D(^PRC(443.6,+IEN,2,"AC")),$P(PRCFA("MOD"),U)="M" D W !
45 .S PRCFMOD=1,NEWADD=0
46 .W ! K MSG S MSG(1)="The Amendment has added line items which contain one or more of the following"
47 .S MSG(2)="contracts to this Purchase Order for Services:"
48 .D EN^DDIOL(.MSG) K MSG
49 .S CONT="" F S CONT=$O(^PRC(443.6,+IEN,2,"AC",CONT)) Q:CONT="" D ADDCONT
50 .D:NEWADD=0 EN^DDIOL(" ** NO NEW CONTRACTS ADDED THROUGH THE AMENDMENT **")
51 .K PRCFMOD,NEWADD
52 .Q
53 Q
54ADDCONT ;
55 S DIC="^PRC(440,"_VENIEN_",4,",DIC(0)="MNZ",X=CONT D ^DIC K DIC Q:Y<0
56 I Y>0 D
57 .N DA,CONTIEN,CONTEND S CONTIEN=+Y
58 .S DIC=440,DR=6,DA=VENIEN,DIQ="PRCTMP(",DIQ(0)="IEN",DR(440.03)=".5;1",DA(440.03)=CONTIEN D EN^DIQ1 K DIC,DIQ,DR
59 .S CONTENDE=$G(PRCTMP(440.03,CONTIEN,1,"E")),CONTENDI=$G(PRCTMP(440.03,CONTIEN,1,"I"))
60 .I PRCFMOD=1 Q:$D(CONTENDA(9999999-CONTENDI)) S NEWADD=1
61 .S CONTENDA(9999999-CONTENDI)=CONTENDE_U_CONTENDI
62 .W !?2,"CONTRACT: ",CONT,?33,"END DATE: ",CONTENDE,?56,"START DATE: ",$G(PRCTMP(440.03,CONTIEN,.5,"E")) W:$G(PRCTMP(440.03,CONTIEN,.5,"E"))="" "NONE LISTED"
63 .Q
64 Q
65MSG1 ; Display current auto accrual information for PO
66 K MSG W ! N FIL S FIL=$$FILE^PRCFFU16
67 S MSG(1)="CURRENT VALUES FOR AUTO ACCRUAL FOR P.O. SERVICE ORDER:"
68 S MSG(2)=" ENDING DATE FOR SERVICE: "_$G(PRCTMP(FIL,+OB,29,"E"))
69 S MSG(3)=" AUTO ACCRUAL FLAG: "_$G(PRCTMP(FIL,+OB,30,"E"))
70 D EN^DDIOL(.MSG) K MSG
71 Q
72MSG2 ; Prompt for change if needed
73 N TAG S TAG=$$LABEL
74 K MSG W !! S MSG(1)="The Ending Date and the Auto Accrual Flag must now be entered for"
75 S MSG(2)="this obligation. The system will default to the Ending Date on the Vendor"
76 S MSG(3)="Contract from the "_TAG_", if available. Otherwise, the default Ending"
77 S MSG(4)="Date is the last date of the current month.",MSG(5)=" "
78 S MSG(6)="The Auto Accrual Flag tells FMS whether the "_TAG_" should be accrued."
79 S MSG(7)="The default value will be 'NO' if the Ending Date is within the same month."
80 S MSG(8)="To accrue the "_TAG_", change the flag to 'YES'."
81 D EN^DDIOL(.MSG) K MSG
82 Q
83CONTNUM ; Determine contract number
84 I $G(PRCTMP(410,IEN,11,"E"))="" Q
85 I $G(PRCTMP(410,IEN,13,"I"))]"" D
86 .S VENID=$G(PRCTMP(410,IEN,12,"I")) Q:VENID=""
87 .S VENCONT=$G(PRCTMP(410,IEN,13,"I"))
88 .S DIC="^PRC(440,"_VENID_",4,",DIC(0)="MNZ",X=VENCONT D ^DIC K DIC
89 .Q:Y<0 I Y>0 D
90 ..N DA S CONTIEN=+Y
91 ..S DIC=440,DR=6,DA=+VENID,DIQ="PRCTMP(",DIQ(0)="IEN",DR(440.03)=".5;1",DA(440.03)=CONTIEN D EN^DIQ1 K DIC,DIQ,DR
92 ..S CONTEND=$G(PRCTMP(440.03,CONTIEN,1,"E"))
93 ..Q
94 .Q
95 Q
96 ;
97MSG5 ; Exit message
98 W ! D EN^DDIOL("Returning to Obligation processing...") W !
99 Q
100LABEL() ; Determine label for messages
101 S LABEL=""
102 I '$D(PRCFA("MP")) S LABEL=""
103 I $D(TRNODE(0)) I $P(TRNODE(0),U,2)="O"!($P(TRNODE(0),U,2)="A") S LABEL="1358"
104 I $D(PRCFA("MP")),PRCFA("MP")=21 S LABEL="1358"
105 I $D(PRCFA("MP")),PRCFA("MP")=2 S LABEL="Purchase Order"
106 Q LABEL
Note: See TracBrowser for help on using the repository browser.