PRCSES ;WISC/SAW-SUB-MODULES CALLED BY FIELDS IN CONTROL POINT ACT. FILE ;1/20/98 3:07 PM [7/14/98 3:04pm]
V ;;5.1;IFCAP;**150**;Oct 20, 2000;Build 24
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*150 Modifies TRAN* entrY point to quit if temp transaction
;
W !,"Major budget object code classifications are:"
W !,"10 thru 13 - Personal Services and Benefits"
W !," 21 - Travel and Transportation of Persons"
W !," 22 - Transportation of Things"
W !," 23 - Rent, Communications, and Utilities"
W !," 24 - Printing and Reproduction"
W !," 25 - Other Services"
W !," 26 - Supplies and Materials"
W !,"31 thru 33 - Acquisition of Capital Assets",!
Q
SUB ;INPUT TRANSFORM FOR BOC FIELD
S Z0=$S($D(^PRCS(410,DA(1),3)):+$P(^(3),"^",3),1:0)
SUB1 I 'Z0!('$D(^PRCD(420.1,Z0,1,0))) K Z0,X Q
S DIC="^PRCD(420.1,Z0,1,",DIC(0)="EMQZ" D ^DIC I +Y'>0 K DIC,X,Z0 Q
S X=+$P(Y(0),"^") I '$D(^PRCD(420.2,X,0)) K DIC,X,Z0 Q
S (PRCS("SUB"),X)=$E($P(^PRCD(420.2,X,0),"^"),1,30) K DIC,Z0 Q
;
VENDOR ;INPUT TRANSFORM FOR VENDOR FIELD
;
N IEN,LOOP,OK,PRCX,PRCY,NAME,N9,RV,RVX
K:X[""""!($A(X)=45)!($L(X)>30)!($L(X)<1)!((X?1P.E&'((X?1"`"1.N)!(X?1"**".E)))) X
W:'$D(X) !,$C(7),"The vendor name must be between 1 and 30 characters long,",!,"without a leading punctuation mark."
Q:'$D(X)
I $P(^PRCS(410,DA,0),"^",4)=5 D ISS Q:'$D(X) G VENDOR2
S PRCX=X
AGAIN I $G(RV)>0 S NAME=$P($G(^PRC(440,RV,0)),U)
I $G(RV)'>0 S X=PRCX
S Z("Z")=1
I $P(^PRCS(410,DA,0),"^",4)=3,$D(^(10)),$P(^(10),"^") D K X Q
. W !,$C(7),"This is a repetitive item type of request."
. W !,"Cancel this request if you wish to order from a different vendor."
. Q
K DIC
K Y
K Y(0)
S Z(1)=$G(X)
S DIC="^PRC(440,"
S DIC(0)=$S($G(RV)>0:"EMQZ",1:"EMZ")
S:$G(RV)>0 X="`"_RV
S DIC("S")="I '$D(^PRC(440,""AC"",""S"",+Y))"
D ^DIC
;
; QUIT IF USER TIMES OUT OR '^'s OUT.
;
I $D(DTOUT)!($D(DUOUT)) S X="^" Q
;
K:Y<0 X,RV
S IEN=Y
S PRCY(0)=$G(Y(0))
K:+IEN>0 OK,RV
D:+IEN>0 INACT
;
; ACTIVE VENDOR
;
I $G(OK)=1 G VENDOR2
;
; INACTIVE VENDOR WITH REPLACEMENT VENDOR
;
I $G(LOOP)=1!($G(RV)>0) K X,IEN,PRCY(0),DIC G AGAIN
;
; NO VENDOR SELECTED
;
I +IEN'>0 D
. S X=Z(1)
. K Z(1)
. I $D(^PRCS(410,DA,3)),$P(^(3),U,4)'="" S $P(^(3),"^",4)=""
. Q
;
; INACTIVE VENDOR WOTHOUT A REPLACEMENT VENDOR
;
I $G(RV)=0 D Q
. K X
. K Z(1)
. I $D(^PRCS(410,DA,3)),$P(^(3),U,4)'="" S $P(^(3),"^",4)=""
. Q
;
VENDOR1 I +IEN'>0 W !,"INVALID SELECTION OR NOT IN VENDOR FILE. ARE YOU SURE",$C(7) S %=2 D YN^DICN G VENDOR1:%=0 K:%'=1 X W:%=1 !!,"Enter information for new vendor"
;
VENDOR2 I +IEN>0 D
. S Z(1)="@1"
. S X=$P(PRCY(0),U)
. S ^PRCS(410,DA,2)=$P(PRCY(0),U,1,10)
. S $P(^PRCS(410,DA,3),"^",4)=+IEN
. Q
K %
K DIC
Q
;
ISS S IEN=$O(^PRC(440,"AC","S",0))
S PRCY(0)=$S($D(^PRC(440,+IEN,0)):^(0),1:"")
S X=$P(PRCY(0),"^")
I 'IEN!(PRCY(0)="") D K X Q
. W $C(7),"A&MM MUST enter the A&MM Warehouse as a vendor before you can place an"
. W !,"Issue Book request."
. Q
W !,"Issue Book Requests will automatically be ordered from",!,X,!
Q
;
INACT ; CHECK IF THE VENDOR SELECTED IS INACTIVE.
; IF INACTIVE, SEE IF THERE IS A REPLACEMENT VENDOR.
; IF THERE IS AN ACTIVE REPLACEMENT VENDOR SUGGEST THAT VENDOR
; TO THE USER.
;
; VARIABLES 'OK' AND 'RV' ARE UNDEFINED WHEN ENTERING 'INACT'.
;
; DIFFERENT OUTCOMES FROM INACT, AND OUTPUT VARIABLES.
;
; CONDITION OUTPUT
; VENDOR SELECTED BY USER IS ACTIVE. 'OK' SET TO 1
; VENDOR SELECTED BY USER IS INACTIVE,
; NO REPLACEMENT VENDOR AT END 'RV' SET TO 0
; OF CHAIN. 'LOOP' SET TO 1
; VENDOR SELECTED BY USER IS INACTIVE,
; REPLACEMENT VENDOR AT END OF 'RV' SET TO SUBSTITUTE
; CHAIN.XXVENDOR IEN
; 'LOOP' SET TO 1
;
S N10=$G(^PRC(440,+IEN,10))
I N10="" S OK=1 Q
I $P(N10,U,5)="" S OK=1 Q
S N9=$G(^PRC(440,+IEN,9))
S RV=+N9
I RV=+IEN S LOOP=1,RV=0
W !!,"The VENDOR you have chosen is Inactivated."
W:RV'>0 !,"You need to select an active vendor.",!!
;
;QUIT IF A REPLACEMENT VENDOR POINTS TO ITSELF
;
S LOOP=""
F Q:RV=0 S IVCK=$P($G(^PRC(440,RV,10)),U,5) Q:IVCK="" D Q:LOOP=1
. S RVX=$G(^PRC(440,RV,9))
. I RVX'>0 S LOOP=1 Q
. I RV=RVX S LOOP=1 Q
. S RV=RVX
. Q
;
;PAUSE IF THERE IS NO REPLACEMENT VENDOR TO ALLOW USER TO SEE MESSAGE
;
I RV'>0 D
. S DIR(0)="E"
. S DIR("A")="Press the return key to continue"
. D ^DIR
. Q
W:RV>0 !,"Here is the suggested REPLACEMENT VENDOR.",!!
Q
;
CC ;INPUT TRANSFORM FOR COST CENTER
N Z1 S Z0=$P(^PRCS(410,DA,0),"^",5),Z1=$S($D(^(3)):+$P(^(3),"^"),1:0) I 'Z0!('Z1) K X G CC1
I '$D(^PRC(420,Z0,1,0))!('$D(^PRC(420,Z0,1,Z1,2,0))) K X G CC1
S DIC="^PRC(420,Z0,1,Z1,2,",DIC(0)="QEMZ" D ^DIC I +Y'>0 K X G CC1
S X=$P(Y(0),"^") I '$D(^PRCD(420.1,X,0)) K X G CC1
S X=$E($P(^PRCD(420.1,X,0),"^"),1,30)
CC1 K DIC,Z0,Z1 Q
TRANS ;SET FOR X-REF ON TRANS $ AMT FIELD
Q:+$G(DA)=0 Q:+$G(^PRCS(410,DA,0))=0 ;PRC*5.1*150 Check to exclude temp transaction processing
G TRANS^PRCSEZ
TRANS1 Q:+$G(DA)=0 Q:+$G(^PRCS(410,DA,0))=0 ;PRC*5.1*150 Check to exclude temp transaction processing
G TRANS1^PRCSEZ
TRANK ;KILL FOR X-REF ON TRANS $ AMT FIELD
Q:+$G(DA)=0 Q:+$G(^PRCS(410,DA,0))=0 ;PRC*5.1*150 Check to exclude temp transaction processing
G TRANK^PRCSEZ
TRANK1 Q:+$G(DA)=0 Q:+$G(^PRCS(410,DA,0))=0 ;PRC*5.1*150 Check to exclude temp transaction processing
G TRANK1^PRCSEZ
STATUS ;COMPUTES STATUS OF PO FOR FIELD 54, FILE 410
S X="",Y(410)=$S($D(^PRCS(410,D0,10)):$P(^(10),"^",3),1:"")
I $D(^PRC(443,D0,0)) S Y(411)=$P(^(0),"^",7) I Y(411),$D(^PRCD(442.3,Y(411),0)) S X=$P(^(0),"^")
I Y(410),$D(^PRC(442,Y(410),7)) S Y(410)=$P(^(7),"^") I Y(410),$D(^PRCD(442.3,Y(410),0)) S X=$P(^(0),"^")
K Y(410),Y(411) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSES 6050 printed Sep 23, 2025@19:53:45 Page 2
PRCSES ;WISC/SAW-SUB-MODULES CALLED BY FIELDS IN CONTROL POINT ACT. FILE ;1/20/98 3:07 PM [7/14/98 3:04pm]
V ;;5.1;IFCAP;**150**;Oct 20, 2000;Build 24
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*150 Modifies TRAN* entrY point to quit if temp transaction
+4 ;
+5 WRITE !,"Major budget object code classifications are:"
+6 WRITE !,"10 thru 13 - Personal Services and Benefits"
+7 WRITE !," 21 - Travel and Transportation of Persons"
+8 WRITE !," 22 - Transportation of Things"
+9 WRITE !," 23 - Rent, Communications, and Utilities"
+10 WRITE !," 24 - Printing and Reproduction"
+11 WRITE !," 25 - Other Services"
+12 WRITE !," 26 - Supplies and Materials"
+13 WRITE !,"31 thru 33 - Acquisition of Capital Assets",!
+14 QUIT
SUB ;INPUT TRANSFORM FOR BOC FIELD
+1 SET Z0=$SELECT($DATA(^PRCS(410,DA(1),3)):+$PIECE(^(3),"^",3),1:0)
SUB1 IF 'Z0!('$DATA(^PRCD(420.1,Z0,1,0)))
KILL Z0,X
QUIT
+1 SET DIC="^PRCD(420.1,Z0,1,"
SET DIC(0)="EMQZ"
DO ^DIC
IF +Y'>0
KILL DIC,X,Z0
QUIT
+2 SET X=+$PIECE(Y(0),"^")
IF '$DATA(^PRCD(420.2,X,0))
KILL DIC,X,Z0
QUIT
+3 SET (PRCS("SUB"),X)=$EXTRACT($PIECE(^PRCD(420.2,X,0),"^"),1,30)
KILL DIC,Z0
QUIT
+4 ;
VENDOR ;INPUT TRANSFORM FOR VENDOR FIELD
+1 ;
+2 NEW IEN,LOOP,OK,PRCX,PRCY,NAME,N9,RV,RVX
+3 if X[""""!($ASCII(X)=45)!($LENGTH(X)>30)!($LENGTH(X)<1)!((X?1P.E&'((X?1"`"1.N)!(X?1"**".E))))
KILL X
+4 if '$DATA(X)
WRITE !,$CHAR(7),"The vendor name must be between 1 and 30 characters long,",!,"without a leading punctuation mark."
+5 if '$DATA(X)
QUIT
+6 IF $PIECE(^PRCS(410,DA,0),"^",4)=5
DO ISS
if '$DATA(X)
QUIT
GOTO VENDOR2
+7 SET PRCX=X
AGAIN IF $GET(RV)>0
SET NAME=$PIECE($GET(^PRC(440,RV,0)),U)
+1 IF $GET(RV)'>0
SET X=PRCX
+2 SET Z("Z")=1
+3 IF $PIECE(^PRCS(410,DA,0),"^",4)=3
IF $DATA(^(10))
IF $PIECE(^(10),"^")
Begin DoDot:1
+4 WRITE !,$CHAR(7),"This is a repetitive item type of request."
+5 WRITE !,"Cancel this request if you wish to order from a different vendor."
+6 QUIT
End DoDot:1
KILL X
QUIT
+7 KILL DIC
+8 KILL Y
+9 KILL Y(0)
+10 SET Z(1)=$GET(X)
+11 SET DIC="^PRC(440,"
+12 SET DIC(0)=$SELECT($GET(RV)>0:"EMQZ",1:"EMZ")
+13 if $GET(RV)>0
SET X="`"_RV
+14 SET DIC("S")="I '$D(^PRC(440,""AC"",""S"",+Y))"
+15 DO ^DIC
+16 ;
+17 ; QUIT IF USER TIMES OUT OR '^'s OUT.
+18 ;
+19 IF $DATA(DTOUT)!($DATA(DUOUT))
SET X="^"
QUIT
+20 ;
+21 if Y<0
KILL X,RV
+22 SET IEN=Y
+23 SET PRCY(0)=$GET(Y(0))
+24 if +IEN>0
KILL OK,RV
+25 if +IEN>0
DO INACT
+26 ;
+27 ; ACTIVE VENDOR
+28 ;
+29 IF $GET(OK)=1
GOTO VENDOR2
+30 ;
+31 ; INACTIVE VENDOR WITH REPLACEMENT VENDOR
+32 ;
+33 IF $GET(LOOP)=1!($GET(RV)>0)
KILL X,IEN,PRCY(0),DIC
GOTO AGAIN
+34 ;
+35 ; NO VENDOR SELECTED
+36 ;
+37 IF +IEN'>0
Begin DoDot:1
+38 SET X=Z(1)
+39 KILL Z(1)
+40 IF $DATA(^PRCS(410,DA,3))
IF $PIECE(^(3),U,4)'=""
SET $PIECE(^(3),"^",4)=""
+41 QUIT
End DoDot:1
+42 ;
+43 ; INACTIVE VENDOR WOTHOUT A REPLACEMENT VENDOR
+44 ;
+45 IF $GET(RV)=0
Begin DoDot:1
+46 KILL X
+47 KILL Z(1)
+48 IF $DATA(^PRCS(410,DA,3))
IF $PIECE(^(3),U,4)'=""
SET $PIECE(^(3),"^",4)=""
+49 QUIT
End DoDot:1
QUIT
+50 ;
VENDOR1 IF +IEN'>0
WRITE !,"INVALID SELECTION OR NOT IN VENDOR FILE. ARE YOU SURE",$CHAR(7)
SET %=2
DO YN^DICN
if %=0
GOTO VENDOR1
if %'=1
KILL X
if %=1
WRITE !!,"Enter information for new vendor"
+1 ;
VENDOR2 IF +IEN>0
Begin DoDot:1
+1 SET Z(1)="@1"
+2 SET X=$PIECE(PRCY(0),U)
+3 SET ^PRCS(410,DA,2)=$PIECE(PRCY(0),U,1,10)
+4 SET $PIECE(^PRCS(410,DA,3),"^",4)=+IEN
+5 QUIT
End DoDot:1
+6 KILL %
+7 KILL DIC
+8 QUIT
+9 ;
ISS SET IEN=$ORDER(^PRC(440,"AC","S",0))
+1 SET PRCY(0)=$SELECT($DATA(^PRC(440,+IEN,0)):^(0),1:"")
+2 SET X=$PIECE(PRCY(0),"^")
+3 IF 'IEN!(PRCY(0)="")
Begin DoDot:1
+4 WRITE $CHAR(7),"A&MM MUST enter the A&MM Warehouse as a vendor before you can place an"
+5 WRITE !,"Issue Book request."
+6 QUIT
End DoDot:1
KILL X
QUIT
+7 WRITE !,"Issue Book Requests will automatically be ordered from",!,X,!
+8 QUIT
+9 ;
INACT ; CHECK IF THE VENDOR SELECTED IS INACTIVE.
+1 ; IF INACTIVE, SEE IF THERE IS A REPLACEMENT VENDOR.
+2 ; IF THERE IS AN ACTIVE REPLACEMENT VENDOR SUGGEST THAT VENDOR
+3 ; TO THE USER.
+4 ;
+5 ; VARIABLES 'OK' AND 'RV' ARE UNDEFINED WHEN ENTERING 'INACT'.
+6 ;
+7 ; DIFFERENT OUTCOMES FROM INACT, AND OUTPUT VARIABLES.
+8 ;
+9 ; CONDITION OUTPUT
+10 ; VENDOR SELECTED BY USER IS ACTIVE. 'OK' SET TO 1
+11 ; VENDOR SELECTED BY USER IS INACTIVE,
+12 ; NO REPLACEMENT VENDOR AT END 'RV' SET TO 0
+13 ; OF CHAIN. 'LOOP' SET TO 1
+14 ; VENDOR SELECTED BY USER IS INACTIVE,
+15 ; REPLACEMENT VENDOR AT END OF 'RV' SET TO SUBSTITUTE
+16 ; CHAIN.XXVENDOR IEN
+17 ; 'LOOP' SET TO 1
+18 ;
+19 SET N10=$GET(^PRC(440,+IEN,10))
+20 IF N10=""
SET OK=1
QUIT
+21 IF $PIECE(N10,U,5)=""
SET OK=1
QUIT
+22 SET N9=$GET(^PRC(440,+IEN,9))
+23 SET RV=+N9
+24 IF RV=+IEN
SET LOOP=1
SET RV=0
+25 WRITE !!,"The VENDOR you have chosen is Inactivated."
+26 if RV'>0
WRITE !,"You need to select an active vendor.",!!
+27 ;
+28 ;QUIT IF A REPLACEMENT VENDOR POINTS TO ITSELF
+29 ;
+30 SET LOOP=""
+31 FOR
if RV=0
QUIT
SET IVCK=$PIECE($GET(^PRC(440,RV,10)),U,5)
if IVCK=""
QUIT
Begin DoDot:1
+32 SET RVX=$GET(^PRC(440,RV,9))
+33 IF RVX'>0
SET LOOP=1
QUIT
+34 IF RV=RVX
SET LOOP=1
QUIT
+35 SET RV=RVX
+36 QUIT
End DoDot:1
if LOOP=1
QUIT
+37 ;
+38 ;PAUSE IF THERE IS NO REPLACEMENT VENDOR TO ALLOW USER TO SEE MESSAGE
+39 ;
+40 IF RV'>0
Begin DoDot:1
+41 SET DIR(0)="E"
+42 SET DIR("A")="Press the return key to continue"
+43 DO ^DIR
+44 QUIT
End DoDot:1
+45 if RV>0
WRITE !,"Here is the suggested REPLACEMENT VENDOR.",!!
+46 QUIT
+47 ;
CC ;INPUT TRANSFORM FOR COST CENTER
+1 NEW Z1
SET Z0=$PIECE(^PRCS(410,DA,0),"^",5)
SET Z1=$SELECT($DATA(^(3)):+$PIECE(^(3),"^"),1:0)
IF 'Z0!('Z1)
KILL X
GOTO CC1
+2 IF '$DATA(^PRC(420,Z0,1,0))!('$DATA(^PRC(420,Z0,1,Z1,2,0)))
KILL X
GOTO CC1
+3 SET DIC="^PRC(420,Z0,1,Z1,2,"
SET DIC(0)="QEMZ"
DO ^DIC
IF +Y'>0
KILL X
GOTO CC1
+4 SET X=$PIECE(Y(0),"^")
IF '$DATA(^PRCD(420.1,X,0))
KILL X
GOTO CC1
+5 SET X=$EXTRACT($PIECE(^PRCD(420.1,X,0),"^"),1,30)
CC1 KILL DIC,Z0,Z1
QUIT
TRANS ;SET FOR X-REF ON TRANS $ AMT FIELD
+1 ;PRC*5.1*150 Check to exclude temp transaction processing
if +$GET(DA)=0
QUIT
if +$GET(^PRCS(410,DA,0))=0
QUIT
+2 GOTO TRANS^PRCSEZ
TRANS1 ;PRC*5.1*150 Check to exclude temp transaction processing
if +$GET(DA)=0
QUIT
if +$GET(^PRCS(410,DA,0))=0
QUIT
+1 GOTO TRANS1^PRCSEZ
TRANK ;KILL FOR X-REF ON TRANS $ AMT FIELD
+1 ;PRC*5.1*150 Check to exclude temp transaction processing
if +$GET(DA)=0
QUIT
if +$GET(^PRCS(410,DA,0))=0
QUIT
+2 GOTO TRANK^PRCSEZ
TRANK1 ;PRC*5.1*150 Check to exclude temp transaction processing
if +$GET(DA)=0
QUIT
if +$GET(^PRCS(410,DA,0))=0
QUIT
+1 GOTO TRANK1^PRCSEZ
STATUS ;COMPUTES STATUS OF PO FOR FIELD 54, FILE 410
+1 SET X=""
SET Y(410)=$SELECT($DATA(^PRCS(410,D0,10)):$PIECE(^(10),"^",3),1:"")
+2 IF $DATA(^PRC(443,D0,0))
SET Y(411)=$PIECE(^(0),"^",7)
IF Y(411)
IF $DATA(^PRCD(442.3,Y(411),0))
SET X=$PIECE(^(0),"^")
+3 IF Y(410)
IF $DATA(^PRC(442,Y(410),7))
SET Y(410)=$PIECE(^(7),"^")
IF Y(410)
IF $DATA(^PRCD(442.3,Y(410),0))
SET X=$PIECE(^(0),"^")
+4 KILL Y(410),Y(411)
QUIT
