PRCHQ1B ;(WASH ISC)/LKG - Request for Quotation ;8/6/96 20:48
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
BOCINP ;Input transform for BOC
N PRC2237,Z0,DIC
S PRC2237=$P($G(^PRC(444,D0,0)),U,9) I PRC2237'?1.N K X Q
S Z0=$S($D(^PRCS(410,PRC2237,3)):+$P(^(3),U,3),1:0)
I 'Z0!'$D(^PRCD(420.1,Z0,1,0)) K X Q
S DIC="^PRCD(420.1,Z0,1,",DIC(0)="EMQZ" D ^DIC
I +Y'>0 K X Q
S X=+$P(Y(0),U) I '$D(^PRCD(420.2,X,0)) K X Q
Q
BOCHLP ;Executable help for BOC
N PRCTXT,PRC2237,D,Z0,DIC,PRCDA S PRCDA=D0
S PRCTXT(1)="Major budget object code classifications are:"
S PRCTXT(2)="10 thru 13 - Personal Services and Benefits"
S PRCTXT(3)=" 21 - Travel and Transportation of Persons"
S PRCTXT(4)=" 22 - Transportation of Things"
S PRCTXT(5)=" 23 - Rent, Communications, and Utilities"
S PRCTXT(6)=" 24 - Printing and Reproduction"
S PRCTXT(7)=" 25 - Other Services"
S PRCTXT(8)=" 26 - Supplies and Materials"
S PRCTXT(9)="31 thru 33 - Acquisition of Capital Assets"
D EN^DDIOL(.PRCTXT)
S PRC2237=$P($G(^PRC(444,PRCDA,0)),U,9)
I PRC2237'?1.N D EN^DDIOL("2237 pointer is missing so can't determine available BOCs.") Q
S X="?",Z0=$S($D(^PRCS(410,PRC2237,3)):+$P(^(3),U,3),1:0)
I 'Z0!'$D(^PRCD(420.1,Z0,1,0)) D EN^DDIOL("2237's Cost Center is missing so can't determine available BOCs.") Q
S DIC="^PRCD(420.1,Z0,1,",DIC(0)="QEM" D ^DIC
Q
LINENET() ;Calculates the net line amount for item in quote
;;Net = Unit_Price * Quantity - Volume_Discount
N PRCX,PRCY
S PRCX=$$GET^DDSVAL(444.026,.DA,13)*$$GET^DDSVAL(444.026,.DA,2)
S PRCY=+$$GET^DDSVAL(444.026,.DA,14)
S PRCY=$S(PRCY>0:PRCX*PRCY/100,1:$$GET^DDSVAL(444.026,.DA,15))
S:PRCY>0 PRCX=PRCX-PRCY
Q $FN(PRCX,"",2)
STATUSDT ;Sets/Clears Date assigned critical statuses
N PRCI S PRCI=$S(X=0:16,X=2:15,X=3:12,X=4:13,X=5:14,1:"")
I PRCI]"" D
. N %,%H,%I,X D NOW^%DTC
. S $P(^PRC(444,DA,1),U,PRCI)=%
I X=1!(X=2) D
. S $P(^PRC(444,DA,1),U,12,13)="^"
Q
DUN(Z) ;Returns Dun number for Solicited Vendor (Z=5) or Quote Vendor (Z=8)
N X,Y S Y=""
I $D(D0),$D(D1) D
. S X=$P($G(^PRC(444,D0,Z,D1,0)),U) Q:X=""
. S Y=$S($P(X,";",2)[440:$P($G(^PRC(440,$P(X,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(X,";"),0)),U,2))
Q Y
QUOTETOT(PRCD0,PRCD1) ;Sets Total for Quote in field #8 of subfile #444.024
N PRCX,PRCI,DA,DIC,DIE,DR S PRCX=0,PRCI=0
F S PRCI=$O(^PRC(444,PRCD0,8,PRCD1,3,PRCI)) Q:PRCI'?1.N D
. S PRCX=PRCX+$P($G(^PRC(444,PRCD0,8,PRCD1,3,PRCI,1)),U,7)
S PRCX=PRCX+$P($G(^PRC(444,PRCD0,8,PRCD1,1)),U,2)
S DA=PRCD1,DA(1)=PRCD0,DIE="^PRC(444,DA(1),8,",DR="8///^S X=PRCX"
D ^DIE
Q
PUBLIC ;Sets Required status of Transmit to Public field
N PRCX,PRCIENS
S PRCX=$$GET^DDSVAL(444,DA,6,"","I"),PRCX=$S(PRCX="m":0,1:1)
S PRCIENS=DA_","
D REQ^DDSUTL(2,"PRCHQ7",6,PRCX,PRCIENS)
Q
PUBLIC2 ;Sets Require status of Transmit to Public when Method
;of Processing Changes.
N PRCX,PRCIENS
S PRCIENS=DA_",",PRCX=$S(X="m":0,1:1)
D REQ^DDSUTL(2,"PRCHQ7",6,PRCX,PRCIENS)
Q
FCP ;Input Transform for Fund Control Point
N Z0,DIC
S Z0=$E($P(^PRC(444,DA,0),U),1,3) K:'Z0 X Q:'Z0
Q:'$D(^PRC(420,Z0,1,0))
S DIC="^PRC(420,Z0,1,",DIC(0)="QEMNZ" D ^DIC S X=$P(Y(0),U)
K:Y'>0 X
Q
FCPHLP ;Executable Help for Fund Control Point
N ZD,Z0,DIC
S:$D(D)#10=1 ZD=D,X="?",Z0=$E($P(^PRC(444,DA,0),U),1,3) Q:'Z0
Q:'$D(^PRC(420,Z0,1,0))
S DIC="^PRC(420,Z0,1,",DIC(0)="QEM" D ^DIC S:$D(ZD)#10=1 D=ZD
Q
REQDFLD1 ;Checks required fields in Item edit page
N PRCIT,PRCJ,PRCAR,PRCWP
S PRCJ=1
S PRCIT=$$GET^DDSVAL(444.019,.DA,.01)
I PRCIT="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Line Item # is missing"
S PRCWP=$$GET^DDSVAL(444.019,.DA,1.5)
I $P($G(@PRCWP@(0)),U,4)'>0 S PRCJ=PRCJ+1,PRCAR(PRCJ)="Description is missing for Item #"_PRCIT
I $$GET^DDSVAL(444.019,.DA,1.6)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Short Description is missing for Item #"_PRCIT
I $$GET^DDSVAL(444.019,.DA,3)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Unit of Purchase is missing for Item #"_PRCIT
I $$GET^DDSVAL(444.019,.DA,2)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Quantity is missing for Item #"_PRCIT
I $$GET^DDSVAL(444.019,.DA,6)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="SIC Code is missing for Item #"_PRCIT
I $$GET^DDSVAL(444.019,.DA,4)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Federal Supply Class is missing for Item #"_PRCIT
I $$GET^DDSVAL(444.019,.DA,12.5)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="BOC is missing for Item #"_PRCIT
I PRCJ>1 D
. S PRCAR(1)="** Warning: The following Required Fields were not completed: "
. D HLP^DDSUTL(.PRCAR) D HLP^DDSUTL("$$EOP")
Q
REQDFLD2 ;Checks required fields in Delivery Schedule
N PRCDS,PRCJ,PRCAR S PRCJ=1
Q:$G(DA)'>0
S PRCDS=$$GET^DDSVAL(444.039,.DA,.01) Q:PRCDS=""
I $$GET^DDSVAL(444.039,.DA,1)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Delivery Date is missing for Delivery Schedule #"_PRCDS
I $$GET^DDSVAL(444.039,.DA,2)="" S PRCJ=PRCJ+1,PRCAR(PRCJ)="Quantity is missing for Delivery Schedule #"_PRCDS
I PRCJ>1 D
. S PRCAR(1)="** Warning: The following Required Fields were not completed: "
. D HLP^DDSUTL(.PRCAR) D HLP^DDSUTL("$$EOP")
Q
METHOD(PRCX) ;Additional Data Validation for Method of Solicitation
Q:PRCX="m" N PRCVEN
S PRCVEN=$$GET^DDSVAL(444.01,.DA,.01,"","I")
I PRCVEN'["PRC(440" S DDSERROR=1
I PRCVEN["PRC(440",$P($G(^PRC(440,+PRCVEN,3)),U,2)'="Y" S DDSERROR=1
I PRCVEN["PRC(440",$P($G(^PRC(440,+PRCVEN,7)),U,12)="" S DDSERROR=1
D:$G(DDSERROR)=1 HLP^DDSUTL("Only MANUAL method is available for Non-EDI Vendor or vendor without Dun#.")
Q
DBCHK(PRCX) ;Validates Dun & Bradstreet # by Mod 10 and Mod 10 plus 5
N I,T,V,W,Y,Z S Y=$E(PRCX,$L(PRCX))
S W="" F I=1:1:$L(PRCX)-1 S Z=$E(PRCX,I),W=W_(1+(I#2=0)*Z)
S T=0 F I=1:1:$L(W) S T=T+$E(W,I)
S V=T\10+1*10-T,V=$E(V,$L(V))
I V=Y Q 1 ;Mod 10 checksum
S V=V+5,V=$E(V,$L(V)) I V=Y Q 1 ;Mod 10 plus 5 checksum
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ1B 5902 printed Sep 23, 2025@19:45:43 Page 2
PRCHQ1B ;(WASH ISC)/LKG - Request for Quotation ;8/6/96 20:48
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
BOCINP ;Input transform for BOC
+1 NEW PRC2237,Z0,DIC
+2 SET PRC2237=$PIECE($GET(^PRC(444,D0,0)),U,9)
IF PRC2237'?1.N
KILL X
QUIT
+3 SET Z0=$SELECT($DATA(^PRCS(410,PRC2237,3)):+$PIECE(^(3),U,3),1:0)
+4 IF 'Z0!'$DATA(^PRCD(420.1,Z0,1,0))
KILL X
QUIT
+5 SET DIC="^PRCD(420.1,Z0,1,"
SET DIC(0)="EMQZ"
DO ^DIC
+6 IF +Y'>0
KILL X
QUIT
+7 SET X=+$PIECE(Y(0),U)
IF '$DATA(^PRCD(420.2,X,0))
KILL X
QUIT
+8 QUIT
BOCHLP ;Executable help for BOC
+1 NEW PRCTXT,PRC2237,D,Z0,DIC,PRCDA
SET PRCDA=D0
+2 SET PRCTXT(1)="Major budget object code classifications are:"
+3 SET PRCTXT(2)="10 thru 13 - Personal Services and Benefits"
+4 SET PRCTXT(3)=" 21 - Travel and Transportation of Persons"
+5 SET PRCTXT(4)=" 22 - Transportation of Things"
+6 SET PRCTXT(5)=" 23 - Rent, Communications, and Utilities"
+7 SET PRCTXT(6)=" 24 - Printing and Reproduction"
+8 SET PRCTXT(7)=" 25 - Other Services"
+9 SET PRCTXT(8)=" 26 - Supplies and Materials"
+10 SET PRCTXT(9)="31 thru 33 - Acquisition of Capital Assets"
+11 DO EN^DDIOL(.PRCTXT)
+12 SET PRC2237=$PIECE($GET(^PRC(444,PRCDA,0)),U,9)
+13 IF PRC2237'?1.N
DO EN^DDIOL("2237 pointer is missing so can't determine available BOCs.")
QUIT
+14 SET X="?"
SET Z0=$SELECT($DATA(^PRCS(410,PRC2237,3)):+$PIECE(^(3),U,3),1:0)
+15 IF 'Z0!'$DATA(^PRCD(420.1,Z0,1,0))
DO EN^DDIOL("2237's Cost Center is missing so can't determine available BOCs.")
QUIT
+16 SET DIC="^PRCD(420.1,Z0,1,"
SET DIC(0)="QEM"
DO ^DIC
+17 QUIT
LINENET() ;Calculates the net line amount for item in quote
+1 ;;Net = Unit_Price * Quantity - Volume_Discount
+2 NEW PRCX,PRCY
+3 SET PRCX=$$GET^DDSVAL(444.026,.DA,13)*$$GET^DDSVAL(444.026,.DA,2)
+4 SET PRCY=+$$GET^DDSVAL(444.026,.DA,14)
+5 SET PRCY=$SELECT(PRCY>0:PRCX*PRCY/100,1:$$GET^DDSVAL(444.026,.DA,15))
+6 if PRCY>0
SET PRCX=PRCX-PRCY
+7 QUIT $FNUMBER(PRCX,"",2)
STATUSDT ;Sets/Clears Date assigned critical statuses
+1 NEW PRCI
SET PRCI=$SELECT(X=0:16,X=2:15,X=3:12,X=4:13,X=5:14,1:"")
+2 IF PRCI]""
Begin DoDot:1
+3 NEW %,%H,%I,X
DO NOW^%DTC
+4 SET $PIECE(^PRC(444,DA,1),U,PRCI)=%
End DoDot:1
+5 IF X=1!(X=2)
Begin DoDot:1
+6 SET $PIECE(^PRC(444,DA,1),U,12,13)="^"
End DoDot:1
+7 QUIT
DUN(Z) ;Returns Dun number for Solicited Vendor (Z=5) or Quote Vendor (Z=8)
+1 NEW X,Y
SET Y=""
+2 IF $DATA(D0)
IF $DATA(D1)
Begin DoDot:1
+3 SET X=$PIECE($GET(^PRC(444,D0,Z,D1,0)),U)
if X=""
QUIT
+4 SET Y=$SELECT($PIECE(X,";",2)[440:$PIECE($GET(^PRC(440,$PIECE(X,";"),7)),U,12),1:$PIECE($GET(^PRC(444.1,$PIECE(X,";"),0)),U,2))
End DoDot:1
+5 QUIT Y
QUOTETOT(PRCD0,PRCD1) ;Sets Total for Quote in field #8 of subfile #444.024
+1 NEW PRCX,PRCI,DA,DIC,DIE,DR
SET PRCX=0
SET PRCI=0
+2 FOR
SET PRCI=$ORDER(^PRC(444,PRCD0,8,PRCD1,3,PRCI))
if PRCI'?1.N
QUIT
Begin DoDot:1
+3 SET PRCX=PRCX+$PIECE($GET(^PRC(444,PRCD0,8,PRCD1,3,PRCI,1)),U,7)
End DoDot:1
+4 SET PRCX=PRCX+$PIECE($GET(^PRC(444,PRCD0,8,PRCD1,1)),U,2)
+5 SET DA=PRCD1
SET DA(1)=PRCD0
SET DIE="^PRC(444,DA(1),8,"
SET DR="8///^S X=PRCX"
+6 DO ^DIE
+7 QUIT
PUBLIC ;Sets Required status of Transmit to Public field
+1 NEW PRCX,PRCIENS
+2 SET PRCX=$$GET^DDSVAL(444,DA,6,"","I")
SET PRCX=$SELECT(PRCX="m":0,1:1)
+3 SET PRCIENS=DA_","
+4 DO REQ^DDSUTL(2,"PRCHQ7",6,PRCX,PRCIENS)
+5 QUIT
PUBLIC2 ;Sets Require status of Transmit to Public when Method
+1 ;of Processing Changes.
+2 NEW PRCX,PRCIENS
+3 SET PRCIENS=DA_","
SET PRCX=$SELECT(X="m":0,1:1)
+4 DO REQ^DDSUTL(2,"PRCHQ7",6,PRCX,PRCIENS)
+5 QUIT
FCP ;Input Transform for Fund Control Point
+1 NEW Z0,DIC
+2 SET Z0=$EXTRACT($PIECE(^PRC(444,DA,0),U),1,3)
if 'Z0
KILL X
if 'Z0
QUIT
+3 if '$DATA(^PRC(420,Z0,1,0))
QUIT
+4 SET DIC="^PRC(420,Z0,1,"
SET DIC(0)="QEMNZ"
DO ^DIC
SET X=$PIECE(Y(0),U)
+5 if Y'>0
KILL X
+6 QUIT
FCPHLP ;Executable Help for Fund Control Point
+1 NEW ZD,Z0,DIC
+2 if $DATA(D)#10=1
SET ZD=D
SET X="?"
SET Z0=$EXTRACT($PIECE(^PRC(444,DA,0),U),1,3)
if 'Z0
QUIT
+3 if '$DATA(^PRC(420,Z0,1,0))
QUIT
+4 SET DIC="^PRC(420,Z0,1,"
SET DIC(0)="QEM"
DO ^DIC
if $DATA(ZD)#10=1
SET D=ZD
+5 QUIT
REQDFLD1 ;Checks required fields in Item edit page
+1 NEW PRCIT,PRCJ,PRCAR,PRCWP
+2 SET PRCJ=1
+3 SET PRCIT=$$GET^DDSVAL(444.019,.DA,.01)
+4 IF PRCIT=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Line Item # is missing"
+5 SET PRCWP=$$GET^DDSVAL(444.019,.DA,1.5)
+6 IF $PIECE($GET(@PRCWP@(0)),U,4)'>0
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Description is missing for Item #"_PRCIT
+7 IF $$GET^DDSVAL(444.019,.DA,1.6)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Short Description is missing for Item #"_PRCIT
+8 IF $$GET^DDSVAL(444.019,.DA,3)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Unit of Purchase is missing for Item #"_PRCIT
+9 IF $$GET^DDSVAL(444.019,.DA,2)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Quantity is missing for Item #"_PRCIT
+10 IF $$GET^DDSVAL(444.019,.DA,6)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="SIC Code is missing for Item #"_PRCIT
+11 IF $$GET^DDSVAL(444.019,.DA,4)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Federal Supply Class is missing for Item #"_PRCIT
+12 IF $$GET^DDSVAL(444.019,.DA,12.5)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="BOC is missing for Item #"_PRCIT
+13 IF PRCJ>1
Begin DoDot:1
+14 SET PRCAR(1)="** Warning: The following Required Fields were not completed: "
+15 DO HLP^DDSUTL(.PRCAR)
DO HLP^DDSUTL("$$EOP")
End DoDot:1
+16 QUIT
REQDFLD2 ;Checks required fields in Delivery Schedule
+1 NEW PRCDS,PRCJ,PRCAR
SET PRCJ=1
+2 if $GET(DA)'>0
QUIT
+3 SET PRCDS=$$GET^DDSVAL(444.039,.DA,.01)
if PRCDS=""
QUIT
+4 IF $$GET^DDSVAL(444.039,.DA,1)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Delivery Date is missing for Delivery Schedule #"_PRCDS
+5 IF $$GET^DDSVAL(444.039,.DA,2)=""
SET PRCJ=PRCJ+1
SET PRCAR(PRCJ)="Quantity is missing for Delivery Schedule #"_PRCDS
+6 IF PRCJ>1
Begin DoDot:1
+7 SET PRCAR(1)="** Warning: The following Required Fields were not completed: "
+8 DO HLP^DDSUTL(.PRCAR)
DO HLP^DDSUTL("$$EOP")
End DoDot:1
+9 QUIT
METHOD(PRCX) ;Additional Data Validation for Method of Solicitation
+1 if PRCX="m"
QUIT
NEW PRCVEN
+2 SET PRCVEN=$$GET^DDSVAL(444.01,.DA,.01,"","I")
+3 IF PRCVEN'["PRC(440"
SET DDSERROR=1
+4 IF PRCVEN["PRC(440"
IF $PIECE($GET(^PRC(440,+PRCVEN,3)),U,2)'="Y"
SET DDSERROR=1
+5 IF PRCVEN["PRC(440"
IF $PIECE($GET(^PRC(440,+PRCVEN,7)),U,12)=""
SET DDSERROR=1
+6 if $GET(DDSERROR)=1
DO HLP^DDSUTL("Only MANUAL method is available for Non-EDI Vendor or vendor without Dun#.")
+7 QUIT
DBCHK(PRCX) ;Validates Dun & Bradstreet # by Mod 10 and Mod 10 plus 5
+1 NEW I,T,V,W,Y,Z
SET Y=$EXTRACT(PRCX,$LENGTH(PRCX))
+2 SET W=""
FOR I=1:1:$LENGTH(PRCX)-1
SET Z=$EXTRACT(PRCX,I)
SET W=W_(1+(I#2=0)*Z)
+3 SET T=0
FOR I=1:1:$LENGTH(W)
SET T=T+$EXTRACT(W,I)
+4 SET V=T\10+1*10-T
SET V=$EXTRACT(V,$LENGTH(V))
+5 ;Mod 10 checksum
IF V=Y
QUIT 1
+6 ;Mod 10 plus 5 checksum
SET V=V+5
SET V=$EXTRACT(V,$LENGTH(V))
IF V=Y
QUIT 1
+7 QUIT 0
