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