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 Dec 13, 2024@02:18:25 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
