source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFAC0.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PRCFAC0 ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS OBLIGATIONS ;11/4/92 4:32 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCFSITE G:'% OUT3^PRCFAC01
5 K DIC("A") S D="C",DIC("S")="I $D(^(7)),+^(0)=PRC(""SITE""),$D(^PRCD(442.3,+^(7),0)) S FSO=$P(^(0),U,3) I FSO>9,FSO<21",DIC("A")="Select Purchase Order Number: ",DIC=442,DIC(0)="AEQZ" D IX^DIC K DIC("S"),DIC("A"),FSO G:+Y<0 OUT3^PRCFAC01
6 S PO(0)=Y(0),PO=Y,PRCFA("PODA")=+Y,PCP=+$P(PO(0),"^",3),$P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
7 I +$P(PO(0),U,3)=0!('$D(^PRC(420,PRC("SITE"),1,+PCP,0))) W $C(7),"PURCHASE ORDER DOES NOT CONTAIN A CONTROL POINT.",!,"UNABLE TO PROCESS, PLEASE RETURN TO SUPPLY FOR CORRECTION!" G OUT3^PRCFAC01
8 I $P(PO(0),U,5)="",$P(PCP,"^",2)<2 F II=0:0 D CCEDIT Q:$P(PO(0),"^",5)]"" G:'% OUT3^PRCFAC01
9 I +$P(PO(0),"^",16)=0 D NC G OUT3^PRCFAC01:%<0,NC^PRCFAC01:%=2
10 I $P(PO(0),U,6)="",+$P(PO(0),U,7)'=0,$P(PCP,"^",2)="" F II=0:0 W !!,"No BOC data has been recorded for this Purchase Order.",$C(7) D SAEDIT Q:($P(PO(0),"^",6)]""&(+$P(PO(0),"^",7)=0)) Q:%<0
11SC ;PAINT SCREEN
12 I '$D(IOF)!('$D(IOM)) S IOP="HOME" D ^%ZIS K POP
13 K II W @IOF,!?(IOM-37\2),"PURCHASE ORDER - "_$P(PO(0),"^"),!!," COST CENTER: "_$P(PO(0),"^",5),?IOM\2-4,"CONTROL POINT: "_$P(PO(0),"^",3)
14 W !!,"BOC #1: "_$P(PO(0),"^",6),?IOM\2,"AMOUNT #1: $ "_$J($P(PO(0),"^",7),0,2),!!
15 I $P(PO(0),"^",8)]"",$P(PO(0),"^",9)]"" W "BOC #2: "_$P(PO(0),"^",8),?IOM\2,"AMOUNT #2: $ "_$J($P(PO(0),"^",9),0,2),!!
16 D:$D(^PRC(442,PRCFA("PODA"),13)) ^PRCFAC0J
17 S %A="The information listed above is recorded on this Purchase order.",%A(1)="Is this information correct",%B="Entering a 'NO' will allow you to edit the Cost Center and BOCs.",%B(1)="An '^' will terminate the option.",%=1
18 D ^PRCFYN G OUT3^PRCFAC01:%<1 I %=2 D:$P(PCP,"^",2)<2 CCEDIT G:'% OUT3^PRCFAC01 D:$P(PCP,"^",2)="" SAEDIT G SC
19 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P($P(PO(0),"^",3)," "),C1=1
20 G ^PRCFAC01
21ONEITEM S DIC("A")="Select ITEM: ",DA=PRCFA("PODA"),DIC="^PRC(442,"_DA_",2,",DIC(0)="AEQMZ" D ^DIC K DIC("A") I Y<0 S:X["^" PRCFOUT="" D ^PRCHS S PO(0)=^PRC(442,PRCFA("PODA"),0) S %=$S($D(PRCFOUT):-1,1:1) Q
22 S DA=+Y,DIE=DIC,DR=3.5 D ^DIE S DIC("A")="Select Next ITEM: " G ONEITEM
23ALLITEMS S DIC=420.2,DIC(0)="AQEMNZ" D ^DIC Q:Y<0 S SA=+Y
24 I $P(PO(0),"^",5)="" W !,"You're missing a Cost Center. Let's start over." G OUT3^PRCFAC01
25 S SA=Y(0) I '$D(^PRCD(420.1,$P(PO(0),"^",5),1,+SA)) W $C(7) S %A="BOC "_+SA_" is not valid with Cost Center "_$P(PO(0),"^",5)_". OK to continue",%B="",%=2 D ^PRCFYN I %'=1 S %=-1 Q
26 S %A="I will now enter BOC "_+SA_", on all items. Is this OK",%B="",%=2 D ^PRCFYN Q:%'=1
27 S DA=0 F I=1:1 S DA=$O(^PRC(442,+PO,2,DA)) Q:'DA S:$D(^(DA,0)) $P(^(0),"^",4)=$P(SA,"^")
28 K SA S DA=PRCFA("PODA") D ^PRCHS S PO(0)=^PRC(442,PRCFA("PODA"),0) Q
29SAEDIT S %A="Do you wish to assign the same BOC to ALL items",%B="",%=2 D ^PRCFYN G ALLITEMS:%=1,ONEITEM:%=2 Q
30CCEDIT S DA=PRCFA("PODA"),DR="2;",DIE="^PRC(442," D ^DIE S %=1 I $D(Y) S %=0 Q
31 S PO(0)=^PRC(442,DA,0) Q
32NC S %A="This order appears to be a 'NO CHARGE' order. Do you need to take",%A(1)="any action on this order",%B="'No' will mark the order appropriately and return it to supply."
33 S %B(1)="'Yes' will allow you to continue and create a code sheet.",%B(2)="'^' to exit.",%=2 D ^PRCFYN Q:%'=2
34 D SIG^PRCFACX0 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") S %=-1 Q
35 S %=2 Q
Note: See TracBrowser for help on using the repository browser.