source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIE.m@ 1582

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PRCSRIE ;WISC/SAW/DXH - BUILD AND MAINTAIN REPETITIVE ITEM LIST FILE ;7.26.99
2V ;;5.1;IFCAP;**13,53**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;ENTER REP ITEM
5 N CC S CC=0
6 D ENF^PRCSUT(1) G W5^PRCSUT3:'$D(PRC("SITE")) G EXIT:Y<0
7 ;I $$ISSUPFCP^PRCSCK(PRC("SITE"),+PRC("CP")) S CC=+$$SUPPLYCC^PRCSCK()
8 ;I $$VALIDCC^PRCSECP(PRC("SITE"),+PRC("CP"),CC) S DIC("B")=CC G GOTDFLT
9 S CC=$$GETCCCNT^PRCSECP(PRC("SITE"),+PRC("CP"))
10 I 'CC G CC ;GO BAIL OUT IF NO CC'S DEFINED
11 I +CC=1 S DIC("B")=$P(CC,U,2)
12GOTDFLT S DIC("A")="Select COST CENTER: "
13 S DIC="^PRC(420,PRC(""SITE""),1,+PRC(""CP""),2,",DIC(0)="AEMNQZ"
14 D ^DIC I Y'>0 G EXIT
15 S Y=$P(Y(0),"^") I '$D(^PRCD(420.1,Y,0)) G ERREXIT
16 ;
17STF N REP
18 S REP=1
19 S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")_"-"_Y
20 D EN1^PRCSUT3
21 S DLAYGO=410.3,DIC="^PRCS(410.3,",DIC(0)="LZ" D ^DIC K DLAYGO
22 G W4^PRCSUT3:Y<0 S (PRCSDA,DA)=+Y
23 L +^PRCS(410.3,DA):15 G:$T=0 PRCSRIE
24 Q:$D(PRCHSPD)
25 D NOW^%DTC S $P(^PRCS(410.3,DA,0),"^",2)=0,$P(^(0),"^",4)=%
26 S PRCSNO=$P(^PRCS(410.3,DA,0),"^") S:$D(PRCSIP) $P(^(0),"^",3)=PRCSIP
27 S DIC(0)="AEMQ",DIE=DIC,DR="[PRCSRI]",DIE("NO^")=1 D ^DIE
28 S DA=PRCSDA L -^PRCS(410.3,DA) K DIE("NO^")
29 D CALC^PRCSRIE1
30W1 W !!,"Would you like to create another repetitive item list entry"
31 S %=2 D YN^DICN
32 G W1:%=0,EXIT:%=2!(%<0)
33 W !! K PRCSV,PRCSV1
34 G PRCSRIE
35 ;
36VENDOR ;INPUT TRANS VENDOR FIELD-410.3
37 Q:'$D(PRC("SITE")) Q:'$D(PRC("CP")) S Z0=$P(^PRCS(410.3,DA(1),1,DA,0),"^") K:'Z0 X G EX1:'Z0,EX1:'$D(^PRC(441,Z0,2,0))
38 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",12)=2 S DIC("S")="I '$D(^PRC(440,""AC"",""S"",+Y))"
39 S DIC="^PRC(441,Z0,2,",DIC(0)="QEMNZ" D ^DIC K DIC("S") I Y'>0 K X G EX1
40 I '$D(^PRC(440,+Y,0)) K X G EX1
41 S X=$P(^PRC(440,+Y,0),"^"),$P(^PRCS(410.3,DA(1),1,DA,0),"^",5)=+Y
42VENDOR1 S Z=$P(Y(0),"^",2) I Z="" D VENDOR2 Q
43 I Z=0 W !,"NOTE: This item has a unit cost of $0.00" ;HEH-0502-40043
44 S $P(^PRCS(410.3,DA(1),1,DA,0),"^",4)=Z
45EX I $P(Y(0),"^",12) W $C(7),!,"NOTE: This item has a minimum order quantity of ",$P(Y(0),"^",12)
46 I $P(Y(0),"^",11) W $C(7),!,"NOTE: This item must be ordered in multiples of ",$P(Y(0),"^",11)
47 I $P(Y(0),"^",8) S Z(1)=$P(Y(0),"^",7),Z(1)=$S($D(^PRCD(420.5,+Z(1),0)):$P(^(0),"^",2),1:"") I Z(1)'="" W $C(7),!,"NOTE: This item has a packaging multiple/unit of purchase of ",$P(Y(0),"^",8)_"/"_Z(1)
48EX1 K DIC,Z0,Z("DR")
49 Q
50 ;
51VENDOR2 K DIC,Z0,Z("DR")
52 S NOCOST=1
53 S DIC(0)="AEMQ",DIC="^PRCS(410.3,",DIK=DIC_DA(1)_",1,"
54 ;
55 W !!," The vendor you have chosen has no unit cost for this item."
56 W !," Please do one of the following:"
57 W !," 1. Choose another item."
58 W !," 2. Choose another vendor."
59 W !," 3. Contact A&MM to enter the unit cost.",!!
60 ;
61 QUIT
62 ;
63VENDORC ;CK MND SOURCE/PREF VENDOR
64 S Z0=$P(^PRCS(410.3,DA(1),1,DA,0),"^") K PRCSV1 I 'Z0 K Z0 Q
65 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",12)=2 G V2
66 S Z2=$P(^PRCS(410.3,DA(1),1,DA,0),"^",3),Z3="This item has a mandatory source (vendor) of "
67 I $P(^PRC(441,Z0,0),"^",8) S Y=$P(^(0),"^",8) I $D(^PRC(440,Y,0)) S X=$P(^(0),"^") Q:X=Z2
68 I W !,$C(7),Z3,X S $P(^PRCS(410.3,DA(1),1,DA,0),"^",3)=X,$P(^(0),"^",5)=Y,^PRCS(410.3,DA(1),1,"AC",X,DA)="",PRCSV=1 I Z2'="" K ^PRCS(410.3,DA(1),1,"AC",Z2,DA)
69 K Z2,Z3 I $D(PRCSV) S Y(0)=$S($D(^PRC(441,Z0,2,Y,0)):^(0),1:"") G VENDOR1
70V2 S X=0,X=$O(^PRC(441,Z0,4,"B",PRC("SITE")_$P(PRC("CP")," "),X)) I X,$D(^PRC(441,Z0,4,X,0)),$P(^(0),"^",3)'="" S PRCSV1=$P(^(0),"^",3)
71 I $D(PRCSV1),$D(^PRC(440,PRCSV1,0)) S PRCSV1=$P(^(0),"^") W !,$C(7),"The following is the preferred (but not mandatory) vendor for this item." K X,Z0
72 Q
73CC W $C(7),!!,"There are no cost centers entered for this station and control point in the Fund",!,"Control Point file. You must enter one or more cost centers before continuing." R !,"Press return to continue: ",X:5
74EXIT K %,DA,DIC,DIE,DR,PRCSDA,PRCSL,PRCSNO,PRCSV,PRCSV1,Y(0),X,Y,Z,Z0,Z1 Q
75ERREXIT W $C(7),!!,"That Cost Center is invalid."
76 R " Press return to continue: ",X:5
77 G EXIT
Note: See TracBrowser for help on using the repository browser.