- PRCHFPDS ;WISC/RWS-FPDS SCREENS FOR FY89 ;12/20/96 2:02 PM
- V ;;5.1;IFCAP;**16,59,79**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- PROC ;Screen for Proc. Method/Bus. codes
- S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 G PROCQ:Y>120!($P(^(0),U,3)'=PRCHDT)
- ;
- ;if source code=5 Business Type=4 & code index has "E" (Category E4) then gather info on a po.
- I $E(PRCH,1,2)="GS" S Z0=$S("B"[$E(Z1)&(Z1[+PRCHN("MB")):1,1:0) G PROCQ
- ;
- ;PRC*5.1*79 - added 'B,D'
- I $E(PRCH,1,4)="V797" S Z0=$S(Z1[+PRCHN("MB")&("BCD"[$E(Z1)):1,1:0) G PROCQ
- ;PRC*5.1*79 - added 'B'
- I $E(PRCH,1,3)=".OM" S Z0=$S(Z1[+PRCHN("MB")&("ABDE"[$E(Z1)):1,1:0) G PROCQ
- I Z1[+PRCHN("MB") S Z0=1
- PROCQ I Z0
- ;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.
- K Z0,Z1
- Q
- ;
- PREF ;Screen for Pref Prog. Codes
- ;List possible 'PREF. PROGRAM' choices.
- ;
- W !!,"Possible Preference Program Codes: "
- 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
- . S PRCHDISP=$P(^PRCD(420.6,Y,0),U,5)
- . Q
- ;
- ;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
- ;
- S Y="@12"
- W ! K Z,Z1
- Q
- ;
- PREF2 ;Z2=COMPETITIVE STATUS/BUSINESS, Z1=PREFERENCE PROGRAM CODE, PRCHN("MB")=METHOD OF BUSINESS
- S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0
- I $P(^PRCD(420.6,Y,0),U,3)'=PRCHDT G PREFQ
- ;
- ;add new codes for the FPDS report to Austin: #170-#174, PRC*5.1*79.
- I "^151^154^155^169^170^171^172^173^174^"'[Y G PREFQ
- S Z2=$P($G(^PRCD(420.6,+$P(^PRC(442,DA(1),9,DA,0),U,4),0)),U,1)
- ;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.
- I Z2["Y1","X1","K"'[Z1 G PREFQ ;new for PRC*5.1*79
- I Z2["X",Z1="I" G PREFQ
- ;if vendor size=1 show all pref. programs, otherwise show only 'O'
- I +PRCHN("MB")=1 S Z0=1 G PREFQ ;new for PRC*5.1*79
- I "234"[+PRCHN("MB"),"O"[$E(Z1) S Z0=1 G PREFQ
- ;
- PREFQ I Z0
- K Z0,Z1
- Q
- ;
- BREAK ;Setting BREAKOUT CODE (# 442.16)
- ;When Source Code=5, then Breakout/Socio.Gr. must be set to OO (161).
- I PRCHSC=5 D Q
- . S ^PRC(442,PRCHPO,9,DA,1,0)="^442.16PA^161^1"
- . S ^PRC(442,PRCHPO,9,DA,1,161,0)=161
- . S ^PRC(442,PRCHPO,9,DA,1,"B",161,161)=""
- . Q
- 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)=""
- S I=$P(^PRC(442,PRCHPO,9,DA,0),"^",2),PRCHN("TC")=$P($G(^PRCD(420.6,+I,0)),"^",1)
- Q
- ;
- COMP ;template PRCHAMT89 calls COMP
- ;List possible 'COMP. STATUS/BUSINESS' choices.
- ;
- W !!,"Possible Competitive Status/Business codes: "
- 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
- ;
- ;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
- S Y="@11"
- W ! K Z,Z1
- Q
- COMP2 ;
- S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 G COMPQ:$P(^(0),U,3)'=PRCHDT!(Y<121)!(Y>132)
- ;
- ;if source code=5 business type=4 then add $$ amt in code index Z4 category.
- I PRCHN("MB")[$E(Z1,2) S Z0=1
- ;
- COMPQ I Z0
- K Z0,Z1
- Q
- CHK ; CHECK FOR VARIOUS COMBINATIONS OF 'SOCIOECONOMIC GROUP (FY89)' CODES IN VENDOR FILE.
- K PRCHTO
- I $P($G(^PRC(440,DA,1.1,0)),"^",3)="" G ERR ;See NOIS:V13-0802-N1396
- F I=0:0 S I=$O(^PRC(440,DA,1.1,I)) Q:'I S PRCHTO(I)=""
- 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
- 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
- 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
- ;
- EX K PRCHTO,I
- Q
- ;
- ERR K ^PRC(440,DA,1.1) S Y=10
- G EX
- ;
- D1 ; DISPLAY BREAKOUT CODES BROUGHT FROM VENDOR FILE IN ROUTINE PREF (CALLED FROM INPUT TEMPLATE PRCHAMT89)
- 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),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPDS 4569 printed Feb 18, 2025@23:33:58 Page 2
- PRCHFPDS ;WISC/RWS-FPDS SCREENS FOR FY89 ;12/20/96 2:02 PM
- V ;;5.1;IFCAP;**16,59,79**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 QUIT
- +3 ;
- PROC ;Screen for Proc. Method/Bus. codes
- +1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
- SET Z0=0
- if Y>120!($PIECE(^(0),U,3)'=PRCHDT)
- GOTO PROCQ
- +2 ;
- +3 ;if source code=5 Business Type=4 & code index has "E" (Category E4) then gather info on a po.
- +4 IF $EXTRACT(PRCH,1,2)="GS"
- SET Z0=$SELECT("B"[$EXTRACT(Z1)&(Z1[+PRCHN("MB")):1,1:0)
- GOTO PROCQ
- +5 ;
- +6 ;PRC*5.1*79 - added 'B,D'
- +7 IF $EXTRACT(PRCH,1,4)="V797"
- SET Z0=$SELECT(Z1[+PRCHN("MB")&("BCD"[$EXTRACT(Z1)):1,1:0)
- GOTO PROCQ
- +8 ;PRC*5.1*79 - added 'B'
- +9 IF $EXTRACT(PRCH,1,3)=".OM"
- SET Z0=$SELECT(Z1[+PRCHN("MB")&("ABDE"[$EXTRACT(Z1)):1,1:0)
- GOTO PROCQ
- +10 IF Z1[+PRCHN("MB")
- SET Z0=1
- PROCQ IF Z0
- +1 ;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.
- +2 KILL Z0,Z1
- +3 QUIT
- +4 ;
- PREF ;Screen for Pref Prog. Codes
- +1 ;List possible 'PREF. PROGRAM' choices.
- +2 ;
- +3 WRITE !!,"Possible Preference Program Codes: "
- +4 SET I=0
- FOR Y=149:0
- SET Y=$ORDER(^PRCD(420.6,Y))
- if Y="B"
- QUIT
- Begin DoDot:1
- +5 SET PRCHDISP=$PIECE(^PRCD(420.6,Y,0),U,5)
- +6 QUIT
- End DoDot:1
- IF PRCHDISP'="N"
- DO PREF2
- IF $TEST
- if I
- WRITE ","
- WRITE $PIECE(^PRCD(420.6,Y,0),U,1)
- SET I=I+1
- +7 ;
- +8 ;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
- +9 ;
- +10 SET Y="@12"
- +11 WRITE !
- KILL Z,Z1
- +12 QUIT
- +13 ;
- PREF2 ;Z2=COMPETITIVE STATUS/BUSINESS, Z1=PREFERENCE PROGRAM CODE, PRCHN("MB")=METHOD OF BUSINESS
- +1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
- SET Z0=0
- +2 IF $PIECE(^PRCD(420.6,Y,0),U,3)'=PRCHDT
- GOTO PREFQ
- +3 ;
- +4 ;add new codes for the FPDS report to Austin: #170-#174, PRC*5.1*79.
- +5 IF "^151^154^155^169^170^171^172^173^174^"'[Y
- GOTO PREFQ
- +6 SET Z2=$PIECE($GET(^PRCD(420.6,+$PIECE(^PRC(442,DA(1),9,DA,0),U,4),0)),U,1)
- +7 ;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.
- +8 ;new for PRC*5.1*79
- IF Z2["Y1"
- IF "X1"
- IF "K"'[Z1
- GOTO PREFQ
- +9 IF Z2["X"
- IF Z1="I"
- GOTO PREFQ
- +10 ;if vendor size=1 show all pref. programs, otherwise show only 'O'
- +11 ;new for PRC*5.1*79
- IF +PRCHN("MB")=1
- SET Z0=1
- GOTO PREFQ
- +12 IF "234"[+PRCHN("MB")
- IF "O"[$EXTRACT(Z1)
- SET Z0=1
- GOTO PREFQ
- +13 ;
- PREFQ IF Z0
- +1 KILL Z0,Z1
- +2 QUIT
- +3 ;
- BREAK ;Setting BREAKOUT CODE (# 442.16)
- +1 ;When Source Code=5, then Breakout/Socio.Gr. must be set to OO (161).
- +2 IF PRCHSC=5
- Begin DoDot:1
- +3 SET ^PRC(442,PRCHPO,9,DA,1,0)="^442.16PA^161^1"
- +4 SET ^PRC(442,PRCHPO,9,DA,1,161,0)=161
- +5 SET ^PRC(442,PRCHPO,9,DA,1,"B",161,161)=""
- +6 QUIT
- End DoDot:1
- QUIT
- +7 IF $ORDER(PRCHB(0))
- SET ^PRC(442,PRCHPO,9,DA,1,0)=PRCHB(0)
- FOR I=0:0
- SET I=$ORDER(PRCHB(I))
- if 'I
- QUIT
- SET ^PRC(442,PRCHPO,9,DA,1,I,0)=I
- SET ^PRC(442,PRCHPO,9,DA,1,"B",I,I)=""
- +8 SET I=$PIECE(^PRC(442,PRCHPO,9,DA,0),"^",2)
- SET PRCHN("TC")=$PIECE($GET(^PRCD(420.6,+I,0)),"^",1)
- +9 QUIT
- +10 ;
- COMP ;template PRCHAMT89 calls COMP
- +1 ;List possible 'COMP. STATUS/BUSINESS' choices.
- +2 ;
- +3 WRITE !!,"Possible Competitive Status/Business codes: "
- +4 SET I=0
- FOR Y=120:0
- SET Y=$ORDER(^PRCD(420.6,Y))
- if Y>132
- QUIT
- DO COMP2
- IF $TEST
- if I
- WRITE ","
- WRITE $PIECE(^PRCD(420.6,Y,0),U,1)
- SET I=I+1
- +5 ;
- +6 ;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
- +7 SET Y="@11"
- +8 WRITE !
- KILL Z,Z1
- +9 QUIT
- COMP2 ;
- +1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
- SET Z0=0
- if $PIECE(^(0),U,3)'=PRCHDT!(Y<121)!(Y>132)
- GOTO COMPQ
- +2 ;
- +3 ;if source code=5 business type=4 then add $$ amt in code index Z4 category.
- +4 IF PRCHN("MB")[$EXTRACT(Z1,2)
- SET Z0=1
- +5 ;
- COMPQ IF Z0
- +1 KILL Z0,Z1
- +2 QUIT
- CHK ; CHECK FOR VARIOUS COMBINATIONS OF 'SOCIOECONOMIC GROUP (FY89)' CODES IN VENDOR FILE.
- +1 KILL PRCHTO
- +2 ;See NOIS:V13-0802-N1396
- IF $PIECE($GET(^PRC(440,DA,1.1,0)),"^",3)=""
- GOTO ERR
- +3 FOR I=0:0
- SET I=$ORDER(^PRC(440,DA,1.1,I))
- if 'I
- QUIT
- SET PRCHTO(I)=""
- +4 IF $DATA(PRCHTO(161))
- KILL PRCHTO(161)
- IF $ORDER(PRCHTO(0))
- WRITE $CHAR(7),!!,"You CANNOT have a Socioeconomic Group of OO--NONE OF THE OTHER CATEGORIES",!,"in combination with any other Socioeconomic Group",!,"RE-ENTER ALL!!!",!
- GOTO ERR
- +5 IF $DATA(PRCHTO(157))
- IF $DATA(PRCHTO(153))!$DATA(PRCHTO(163))!$DATA(PRCHTO(164))
- WRITE $CHAR(7),!!,"You CANNOT have the Socioeconomic Group of P--JAVITS-WAGNER-O'DAY",!,"in combination with any LARGE group",!,"RE-ENTER ALL!!!",!
- GOTO ERR
- +6 IF '$DATA(PRCHTO(162))
- IF $DATA(PRCHTO(167))
- WRITE $CHAR(7),!!,"Category RV--SERVICE-DISABLED VETERAN must also include S--VETERAN-OWNED SM BUSINESS",!,"RE-ENTER ALL!!!"
- GOTO ERR
- +7 ;
- EX KILL PRCHTO,I
- +1 QUIT
- +2 ;
- ERR KILL ^PRC(440,DA,1.1)
- SET Y=10
- +1 GOTO EX
- +2 ;
- D1 ; DISPLAY BREAKOUT CODES BROUGHT FROM VENDOR FILE IN ROUTINE PREF (CALLED FROM INPUT TEMPLATE PRCHAMT89)
- +1 SET I=0
- FOR J=1:1
- SET I=$ORDER(^PRC(442,PRCHPO,9,DA,1,I))
- if 'I
- QUIT
- SET X=$GET(^PRCD(420.6,+I,0))
- if J=1
- WRITE !!,"Following Socioeconomic Group Codes brought over from Vendor File:",!
- WRITE ?5,$PIECE(X,"^",1)_" "_$PIECE(X,"^",2),!
- +2 QUIT