source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM1.m@ 1141

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

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1PRCHAM1 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;3/29/93 10:03
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ASK K ^TMP("PRCHW",$J) S DIC="^PRCD(442.2,",DIC("S")="I Y>19,($P(^(0),U,3)]"""")" S:$D(PRCHNRQ) DIC("S")=DIC("S")_",(""25;26;28;35;36""'[Y)" S DIC(0)="QEAZ"
5 D ^DIC G:Y<0 CHK^PRCHAM K DIC I '$D(^PRCD(442.2,+Y,1)) W !!?5,"Amendment Lines in file 442.2 not defined " G ASK
6 S ROU=$P(Y(0),U,3),PRCHL1=$P(^PRCD(442.2,+Y,1),U,1),PRCHL2=$P(^(1),U,2) I $L($T(@ROU))<2 W !!?5,"Routine line not defined " G ASK
7 S PRCHT=1 D @ROU G ASK:PRCHT D EN^PRCHAM G ASK
8 ;S PRCHT=1 D @ROU S:'$D(PRCHT) PRCHT=1 G ASK:PRCHT D EN^PRCHAM G ASK
9DIE S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE Q
10EN1 ;P.O. CANCEL
11 S X=0 F I=0:0 S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,12) Q:X
12 I X W !?5,"PURCHASE ORDER HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) Q
13 S %="",%A=" SURE YOU WANT TO CANCEL PURCHASE ORDER ",%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING CANCELLED>" Q
14 S $P(^PRC(443.6,PRCHPO,6,PRCHAN,1),U,4)=$O(^PRCD(442.3,"C",45,0)),PRCHO=$P($P(PRCH(0),U,1),"-",2),PRCHN=".",PRCHCHK=1,PRCHT=0,PRCHAMT=-$P(PRCH(0),U,15) Q
15EN2 ;VENDOR EDIT
16 S PRCHO=+PRCH(1),DR=5 D DIE S PRCHN=+^PRC(443.6,PRCHPO,1) Q:PRCHO=PRCHN
17 S PRCHX(PRCHO,PRCHN)="^PRC(442,""D"",X,PRCHPO)",PRCHO=$S($D(^PRC(440,PRCHO,0)):$P(^(0),U,1),1:""),PRCHN=$S($D(^PRC(440,PRCHN,0)):$P(^(0),U,1),1:"")
18 S PRCHT=0,PRCHDL=1
19 Q
20EN3 ;REPLACE P.O. # THIS OPTION DOESN'T SEEM TO WORK CORRECTLY.
21 S PRCHO=$P(PRCH(0),U,1),PRCH=PRCHPO D PONO^PRCHAM5
22 I '$D(PRCHPO) S PRCHPO=PRCH Q
23 S X=45,DA=PRCHPO D ENS^PRCHSTAT
24 S PRCHN=$P(^PRC(442,PRCHPO,0),U,1),PRCHNPO=PRCHPO,PRCHPO=PRCH,PRCHNPO(0)=PRCHO,^(4,0)="^^1^1^"_DT,^(1,0)="This Purchase Order has been changed to "_PRCHN
25 S PRCHX(PRCHO,PRCHN)="^PRC(442,""B"",X,PRCHPO)",PRCHX($P(PRCHO,"-",2),$P(PRCHN,"-",2))="^PRC(442,""C"",X,PRCHPO)",PRCHX(PRCHN,PRCHO)="^PRC(442,""B"",X,PRCHNPO)",PRCHX($P(PRCHN,"-",2),$P(PRCHO,"-",2))="^PRC(442,""C"",X,PRCHNPO)"
26 S $P(^PRC(443.6,PRCHPO,0),U,1)=PRCHN,PRCHT=0,PRCHDL=1 D DOCID^PRCHAM5
27 Q
28EN4 ;F.C.P. EDIT
29 W $C(7),!!!,"NOTE:",!,"Please notify the service to make any necessary adjustments to both the",!,"previous and new Fund Control Points on this order, to make sure their",!,"balances are correct!!",!!
30 S PRCHAMND="",PRCHO=$P(PRCH(0),U,3),DR="S PRCHN(""CC"")="""";1;2//^S X=PRCHN(""CC"");5.2" D DIE K PRCHAMND S PRCHN=$P(^PRC(443.6,PRCHPO,0),U,3) Q:PRCHO=PRCHN
31 S PRCHX($P(PRCHO," ",1),$P(PRCHN," ",1))="^PRC(442,""E"",X,PRCHPO)"
32 S PRCHT=0,^TMP("PRCHW",$J,1)="Appropriation "_$P(PRCH(0),U,4)_"-"_$P(PRCHO," ",1)_" has been changed to "_$P(^PRC(443.6,PRCHPO,0),U,4)_"-"_$P($P(^(0),U,3)," ",1) Q
33EN5 ;SHIP TO EDIT
34 S:$P(PRCH(0),U,2)'=4 PRCHO=+$P(PRCH(1),U,3),DR=5.4 S:$P(PRCH(0),U,2)=4 PRCHO=+$P(PRCH(1),U,12),DR=5.3 D DIE
35 S PRCHN=$S($P(^PRC(443.6,PRCHPO,0),U,2)'=4:+$P(^(1),U,3),1:+$P(^(1),U,12)) Q:PRCHO=PRCHN
36 I $P(PRCH(0),U,2)'=4 S PRCHO=$S($D(^PRC(411,$E(PRCH(0),1,3),1,PRCHO,0)):$P(^(0),U,1),1:""),PRCHN=$S($D(^PRC(411,$E(PRCH(0),1,3),1,PRCHN,0)):$P(^(0),U,1),1:"")
37 E S PRCHO=$S($D(^PRC(440.2,PRCHO,0))&($D(^DPT(PRCHO,0))):$P(^(0),U,1),1:""),PRCHN=$S($D(^PRC(440.2,PRCHN,0))&($D(^DPT(PRCHN,0))):$P(^(0),U,1),1:"")
38 S PRCHT=0,PRCHDL=1 K DIC("DR") Q
39EN6 ;F.O.B. EDIT
40 S PRCHO=$P(PRCH(1),U,6),DR=6.4 D DIE S PRCHN=$P(^PRC(443.6,PRCHPO,1),U,6) Q:PRCHO=PRCHN
41 S PRCHT=0,PRCHDL=1,PRCHO=$S(PRCHO="O":"ORIGIN",1:"DESTINATION"),PRCHN=$S(PRCHN="O":"ORIGIN",1:"DESTINATION") Q
42EN7 ;PROMPT PAYMENT EDIT
43 G EN7^PRCHAM5
44EN8 ;EST. SHIPPING EDIT
45 G EN8^PRCHAM3
46EN9 ;DESCRIPTION
47 S DIE="^PRC(443.6,",DA=PRCHPO,DR="[PRCHAMDESC]" D ^DIE
48 S PRCHT=1,PRCHCHK=1 Q
49EN10 ;LINE ITEM ADD
50 S (PRCHN,PRCHO)="" G EN10^PRCHAM2
51EN11 ;LINE ITEM DELETE
52 S (PRCHN,PRCHO)="" G EN11^PRCHAM2
53EN12 ;LINE ITEM EDIT
54 S (PRCHN,PRCHO)="" G EN12^PRCHAM2
55EN13 ;SOURCE CODE EDIT
56 S PRCHO=$P(PRCH(1),U,7),DR=8 D DIE S PRCHN=$P(^PRC(443.6,PRCHPO,1),U,7) Q:PRCHO=PRCHN
57 S PRCHT=0,X=PRCHO D TP S PRCHO=X,X=PRCHN D TP S PRCHN=X Q
58EN14 ;ITEM DISCOUNT ADD
59 G EN14^PRCHAM3
60EN15 ;ITEM DISCOUNT DELETE
61 G EN15^PRCHAM3
62EN16 ;ITEM DISCOUNT EDIT
63 G EN16^PRCHAM3
64TP S X=$S($D(^PRCD(420.8,X,0)):$P(^(0),U,1),1:"") S:X="B" X="Combination of 2,4,6" Q
65QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR K PRCSIG,ROUTINE S PRCHT=1 Q
Note: See TracBrowser for help on using the repository browser.