PRCHP18 ;SF/FKV-PRINT REQUEST FOR QUOTATIONS--STANDARD FORM 18 ;7/21/99 13:35
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN D:$D(ZTSK) KILL^%ZTLOAD K ZTSK Q:'$D(PRC("SITE")) S PRCHUNDL="",U="^" F I=1:1:98 S PRCHUNDL=PRCHUNDL_"_"
I '$D(^PRC(411,+SITE,3)) W !!,"**** MISSING SITE ADDRESS--SITE "_SITE_" PROGRAM PRCHP18 **** !!!" G EXIT
; GET SITE ADDRESS FROM ADMIN.SITE PARAMETER FILE
D FTYP1^PRCHFPNT
K PRCHS S S=^PRC(411,+SITE,3),PRCHS(1)=PRCHFTYP_" Chief, A&MM Svc. (90C)",J=1 F I=1:1:2 I $P(S,U,I)'="" S J=J+1,PRCHS(J)=$P(S,U,I)
S J=J+1,PRCHS(J)=$P(S,U,3)_", "_$P($G(^DIC(5,+$P(S,U,4),0)),U,2)_" "_$P(S,U,5) K S I J<4 F I=(J+1):1:4 S J=J+1,PRCHS(J)=""
; GET 'DESTINATION' ADDRESS SELECTED BY OPERATOR, FROM ^TMP
K PRCHD S D=$G(^TMP($J,"D")),J=0 F I=1:1:4 I $P(D,U,I)'="" S J=J+1,PRCHD(J)=$P(D,U,I)
S J=J+1,PRCHD(J)=$P(D,U,5)_", "_$P($G(^DIC(5,+$P(D,U,6),0)),U,2)_" "_$P(D,U,7) K D I J<5 F I=(J+1):1:5 S J=J+1,PRCHD(J)=""
D NOW^%DTC S Y=X D DD^%DT S PRCHDT=Y,Y=PRCHDT1 D DD^%DT S PRCHDT1=Y,Y=PRCHDT2 D DD^%DT S PRCHDT2=Y
; PRINT A REQUEST FOR QUOTATION FOR EACH VENDOR IN OPERATOR'S LIST
S PRCHVCNT=0 D RDV W $C(13) G EXIT
;
RDV N PRCHVFX,PRCHVPH,VENTENOD
S PRCHVCNT=$O(^TMP($J,"V",PRCHVCNT)) Q:'PRCHVCNT
I '$D(^PRCS(410,PRCHD0,0)) W !!,"*** MISSING REQUEST NUMBER "_PRCHD0_" -- PROGRAM PRCHP18 ***" G RDV
; GET VENDOR ADDRESS FROM VENDOR FILE
S V=$G(^PRC(440,PRCHVCNT,0)) I V="" W !!,"*** MISSING VENDOR NUMBER "_PRCHVCNT_" -- PROGRAM PRCHP18 ***" G RDV
S PRCHVPH=$P(V,U,10)
K PRCHV S J=0 F I=1:1:4 I $P(V,U,I)'="" S J=J+1,PRCHV(J)=$P(V,U,I)
S:J=4 PRCHV(J)=PRCHV(J)_" "_$P(V,U,5) S J=J+1,PRCHV(J)=$P(V,U,6)_", "_$P($G(^DIC(5,+$P(V,U,7),0)),U,2)_" "_$P(V,U,8) K V I J<5 F I=(J+1):1:5 S J=J+1,PRCHV(J)=""
S VENTENOD=$G(^PRC(440,PRCHVCNT,10))
I $D(VENTENOD) S PRCHVFX=$P(VENTENOD,U,6)
I '$D(^PRC(443,PRCHD0,0)) W !!,"*** MISSING P.A. INFORMATION FOR REQUEST "_$P(^PRCS(410,PRCHD0,0),U,1)_" ***" G RDV
N PRCHPA,PRCHPAP,PRCPAFAX,PRCEMAIL
S X=+$P(^PRC(443,PRCHD0,0),U,5)
I X>0 D
. N PRCX,DIC,DR,DA,DIQ
. K ^UTILITY("DIQ1",$J)
. S DIC=200,DR=".01;.135;.136;.151",DA=+X,DIQ="PRCX",DIQ(0)="I" D EN^DIQ1
. S PRCHPA=PRCX(200,DA,.01,"I"),PRCHPAP=PRCX(200,DA,.135,"I")
. S PRCPAFAX=PRCX(200,DA,.136,"I"),PRCEMAIL=PRCX(200,DA,.151,"I")
. K ^UTILITY("DIQ1",$J)
S PRCHPAGE=1
W @IOF,?65,"FORM APPROVED OMB NO. 2900-0445",!,PRCHUNDL,!,"REQUEST FOR QUOTATIONS |",?28,"The Notice of Small Business-Small Purchase Set-Aside",?82,"|",?85,"PAGE OF PAGES",!
W ?1,"(this is not an order)",?25,"|",?29,"on the last page of this form",?82,"|",?90,"|",!,?25,"|",?28,"_____is _____is not applicable.",?82,"| 1",?90,"|",!
W $E(PRCHUNDL,1,25),"|",$E(PRCHUNDL,1,56),"|",$E(PRCHUNDL,1,7),"|",$E(PRCHUNDL,1,7),!
W "1.REQUEST NO.",?14,"|2.DATE ISSUED",?30,"|3.REQUISITION/PURCHASE REQUEST",?63,"|4.CERT.FOR NAT.DEF.",?84,"|RATING",!
W ?14,"|",?30,"|",?33,"NO.",?63,"|",?66,"UNDER BDSA REG.2",?84,"|",!
W ?14,"|",?16,PRCHDT,?30,"|",?36,$P(^PRCS(410,PRCHD0,0),U,1),?63,"|",?66,"AND/OR DMS REG.1->",?84,"|",!
W $E(PRCHUNDL,1,14)_"|"_$E(PRCHUNDL,1,15)_"|"_$E(PRCHUNDL,1,32)_"|"_$E(PRCHUNDL,1,20),"|",$E(PRCHUNDL,1,13),!
W "5A.ISSUED BY",?14,PRCHS(1),?63,"|6.DELIVER BY (Date)",!
W ?14,PRCHS(2),?63,"|",!,?14,PRCHS(3),?63,"| ",PRCHDT2,!,?14,PRCHS(4),?63,"|",$E(PRCHUNDL,1,34),!,$E(PRCHUNDL,1,63)_"|7.DELIVERY",!
W "5B.FOR INFORMATION CALL:(Name & phone no.) (No collect calls)",?63,"|(Unless otherwise specified)"
W !,?4,$G(PRCHPA)," PHONE: ",$G(PRCHPAP),?63,"|",?68,"FOB",?84,"OTHER",!
W ?9,"FAX: ",$G(PRCPAFAX),?63,"|",?64,"_X__DESTINATION",?80,"____(See Schedule)",!
W:$G(PRCEMAIL)]"" "E-MAIL: ",PRCEMAIL W ?63,"|",!
W $E(PRCHUNDL,1,63),"|",$E(PRCHUNDL,1,34),!
W "8.TO: NAME AND ADDRESS, INCLUDING ZIP CODE",?63,"|9.DESTINATION (Consignee and ad-",!
W ?10,PRCHV(1),?63,"|",?69,"dress, including ZIP code)",! F I=2:1:5 W ?10,PRCHV(I),?63,"| ",PRCHD(I-1),!
W "PHONE: "_$G(PRCHVPH),?32,"FAX: "_$G(PRCHVFX),?63,"|",!
W:PRCHD(5)'="" ?63,"| ",PRCHD(5),! W $E(PRCHUNDL,1,63),"|",$E(PRCHUNDL,1,34),!
G EN^PRCHP181
;
ENDRPT G RDV
;
EXIT K PRCHI,PRCHUNDL,D0,P,PRCHCNT,PRCHFTYP,PRCHIMAS,PRCHIOP,PRCHITEM,PRCHQTY,PRCHUNIT,PRCHX,PRCHD,PRCHD0,PRCHDT,PRCHDT1,PRCHDT2,PRCHPM,PRCHPA,PRCHPAGE
K PRCHPAP,PRCHS,PRCHV,PRCHVCNT,PRCHDY,S,I,J,K,X,Y,PRCHFL,PRCHUP,PRCHNSN,PRCHVS,PRCHLI,^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHP18 4445 printed Apr 09, 2024@21:13:40 Page 2
PRCHP18 ;SF/FKV-PRINT REQUEST FOR QUOTATIONS--STANDARD FORM 18 ;7/21/99 13:35
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
if '$DATA(PRC("SITE"))
QUIT
SET PRCHUNDL=""
SET U="^"
FOR I=1:1:98
SET PRCHUNDL=PRCHUNDL_"_"
+1 IF '$DATA(^PRC(411,+SITE,3))
WRITE !!,"**** MISSING SITE ADDRESS--SITE "_SITE_" PROGRAM PRCHP18 **** !!!"
GOTO EXIT
+2 ; GET SITE ADDRESS FROM ADMIN.SITE PARAMETER FILE
+3 DO FTYP1^PRCHFPNT
+4 KILL PRCHS
SET S=^PRC(411,+SITE,3)
SET PRCHS(1)=PRCHFTYP_" Chief, A&MM Svc. (90C)"
SET J=1
FOR I=1:1:2
IF $PIECE(S,U,I)'=""
SET J=J+1
SET PRCHS(J)=$PIECE(S,U,I)
+5 SET J=J+1
SET PRCHS(J)=$PIECE(S,U,3)_", "_$PIECE($GET(^DIC(5,+$PIECE(S,U,4),0)),U,2)_" "_$PIECE(S,U,5)
KILL S
IF J<4
FOR I=(J+1):1:4
SET J=J+1
SET PRCHS(J)=""
+6 ; GET 'DESTINATION' ADDRESS SELECTED BY OPERATOR, FROM ^TMP
+7 KILL PRCHD
SET D=$GET(^TMP($JOB,"D"))
SET J=0
FOR I=1:1:4
IF $PIECE(D,U,I)'=""
SET J=J+1
SET PRCHD(J)=$PIECE(D,U,I)
+8 SET J=J+1
SET PRCHD(J)=$PIECE(D,U,5)_", "_$PIECE($GET(^DIC(5,+$PIECE(D,U,6),0)),U,2)_" "_$PIECE(D,U,7)
KILL D
IF J<5
FOR I=(J+1):1:5
SET J=J+1
SET PRCHD(J)=""
+9 DO NOW^%DTC
SET Y=X
DO DD^%DT
SET PRCHDT=Y
SET Y=PRCHDT1
DO DD^%DT
SET PRCHDT1=Y
SET Y=PRCHDT2
DO DD^%DT
SET PRCHDT2=Y
+10 ; PRINT A REQUEST FOR QUOTATION FOR EACH VENDOR IN OPERATOR'S LIST
+11 SET PRCHVCNT=0
DO RDV
WRITE $CHAR(13)
GOTO EXIT
+12 ;
RDV NEW PRCHVFX,PRCHVPH,VENTENOD
+1 SET PRCHVCNT=$ORDER(^TMP($JOB,"V",PRCHVCNT))
if 'PRCHVCNT
QUIT
+2 IF '$DATA(^PRCS(410,PRCHD0,0))
WRITE !!,"*** MISSING REQUEST NUMBER "_PRCHD0_" -- PROGRAM PRCHP18 ***"
GOTO RDV
+3 ; GET VENDOR ADDRESS FROM VENDOR FILE
+4 SET V=$GET(^PRC(440,PRCHVCNT,0))
IF V=""
WRITE !!,"*** MISSING VENDOR NUMBER "_PRCHVCNT_" -- PROGRAM PRCHP18 ***"
GOTO RDV
+5 SET PRCHVPH=$PIECE(V,U,10)
+6 KILL PRCHV
SET J=0
FOR I=1:1:4
IF $PIECE(V,U,I)'=""
SET J=J+1
SET PRCHV(J)=$PIECE(V,U,I)
+7 if J=4
SET PRCHV(J)=PRCHV(J)_" "_$PIECE(V,U,5)
SET J=J+1
SET PRCHV(J)=$PIECE(V,U,6)_", "_$PIECE($GET(^DIC(5,+$PIECE(V,U,7),0)),U,2)_" "_$PIECE(V,U,8)
KILL V
IF J<5
FOR I=(J+1):1:5
SET J=J+1
SET PRCHV(J)=""
+8 SET VENTENOD=$GET(^PRC(440,PRCHVCNT,10))
+9 IF $DATA(VENTENOD)
SET PRCHVFX=$PIECE(VENTENOD,U,6)
+10 IF '$DATA(^PRC(443,PRCHD0,0))
WRITE !!,"*** MISSING P.A. INFORMATION FOR REQUEST "_$PIECE(^PRCS(410,PRCHD0,0),U,1)_" ***"
GOTO RDV
+11 NEW PRCHPA,PRCHPAP,PRCPAFAX,PRCEMAIL
+12 SET X=+$PIECE(^PRC(443,PRCHD0,0),U,5)
+13 IF X>0
Begin DoDot:1
+14 NEW PRCX,DIC,DR,DA,DIQ
+15 KILL ^UTILITY("DIQ1",$JOB)
+16 SET DIC=200
SET DR=".01;.135;.136;.151"
SET DA=+X
SET DIQ="PRCX"
SET DIQ(0)="I"
DO EN^DIQ1
+17 SET PRCHPA=PRCX(200,DA,.01,"I")
SET PRCHPAP=PRCX(200,DA,.135,"I")
+18 SET PRCPAFAX=PRCX(200,DA,.136,"I")
SET PRCEMAIL=PRCX(200,DA,.151,"I")
+19 KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
+20 SET PRCHPAGE=1
+21 WRITE @IOF,?65,"FORM APPROVED OMB NO. 2900-0445",!,PRCHUNDL,!,"REQUEST FOR QUOTATIONS |",?28,"The Notice of Small Business-Small Purchase Set-Aside",?82,"|",?85,"PAGE OF PAGES",!
+22 WRITE ?1,"(this is not an order)",?25,"|",?29,"on the last page of this form",?82,"|",?90,"|",!,?25,"|",?28,"_____is _____is not applicable.",?82,"| 1",?90,"|",!
+23 WRITE $EXTRACT(PRCHUNDL,1,25),"|",$EXTRACT(PRCHUNDL,1,56),"|",$EXTRACT(PRCHUNDL,1,7),"|",$EXTRACT(PRCHUNDL,1,7),!
+24 WRITE "1.REQUEST NO.",?14,"|2.DATE ISSUED",?30,"|3.REQUISITION/PURCHASE REQUEST",?63,"|4.CERT.FOR NAT.DEF.",?84,"|RATING",!
+25 WRITE ?14,"|",?30,"|",?33,"NO.",?63,"|",?66,"UNDER BDSA REG.2",?84,"|",!
+26 WRITE ?14,"|",?16,PRCHDT,?30,"|",?36,$PIECE(^PRCS(410,PRCHD0,0),U,1),?63,"|",?66,"AND/OR DMS REG.1->",?84,"|",!
+27 WRITE $EXTRACT(PRCHUNDL,1,14)_"|"_$EXTRACT(PRCHUNDL,1,15)_"|"_$EXTRACT(PRCHUNDL,1,32)_"|"_$EXTRACT(PRCHUNDL,1,20),"|",$EXTRACT(PRCHUNDL,1,13),!
+28 WRITE "5A.ISSUED BY",?14,PRCHS(1),?63,"|6.DELIVER BY (Date)",!
+29 WRITE ?14,PRCHS(2),?63,"|",!,?14,PRCHS(3),?63,"| ",PRCHDT2,!,?14,PRCHS(4),?63,"|",$EXTRACT(PRCHUNDL,1,34),!,$EXTRACT(PRCHUNDL,1,63)_"|7.DELIVERY",!
+30 WRITE "5B.FOR INFORMATION CALL:(Name & phone no.) (No collect calls)",?63,"|(Unless otherwise specified)"
+31 WRITE !,?4,$GET(PRCHPA)," PHONE: ",$GET(PRCHPAP),?63,"|",?68,"FOB",?84,"OTHER",!
+32 WRITE ?9,"FAX: ",$GET(PRCPAFAX),?63,"|",?64,"_X__DESTINATION",?80,"____(See Schedule)",!
+33 if $GET(PRCEMAIL)]""
WRITE "E-MAIL: ",PRCEMAIL
WRITE ?63,"|",!
+34 WRITE $EXTRACT(PRCHUNDL,1,63),"|",$EXTRACT(PRCHUNDL,1,34),!
+35 WRITE "8.TO: NAME AND ADDRESS, INCLUDING ZIP CODE",?63,"|9.DESTINATION (Consignee and ad-",!
+36 WRITE ?10,PRCHV(1),?63,"|",?69,"dress, including ZIP code)",!
FOR I=2:1:5
WRITE ?10,PRCHV(I),?63,"| ",PRCHD(I-1),!
+37 WRITE "PHONE: "_$GET(PRCHVPH),?32,"FAX: "_$GET(PRCHVFX),?63,"|",!
+38 if PRCHD(5)'=""
WRITE ?63,"| ",PRCHD(5),!
WRITE $EXTRACT(PRCHUNDL,1,63),"|",$EXTRACT(PRCHUNDL,1,34),!
+39 GOTO EN^PRCHP181
+40 ;
ENDRPT GOTO RDV
+1 ;
EXIT KILL PRCHI,PRCHUNDL,D0,P,PRCHCNT,PRCHFTYP,PRCHIMAS,PRCHIOP,PRCHITEM,PRCHQTY,PRCHUNIT,PRCHX,PRCHD,PRCHD0,PRCHDT,PRCHDT1,PRCHDT2,PRCHPM,PRCHPA,PRCHPAGE
+1 KILL PRCHPAP,PRCHS,PRCHV,PRCHVCNT,PRCHDY,S,I,J,K,X,Y,PRCHFL,PRCHUP,PRCHNSN,PRCHVS,PRCHLI,^TMP($JOB)
+2 QUIT
