Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCSRIE

PRCSRIE.m

Go to the documentation of this file.
  1. PRCSRIE ;WISC/SAW/DXH - BUILD AND MAINTAIN REPETITIVE ITEM LIST FILE ;7.26.99
  1. V ;;5.1;IFCAP;**13,53**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;ENTER REP ITEM
  1. N CC S CC=0
  1. D ENF^PRCSUT(1) G W5^PRCSUT3:'$D(PRC("SITE")) G EXIT:Y<0
  1. ;I $$ISSUPFCP^PRCSCK(PRC("SITE"),+PRC("CP")) S CC=+$$SUPPLYCC^PRCSCK()
  1. ;I $$VALIDCC^PRCSECP(PRC("SITE"),+PRC("CP"),CC) S DIC("B")=CC G GOTDFLT
  1. S CC=$$GETCCCNT^PRCSECP(PRC("SITE"),+PRC("CP"))
  1. I 'CC G CC ;GO BAIL OUT IF NO CC'S DEFINED
  1. I +CC=1 S DIC("B")=$P(CC,U,2)
  1. GOTDFLT S DIC("A")="Select COST CENTER: "
  1. S DIC="^PRC(420,PRC(""SITE""),1,+PRC(""CP""),2,",DIC(0)="AEMNQZ"
  1. D ^DIC I Y'>0 G EXIT
  1. S Y=$P(Y(0),"^") I '$D(^PRCD(420.1,Y,0)) G ERREXIT
  1. ;
  1. STF N REP
  1. S REP=1
  1. S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")_"-"_Y
  1. D EN1^PRCSUT3
  1. S DLAYGO=410.3,DIC="^PRCS(410.3,",DIC(0)="LZ" D ^DIC K DLAYGO
  1. G W4^PRCSUT3:Y<0 S (PRCSDA,DA)=+Y
  1. L +^PRCS(410.3,DA):15 G:$T=0 PRCSRIE
  1. Q:$D(PRCHSPD)
  1. D NOW^%DTC S $P(^PRCS(410.3,DA,0),"^",2)=0,$P(^(0),"^",4)=%
  1. S PRCSNO=$P(^PRCS(410.3,DA,0),"^") S:$D(PRCSIP) $P(^(0),"^",3)=PRCSIP
  1. S DIC(0)="AEMQ",DIE=DIC,DR="[PRCSRI]",DIE("NO^")=1 D ^DIE
  1. S DA=PRCSDA L -^PRCS(410.3,DA) K DIE("NO^")
  1. D CALC^PRCSRIE1
  1. W1 W !!,"Would you like to create another repetitive item list entry"
  1. S %=2 D YN^DICN
  1. G W1:%=0,EXIT:%=2!(%<0)
  1. W !! K PRCSV,PRCSV1
  1. G PRCSRIE
  1. ;
  1. VENDOR ;INPUT TRANS VENDOR FIELD-410.3
  1. 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))
  1. I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",12)=2 S DIC("S")="I '$D(^PRC(440,""AC"",""S"",+Y))"
  1. S DIC="^PRC(441,Z0,2,",DIC(0)="QEMNZ" D ^DIC K DIC("S") I Y'>0 K X G EX1
  1. I '$D(^PRC(440,+Y,0)) K X G EX1
  1. S X=$P(^PRC(440,+Y,0),"^"),$P(^PRCS(410.3,DA(1),1,DA,0),"^",5)=+Y
  1. VENDOR1 S Z=$P(Y(0),"^",2) I Z="" D VENDOR2 Q
  1. I Z=0 W !,"NOTE: This item has a unit cost of $0.00" ;HEH-0502-40043
  1. S $P(^PRCS(410.3,DA(1),1,DA,0),"^",4)=Z
  1. EX I $P(Y(0),"^",12) W $C(7),!,"NOTE: This item has a minimum order quantity of ",$P(Y(0),"^",12)
  1. I $P(Y(0),"^",11) W $C(7),!,"NOTE: This item must be ordered in multiples of ",$P(Y(0),"^",11)
  1. 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)
  1. EX1 K DIC,Z0,Z("DR")
  1. Q
  1. ;
  1. VENDOR2 K DIC,Z0,Z("DR")
  1. S NOCOST=1
  1. S DIC(0)="AEMQ",DIC="^PRCS(410.3,",DIK=DIC_DA(1)_",1,"
  1. ;
  1. W !!," The vendor you have chosen has no unit cost for this item."
  1. W !," Please do one of the following:"
  1. W !," 1. Choose another item."
  1. W !," 2. Choose another vendor."
  1. W !," 3. Contact A&MM to enter the unit cost.",!!
  1. ;
  1. QUIT
  1. ;
  1. VENDORC ;CK MND SOURCE/PREF VENDOR
  1. S Z0=$P(^PRCS(410.3,DA(1),1,DA,0),"^") K PRCSV1 I 'Z0 K Z0 Q
  1. I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",12)=2 G V2
  1. S Z2=$P(^PRCS(410.3,DA(1),1,DA,0),"^",3),Z3="This item has a mandatory source (vendor) of "
  1. 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
  1. 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)
  1. K Z2,Z3 I $D(PRCSV) S Y(0)=$S($D(^PRC(441,Z0,2,Y,0)):^(0),1:"") G VENDOR1
  1. V2 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)
  1. 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
  1. Q
  1. CC 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
  1. EXIT K %,DA,DIC,DIE,DR,PRCSDA,PRCSL,PRCSNO,PRCSV,PRCSV1,Y(0),X,Y,Z,Z0,Z1 Q
  1. ERREXIT W $C(7),!!,"That Cost Center is invalid."
  1. R " Press return to continue: ",X:5
  1. G EXIT