| 1 | PRCHFPDS ;WISC/RWS-FPDS SCREENS FOR FY89 ;12/20/96 2:02 PM
|
|---|
| 2 | V ;;5.1;IFCAP;**16,59,79**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | PROC ;Screen for Proc. Method/Bus. codes
|
|---|
| 7 | S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 G PROCQ:Y>120!($P(^(0),U,3)'=PRCHDT)
|
|---|
| 8 | ;
|
|---|
| 9 | ;if source code=5 Business Type=4 & code index has "E" (Category E4) then gather info on a po.
|
|---|
| 10 | I $E(PRCH,1,2)="GS" S Z0=$S("B"[$E(Z1)&(Z1[+PRCHN("MB")):1,1:0) G PROCQ
|
|---|
| 11 | ;
|
|---|
| 12 | ;PRC*5.1*79 - added 'B,D'
|
|---|
| 13 | I $E(PRCH,1,4)="V797" S Z0=$S(Z1[+PRCHN("MB")&("BCD"[$E(Z1)):1,1:0) G PROCQ
|
|---|
| 14 | ;PRC*5.1*79 - added 'B'
|
|---|
| 15 | I $E(PRCH,1,3)=".OM" S Z0=$S(Z1[+PRCHN("MB")&("ABDE"[$E(Z1)):1,1:0) G PROCQ
|
|---|
| 16 | I Z1[+PRCHN("MB") S Z0=1
|
|---|
| 17 | PROCQ I Z0
|
|---|
| 18 | ;I Z0 sets the truth value. If Z0=1 is set, and based on truth value the entries are displayed from a specified range by Y value from file 420.6.
|
|---|
| 19 | K Z0,Z1
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | PREF ;Screen for Pref Prog. Codes
|
|---|
| 23 | ;List possible 'PREF. PROGRAM' choices.
|
|---|
| 24 | ;
|
|---|
| 25 | W !!,"Possible Preference Program Codes: "
|
|---|
| 26 | S I=0 F Y=149:0 S Y=$O(^PRCD(420.6,Y)) Q:Y="B" D I PRCHDISP'="N" D PREF2 I $T W:I "," W $P(^PRCD(420.6,Y,0),U,1) S I=I+1
|
|---|
| 27 | . S PRCHDISP=$P(^PRCD(420.6,Y,0),U,5)
|
|---|
| 28 | . Q
|
|---|
| 29 | ;
|
|---|
| 30 | ;Y = field # 1.2 'PREF. PROGRAM' -- the Y is set to jump back to template PRCHAMT89 to proper field 1.2 rather than first field #1.2
|
|---|
| 31 | ;
|
|---|
| 32 | S Y="@12"
|
|---|
| 33 | W ! K Z,Z1
|
|---|
| 34 | Q
|
|---|
| 35 | ;
|
|---|
| 36 | PREF2 ;Z2=COMPETITIVE STATUS/BUSINESS, Z1=PREFERENCE PROGRAM CODE, PRCHN("MB")=METHOD OF BUSINESS
|
|---|
| 37 | S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0
|
|---|
| 38 | I $P(^PRCD(420.6,Y,0),U,3)'=PRCHDT G PREFQ
|
|---|
| 39 | ;
|
|---|
| 40 | ;add new codes for the FPDS report to Austin: #170-#174, PRC*5.1*79.
|
|---|
| 41 | I "^151^154^155^169^170^171^172^173^174^"'[Y G PREFQ
|
|---|
| 42 | S Z2=$P($G(^PRCD(420.6,+$P(^PRC(442,DA(1),9,DA,0),U,4),0)),U,1)
|
|---|
| 43 | ;if source code=5 & method of business=4 & comp stat/bus=Z4 then pref program code must be set to O i.e. none of the above.
|
|---|
| 44 | I Z2["Y1","X1","K"'[Z1 G PREFQ ;new for PRC*5.1*79
|
|---|
| 45 | I Z2["X",Z1="I" G PREFQ
|
|---|
| 46 | ;if vendor size=1 show all pref. programs, otherwise show only 'O'
|
|---|
| 47 | I +PRCHN("MB")=1 S Z0=1 G PREFQ ;new for PRC*5.1*79
|
|---|
| 48 | I "234"[+PRCHN("MB"),"O"[$E(Z1) S Z0=1 G PREFQ
|
|---|
| 49 | ;
|
|---|
| 50 | PREFQ I Z0
|
|---|
| 51 | K Z0,Z1
|
|---|
| 52 | Q
|
|---|
| 53 | ;
|
|---|
| 54 | BREAK ;Setting BREAKOUT CODE (# 442.16)
|
|---|
| 55 | ;When Source Code=5, then Breakout/Socio.Gr. must be set to OO (161).
|
|---|
| 56 | I PRCHSC=5 D Q
|
|---|
| 57 | . S ^PRC(442,PRCHPO,9,DA,1,0)="^442.16PA^161^1"
|
|---|
| 58 | . S ^PRC(442,PRCHPO,9,DA,1,161,0)=161
|
|---|
| 59 | . S ^PRC(442,PRCHPO,9,DA,1,"B",161,161)=""
|
|---|
| 60 | . Q
|
|---|
| 61 | I $O(PRCHB(0)) S ^PRC(442,PRCHPO,9,DA,1,0)=PRCHB(0) F I=0:0 S I=$O(PRCHB(I)) Q:'I S ^PRC(442,PRCHPO,9,DA,1,I,0)=I,^PRC(442,PRCHPO,9,DA,1,"B",I,I)=""
|
|---|
| 62 | S I=$P(^PRC(442,PRCHPO,9,DA,0),"^",2),PRCHN("TC")=$P($G(^PRCD(420.6,+I,0)),"^",1)
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | COMP ;template PRCHAMT89 calls COMP
|
|---|
| 66 | ;List possible 'COMP. STATUS/BUSINESS' choices.
|
|---|
| 67 | ;
|
|---|
| 68 | W !!,"Possible Competitive Status/Business codes: "
|
|---|
| 69 | S I=0 F Y=120:0 S Y=$O(^PRCD(420.6,Y)) Q:Y>132 D COMP2 I $T W:I "," W $P(^PRCD(420.6,Y,0),U,1) S I=I+1
|
|---|
| 70 | ;
|
|---|
| 71 | ;Y = field # 1.1 'COMP. STATUS/BUSINESS' --the Y is set to jump back to template PRCHAMT89 to proper field 1.1 rather than the first field #1.1
|
|---|
| 72 | S Y="@11"
|
|---|
| 73 | W ! K Z,Z1
|
|---|
| 74 | Q
|
|---|
| 75 | COMP2 ;
|
|---|
| 76 | S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 G COMPQ:$P(^(0),U,3)'=PRCHDT!(Y<121)!(Y>132)
|
|---|
| 77 | ;
|
|---|
| 78 | ;if source code=5 business type=4 then add $$ amt in code index Z4 category.
|
|---|
| 79 | I PRCHN("MB")[$E(Z1,2) S Z0=1
|
|---|
| 80 | ;
|
|---|
| 81 | COMPQ I Z0
|
|---|
| 82 | K Z0,Z1
|
|---|
| 83 | Q
|
|---|
| 84 | CHK ; CHECK FOR VARIOUS COMBINATIONS OF 'SOCIOECONOMIC GROUP (FY89)' CODES IN VENDOR FILE.
|
|---|
| 85 | K PRCHTO
|
|---|
| 86 | I $P($G(^PRC(440,DA,1.1,0)),"^",3)="" G ERR ;See NOIS:V13-0802-N1396
|
|---|
| 87 | F I=0:0 S I=$O(^PRC(440,DA,1.1,I)) Q:'I S PRCHTO(I)=""
|
|---|
| 88 | I $D(PRCHTO(161)) K PRCHTO(161) I $O(PRCHTO(0)) W $C(7),!!,"You CANNOT have a Socioeconomic Group of OO--NONE OF THE OTHER CATEGORIES",!,"in combination with any other Socioeconomic Group",!,"RE-ENTER ALL!!!",! G ERR
|
|---|
| 89 | I $D(PRCHTO(157)),$D(PRCHTO(153))!$D(PRCHTO(163))!$D(PRCHTO(164)) W $C(7),!!,"You CANNOT have the Socioeconomic Group of P--JAVITS-WAGNER-O'DAY",!,"in combination with any LARGE group",!,"RE-ENTER ALL!!!",! G ERR
|
|---|
| 90 | I '$D(PRCHTO(162)),$D(PRCHTO(167)) W $C(7),!!,"Category RV--SERVICE-DISABLED VETERAN must also include S--VETERAN-OWNED SM BUSINESS",!,"RE-ENTER ALL!!!" G ERR
|
|---|
| 91 | ;
|
|---|
| 92 | EX K PRCHTO,I
|
|---|
| 93 | Q
|
|---|
| 94 | ;
|
|---|
| 95 | ERR K ^PRC(440,DA,1.1) S Y=10
|
|---|
| 96 | G EX
|
|---|
| 97 | ;
|
|---|
| 98 | D1 ; DISPLAY BREAKOUT CODES BROUGHT FROM VENDOR FILE IN ROUTINE PREF (CALLED FROM INPUT TEMPLATE PRCHAMT89)
|
|---|
| 99 | S I=0 F J=1:1 S I=$O(^PRC(442,PRCHPO,9,DA,1,I)) Q:'I S X=$G(^PRCD(420.6,+I,0)) W:J=1 !!,"Following Socioeconomic Group Codes brought over from Vendor File:",! W ?5,$P(X,"^",1)_" "_$P(X,"^",2),!
|
|---|
| 100 | Q
|
|---|
