- 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 Feb 18, 2025@23:36:02 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