- ACGSSPR ;IHS/OIRM/DSD/THL,AEF - SOCIOECONOMIC PROCUREMENT REPORT; [ 03/27/2000 2:22 PM ]
- ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
- ;;PRINT SOCIOECONOMIC PROCUREMENT REPORT
- EN D EN1
- EXIT K ACGQUIT,ACG,ACG13,ACG26,ACGBEGIN,ACGEND,ACG1,ACG2,ACG3,ACG5,ACGI,ACGJ,ACGION,ACG19,ACG27,ACG30,ACGBEG,ACGFY,ACGQT,ACGX
- Q
- EN1 K ACGQUIT
- S:'$D(ACGPARA) ACGPARA=^ACGPARA(ACGPODA,0),ACG4=$P(ACGPARA,U,3)
- D QT^ACGSCPAR
- I $D(ACGQUIT) K ACGQUIT Q
- S:'$D(ACG4) ACG4=$P(ACGPARA,U,3)
- I ACG4=236 D CO^ACGSCPAR Q:$D(ACGQUIT) I 1
- E S (ACG4,ACG4X)=ACG4
- ZIS S ZTRTN="EN2^ACGSSPR",ZTDESC="CIS QT SOCIOECONOMIC PROCUREMENT REPORT",ZTSAVE("ACG*")=""
- D ^ACGSZIS
- Q:$D(ACGQUIT)
- EN2 I '$D(ZTQUEUED) S (ACGIOP,IOP)=ION D ^%ZIS I POP S ACGQUIT="" Q
- U IO
- I ACG4X=88 F ACG4=102,121,161,235,239,241:1:249,284,285 K ACGQUIT D R1
- G:ACG4X=88 DONE
- R1 G:$D(ACGQUIT) DONE
- D ENX
- W:$D(IOF) @IOF
- D:ACG4X'=88 DONE
- Q
- DONE D DONE^ACGSZIS
- Q
- ENX U IO
- S ACGBEG=ACGBEGIN,ACG(1)="0^0^TOTAL PROCUREMENTS (EXCLUDING 8(A))",ACG(2)="0^0^SMALL BUSINESS DIRECT AWARDS OTHER THAN DISADV (ITEM 13 = A2 OR A3)",ACG(3)="0^0^DISADVANTAGED SMALL BUSINESS DIRECT AWARDS (ITEM 13 = A1)"
- S ACG(4)="0^0^LARGE MINORITY BUSINESS DIRECT AWARDS (ITEM 13 = B1)",ACG(5)="0^0^WOMEN OWNED (ITEM 30 = YES)",ACG(6)="0^0^LABOR SURPLUS AREA SET ASIDES (ITEM 19 = 51 OR 54)",ACG(7)="0^0^8(A) AWARDS (ITEM 19 = 59 OR 60)"
- S ACG(8)="0^0^MINORITY NON-PROFIT",ACGXREF="T"
- F ACGI=1:1:8 F ACGJ=1:1:4 S ACG(ACGI,ACGJ)="0^0^"
- F S ACGBEG=$O(^ACGS(ACGXREF,ACGBEG)) Q:'ACGBEG!(ACGBEG>ACGEND) S ACG=0 F S ACG=$O(^ACGS(ACGXREF,ACGBEG,ACG)) Q:'ACG D
- .F X="DT","DT1","IHS" I '$D(^ACGS(ACG,X)) S ACGQUIT="" Q
- .I $D(ACGQUIT) K ACGQUIT Q
- .S ACGVDA=+^ACGS(ACG,10),ACGDT=^("DT"),ACGDT1=^("DT1"),ACGIHS=^("IHS")
- .S ACG13=$P(ACGDT,U,13),ACG1=+ACGDT,ACG2=$P(ACGDT,U,2),ACG19=$P(ACGDT,U,19),ACG23=$P(ACGDT1,U,2),ACG26=$P(ACGDT1,U,5),ACG27=$P(ACGDT1,U,6),ACG30=$P(ACGDT1,U,9),ACG111=$S('ACGVDA:"",$D(^AUTTVNDR(ACGVDA,11)):$P(^(11),U,21),1:"")
- .Q:"^15^17^"[(U_ACG1_U)
- .I ACG4X=88,ACG4'=$E(ACG2,1,3) Q
- .I ACG4'=99,ACG4'=236,ACG4'=$E(ACG2,1,3) Q
- .Q:'ACG13!'ACG19!'ACG27
- .Q:'$D(^AUTTTOB(ACG13,0))
- .Q:'$D(^ACGEOC(ACG19,0))
- .Q:'$D(^ACGPPC(ACG27,0)) S ACG27=^(0)
- .I $P(ACG27,U,4)="I" S ACG27=1
- .E S ACG27=$E(ACG27)
- .I ACG27'=1 S ACG27=$S(ACG27="A":3,ACG27="Y":2,1:4)
- .S ACG13=$P(^AUTTTOB(ACG13,0),U)
- .S $P(ACG(1),U)=$P(ACG(1),U)+1,$P(ACG(1),U,2)=$P(ACG(1),U,2)+ACG26,$P(ACG(1,ACG27),U)=$P(ACG(1,ACG27),U)+1,$P(ACG(1,ACG27),U,2)=$P(ACG(1,ACG27),U,2)+ACG26
- .I ACG111=1 S $P(ACG(8),U)=$P(ACG(8),U)+1,$P(ACG(8),U,2)=$P(ACG(8),U,2)+ACG26,$P(ACG(8,ACG27),U)=$P(ACG(8,ACG27),U)+1,$P(ACG(8,ACG27),U,2)=$P(ACG(8,ACG27),U,2)+ACG26 S ^TMP("ACG",$J,ACG)=ACG(8) Q
- .I $E(ACG30)="Y" S $P(ACG(5),U)=$P(ACG(5),U)+1,$P(ACG(5),U,2)=$P(ACG(5),U,2)+ACG26,$P(ACG(5,ACG27),U)=$P(ACG(5,ACG27),U)+1,$P(ACG(5,ACG27),U,2)=$P(ACG(5,ACG27),U,2)+ACG26 Q
- .I ACG19=51 S $P(ACG(6),U)=$P(ACG(6),U)+1,$P(ACG(6),U,2)=$P(ACG(6),U,2)+ACG26,$P(ACG(6,ACG27),U)=$P(ACG(6,ACG27),U)+1,$P(ACG(6,ACG27),U,2)=$P(ACG(6,ACG27),U,2)+ACG26 Q
- .I "5960"[ACG19 S $P(ACG(7),U)=$P(ACG(7),U)+1,$P(ACG(7),U,2)=$P(ACG(7),U,2)+ACG26,$P(ACG(7,ACG27),U)=$P(ACG(7,ACG27),U)+1,$P(ACG(7,ACG27),U,2)=$P(ACG(7,ACG27),U,2)+ACG26 Q
- .I "A2A3"[ACG13 S $P(ACG(2),U)=$P(ACG(2),U)+1,$P(ACG(2),U,2)=$P(ACG(2),U,2)+ACG26,$P(ACG(2,ACG27),U)=$P(ACG(2,ACG27),U)+1,$P(ACG(2,ACG27),U,2)=$P(ACG(2,ACG27),U,2)+ACG26 Q
- .I "A1"[ACG13 S $P(ACG(3),U)=$P(ACG(3),U)+1,$P(ACG(3),U,2)=$P(ACG(3),U,2)+ACG26,$P(ACG(3,ACG27),U)=$P(ACG(3,ACG27),U)+1,$P(ACG(3,ACG27),U,2)=$P(ACG(3,ACG27),U,2)+ACG26 Q
- .I "B1B2"[ACG13 S $P(ACG(4),U)=$P(ACG(4),U)+1,$P(ACG(4),U,2)=$P(ACG(4),U,2)+ACG26,$P(ACG(4,ACG27),U)=$P(ACG(4,ACG27),U)+1,$P(ACG(4,ACG27),U,2)=$P(ACG(4,ACG27),U,2)+ACG26 Q
- .S ACG(8,ACG13)=""
- D EN3
- I $D(IOST),$E(IOST,1,2)="C-" D HOLD^ACGSMENU
- Q
- EN3 S ACGX="QUARTERLY SOCIOECONOMIC PROCUREMENT REPORT"
- D RDATE^ACGSICR
- W !!,"TOTAL CONTRACTS ADVIS SERVICES CONSTRUCTION RES AND DEV OTHER",!,"------------------ -------------- ------------- ------------- --------------"
- F ACGI=1:1:8 D
- .W !?10,$P(ACG(ACGI),U,3),!,$J($P(ACG(ACGI),U),4)
- .F ACGJ=1:1:4 S ACGX=$S(ACGJ=1:20,ACGJ=2:35,ACGJ=3:50,1:65) W ?ACGX,"|",$J($P(ACG(ACGI,ACGJ),U),5)
- .W !,$J($FN($P(ACG(ACGI),U,2),"P,",0),16)
- .F ACGJ=1:1:4 S ACGX=$S(ACGJ=1:20,ACGJ=2:35,ACGJ=3:50,1:65) W ?ACGX,"|",$J($FN($P(ACG(ACGI,ACGJ),U,2),"P,",0),14)
- .W !,"--------------------------------------------------------------------------------",!
- .I $D(IOST),$E(IOST,1,2)="C-" D HOLD^ACGSMENU
- Q
- ACGSSPR ;IHS/OIRM/DSD/THL,AEF - SOCIOECONOMIC PROCUREMENT REPORT; [ 03/27/2000 2:22 PM ]
- +1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
- +2 ;;PRINT SOCIOECONOMIC PROCUREMENT REPORT
- EN DO EN1
- EXIT KILL ACGQUIT,ACG,ACG13,ACG26,ACGBEGIN,ACGEND,ACG1,ACG2,ACG3,ACG5,ACGI,ACGJ,ACGION,ACG19,ACG27,ACG30,ACGBEG,ACGFY,ACGQT,ACGX
- +1 QUIT
- EN1 KILL ACGQUIT
- +1 IF '$DATA(ACGPARA)
- SET ACGPARA=^ACGPARA(ACGPODA,0)
- SET ACG4=$PIECE(ACGPARA,U,3)
- +2 DO QT^ACGSCPAR
- +3 IF $DATA(ACGQUIT)
- KILL ACGQUIT
- QUIT
- +4 IF '$DATA(ACG4)
- SET ACG4=$PIECE(ACGPARA,U,3)
- +5 IF ACG4=236
- DO CO^ACGSCPAR
- IF $DATA(ACGQUIT)
- QUIT
- IF 1
- +6 IF '$TEST
- SET (ACG4,ACG4X)=ACG4
- ZIS SET ZTRTN="EN2^ACGSSPR"
- SET ZTDESC="CIS QT SOCIOECONOMIC PROCUREMENT REPORT"
- SET ZTSAVE("ACG*")=""
- +1 DO ^ACGSZIS
- +2 IF $DATA(ACGQUIT)
- QUIT
- EN2 IF '$DATA(ZTQUEUED)
- SET (ACGIOP,IOP)=ION
- DO ^%ZIS
- IF POP
- SET ACGQUIT=""
- QUIT
- +1 USE IO
- +2 IF ACG4X=88
- FOR ACG4=102,121,161,235,239,241:1:249,284,285
- KILL ACGQUIT
- DO R1
- +3 IF ACG4X=88
- GOTO DONE
- R1 IF $DATA(ACGQUIT)
- GOTO DONE
- +1 DO ENX
- +2 IF $DATA(IOF)
- WRITE @IOF
- +3 IF ACG4X'=88
- DO DONE
- +4 QUIT
- DONE DO DONE^ACGSZIS
- +1 QUIT
- ENX USE IO
- +1 SET ACGBEG=ACGBEGIN
- SET ACG(1)="0^0^TOTAL PROCUREMENTS (EXCLUDING 8(A))"
- SET ACG(2)="0^0^SMALL BUSINESS DIRECT AWARDS OTHER THAN DISADV (ITEM 13 = A2 OR A3)"
- SET ACG(3)="0^0^DISADVANTAGED SMALL BUSINESS DIRECT AWARDS (ITEM 13 = A1)"
- +2 SET ACG(4)="0^0^LARGE MINORITY BUSINESS DIRECT AWARDS (ITEM 13 = B1)"
- SET ACG(5)="0^0^WOMEN OWNED (ITEM 30 = YES)"
- SET ACG(6)="0^0^LABOR SURPLUS AREA SET ASIDES (ITEM 19 = 51 OR 54)"
- SET ACG(7)="0^0^8(A) AWARDS (ITEM 19 = 59 OR 60)"
- +3 SET ACG(8)="0^0^MINORITY NON-PROFIT"
- SET ACGXREF="T"
- +4 FOR ACGI=1:1:8
- FOR ACGJ=1:1:4
- SET ACG(ACGI,ACGJ)="0^0^"
- +5 FOR
- SET ACGBEG=$ORDER(^ACGS(ACGXREF,ACGBEG))
- IF 'ACGBEG!(ACGBEG>ACGEND)
- QUIT
- SET ACG=0
- FOR
- SET ACG=$ORDER(^ACGS(ACGXREF,ACGBEG,ACG))
- IF 'ACG
- QUIT
- Begin DoDot:1
- +6 FOR X="DT","DT1","IHS"
- IF '$DATA(^ACGS(ACG,X))
- SET ACGQUIT=""
- QUIT
- +7 IF $DATA(ACGQUIT)
- KILL ACGQUIT
- QUIT
- +8 SET ACGVDA=+^ACGS(ACG,10)
- SET ACGDT=^("DT")
- SET ACGDT1=^("DT1")
- SET ACGIHS=^("IHS")
- +9 SET ACG13=$PIECE(ACGDT,U,13)
- SET ACG1=+ACGDT
- SET ACG2=$PIECE(ACGDT,U,2)
- SET ACG19=$PIECE(ACGDT,U,19)
- SET ACG23=$PIECE(ACGDT1,U,2)
- SET ACG26=$PIECE(ACGDT1,U,5)
- SET ACG27=$PIECE(ACGDT1,U,6)
- SET ACG30=$PIECE(ACGDT1,U,9)
- SET ACG111=$SELECT('ACGVDA:"",$DATA(^AUTTVNDR(ACGVDA,11)):$PIECE(^(11),U,21),1:"")
- +10 IF "^15^17^"[(U_ACG1_U)
- QUIT
- +11 IF ACG4X=88
- IF ACG4'=$EXTRACT(ACG2,1,3)
- QUIT
- +12 IF ACG4'=99
- IF ACG4'=236
- IF ACG4'=$EXTRACT(ACG2,1,3)
- QUIT
- +13 IF 'ACG13!'ACG19!'ACG27
- QUIT
- +14 IF '$DATA(^AUTTTOB(ACG13,0))
- QUIT
- +15 IF '$DATA(^ACGEOC(ACG19,0))
- QUIT
- +16 IF '$DATA(^ACGPPC(ACG27,0))
- QUIT
- SET ACG27=^(0)
- +17 IF $PIECE(ACG27,U,4)="I"
- SET ACG27=1
- +18 IF '$TEST
- SET ACG27=$EXTRACT(ACG27)
- +19 IF ACG27'=1
- SET ACG27=$SELECT(ACG27="A":3,ACG27="Y":2,1:4)
- +20 SET ACG13=$PIECE(^AUTTTOB(ACG13,0),U)
- +21 SET $PIECE(ACG(1),U)=$PIECE(ACG(1),U)+1
- SET $PIECE(ACG(1),U,2)=$PIECE(ACG(1),U,2)+ACG26
- SET $PIECE(ACG(1,ACG27),U)=$PIECE(ACG(1,ACG27),U)+1
- SET $PIECE(ACG(1,ACG27),U,2)=$PIECE(ACG(1,ACG27),U,2)+ACG26
- +22 IF ACG111=1
- SET $PIECE(ACG(8),U)=$PIECE(ACG(8),U)+1
- SET $PIECE(ACG(8),U,2)=$PIECE(ACG(8),U,2)+ACG26
- SET $PIECE(ACG(8,ACG27),U)=$PIECE(ACG(8,ACG27),U)+1
- SET $PIECE(ACG(8,ACG27),U,2)=$PIECE(ACG(8,ACG27),U,2)+ACG26
- SET ^TMP("ACG",$JOB,ACG)=ACG(8)
- QUIT
- +23 IF $EXTRACT(ACG30)="Y"
- SET $PIECE(ACG(5),U)=$PIECE(ACG(5),U)+1
- SET $PIECE(ACG(5),U,2)=$PIECE(ACG(5),U,2)+ACG26
- SET $PIECE(ACG(5,ACG27),U)=$PIECE(ACG(5,ACG27),U)+1
- SET $PIECE(ACG(5,ACG27),U,2)=$PIECE(ACG(5,ACG27),U,2)+ACG26
- QUIT
- +24 IF ACG19=51
- SET $PIECE(ACG(6),U)=$PIECE(ACG(6),U)+1
- SET $PIECE(ACG(6),U,2)=$PIECE(ACG(6),U,2)+ACG26
- SET $PIECE(ACG(6,ACG27),U)=$PIECE(ACG(6,ACG27),U)+1
- SET $PIECE(ACG(6,ACG27),U,2)=$PIECE(ACG(6,ACG27),U,2)+ACG26
- QUIT
- +25 IF "5960"[ACG19
- SET $PIECE(ACG(7),U)=$PIECE(ACG(7),U)+1
- SET $PIECE(ACG(7),U,2)=$PIECE(ACG(7),U,2)+ACG26
- SET $PIECE(ACG(7,ACG27),U)=$PIECE(ACG(7,ACG27),U)+1
- SET $PIECE(ACG(7,ACG27),U,2)=$PIECE(ACG(7,ACG27),U,2)+ACG26
- QUIT
- +26 IF "A2A3"[ACG13
- SET $PIECE(ACG(2),U)=$PIECE(ACG(2),U)+1
- SET $PIECE(ACG(2),U,2)=$PIECE(ACG(2),U,2)+ACG26
- SET $PIECE(ACG(2,ACG27),U)=$PIECE(ACG(2,ACG27),U)+1
- SET $PIECE(ACG(2,ACG27),U,2)=$PIECE(ACG(2,ACG27),U,2)+ACG26
- QUIT
- +27 IF "A1"[ACG13
- SET $PIECE(ACG(3),U)=$PIECE(ACG(3),U)+1
- SET $PIECE(ACG(3),U,2)=$PIECE(ACG(3),U,2)+ACG26
- SET $PIECE(ACG(3,ACG27),U)=$PIECE(ACG(3,ACG27),U)+1
- SET $PIECE(ACG(3,ACG27),U,2)=$PIECE(ACG(3,ACG27),U,2)+ACG26
- QUIT
- +28 IF "B1B2"[ACG13
- SET $PIECE(ACG(4),U)=$PIECE(ACG(4),U)+1
- SET $PIECE(ACG(4),U,2)=$PIECE(ACG(4),U,2)+ACG26
- SET $PIECE(ACG(4,ACG27),U)=$PIECE(ACG(4,ACG27),U)+1
- SET $PIECE(ACG(4,ACG27),U,2)=$PIECE(ACG(4,ACG27),U,2)+ACG26
- QUIT
- +29 SET ACG(8,ACG13)=""
- End DoDot:1
- +30 DO EN3
- +31 IF $DATA(IOST)
- IF $EXTRACT(IOST,1,2)="C-"
- DO HOLD^ACGSMENU
- +32 QUIT
- EN3 SET ACGX="QUARTERLY SOCIOECONOMIC PROCUREMENT REPORT"
- +1 DO RDATE^ACGSICR
- +2 WRITE !!,"TOTAL CONTRACTS ADVIS SERVICES CONSTRUCTION RES AND DEV OTHER",!,"------------------ -------------- ------------- ------------- --------------"
- +3 FOR ACGI=1:1:8
- Begin DoDot:1
- +4 WRITE !?10,$PIECE(ACG(ACGI),U,3),!,$JUSTIFY($PIECE(ACG(ACGI),U),4)
- +5 FOR ACGJ=1:1:4
- SET ACGX=$SELECT(ACGJ=1:20,ACGJ=2:35,ACGJ=3:50,1:65)
- WRITE ?ACGX,"|",$JUSTIFY($PIECE(ACG(ACGI,ACGJ),U),5)
- +6 WRITE !,$JUSTIFY($FNUMBER($PIECE(ACG(ACGI),U,2),"P,",0),16)
- +7 FOR ACGJ=1:1:4
- SET ACGX=$SELECT(ACGJ=1:20,ACGJ=2:35,ACGJ=3:50,1:65)
- WRITE ?ACGX,"|",$JUSTIFY($FNUMBER($PIECE(ACG(ACGI,ACGJ),U,2),"P,",0),14)
- +8 WRITE !,"--------------------------------------------------------------------------------",!
- +9 IF $DATA(IOST)
- IF $EXTRACT(IOST,1,2)="C-"
- DO HOLD^ACGSMENU
- End DoDot:1
- +10 QUIT
