ACGS282 ;IHS/OIRM/DSD/THL,AEF - UTILITY TO PRINT THE SMALL PURCHASE 281 REPORT - CONT; [ 03/27/2000 2:22 PM ]
;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
;;UTILITY TO PRINT THE SMALL PURCHASE 281 REPORT
;;modified for y2k;mlp;01/31/2000
B1 ;EP
S ACGRDA=0
F S ACGRDA=$O(^ACGS("R",ACGBEG,ACGRDA)) Q:'ACGRDA I "^15^17^"[(U_+^ACGS(ACGRDA,"DT")_U),$D(^("SP")) S ACGDT=^("DT"),ACG26=$P($P(^("DT1"),U,5),"."),ACGSP=^("SP") D
.Q:$P(ACGDT,U,2)["PENDING"
.I ACG4X'=99 Q:$P(ACGDT,U,4)'=ACG4X
.I $P(ACGSP,U,7)="" S ACG12=$P(ACGDT,U,12) I ACG12]"" S:ACG12="D" ACG12="C" S DA=ACGRDA,DIE="^ACGS(",DR="307////"_ACG12 D DIE^ACGSDIC W "."
.F ACG=3:1:7 S @("ACG30"_ACG)=$P(ACGSP,U,ACG)
.F ACG=3:1:7 I @("ACG30"_ACG)="" S ACGQUIT="" Q
.I $D(ACGQUIT) K ACGQUIT Q
.;SET PROCUREMENT METHOD/TYPE OF BUSINESS BUCKETS
.S $P(ACGPM(ACG4XX,ACG306,ACG304),U)=$P(ACGPM(ACG4XX,ACG306,ACG304),U)+ACG26,$P(ACGPM(ACG4XX,ACG306),U)=$P(ACGPM(ACG4XX,ACG306),U)+ACG26,$P(ACGPM(ACG4XX,ACG304),U)=$P(ACGPM(ACG4XX,ACG304),U)+ACG26,ACGPM(ACG4XX)=ACGPM(ACG4XX)+ACG26
.S $P(ACGPM(ACG4XX,ACG306),U,2)=$P(ACGPM(ACG4XX,ACG306),U,2)+1,$P(ACGPM(ACG4XX,1),U,3)=$P(ACGPM(ACG4XX,1),U,3)+1,$P(ACGPM(ACG4XX,1),U,4)=$P(ACGPM(ACG4XX,1),U,4)+ACG26
.;SET PREFERENCE PROGRAM BUCKETS
.S $P(ACGPP(ACG4XX,ACG303),U)=$P(ACGPP(ACG4XX,ACG303),U)+ACG26,$P(ACGPP(ACG4XX,ACG303),U,2)=$P(ACGPP(ACG4XX,ACG303),U,2)+1
.;SET TYPE OF CONTRACTOR BUCKETS
.S $P(ACGTC(ACG4XX,ACG305),U)=$P(ACGTC(ACG4XX,ACG305),U)+ACG26,$P(ACGTC(ACG4XX,ACG305),U,2)=$P(ACGTC(ACG4XX,ACG305),U,2)+1
.;SET EXTEND COMPETED BUCKETS
.S $P(ACGPM(ACG4XX,ACG307,ACG304),U)=$P(ACGPM(ACG4XX,ACG307,ACG304),U)+ACG26,$P(ACGPM(ACG4XX,ACG307),U)=$P(ACGPM(ACG4XX,ACG307),U)+ACG26,$P(ACGPM(ACG4XX,ACG307),U,2)=$P(ACGPM(ACG4XX,ACG307),U,2)+1
Q
QT ;EP;TO DETERMINE DATE RANGE FOR QUARTERS
S DIR(0)="SO^1:FIRST;2:SECOND;3:THIRD;4:FOURTH;5:YEAR-TO-DATE",DIR("A")="Quarter....",DIR("?")="Enter the quarter for the report"
W !
D DIR^ACGSDIC
Q:$D(ACGQUIT)
S ACGQT=+Y
I ACGQT=5 S ACGQTX=5,ACGQT=1
D FY^ACGSEXP
I $D(ACGQTX) S ACGQT=5 K ACGQTX
Q:$D(ACGQUIT)
PERIOD S:ACGQT=1!(ACGQT=5) ACGFY=ACGFY-1
;S ACGBEGIN=2_ACGFY_$S(ACGQT=1!(ACGQT=5):10,ACGQT=2:"01",ACGQT=3:"04",1:"07")_"00",ACGEND=2_ACGFY_$S(ACGQT=1:12,ACGQT=2:"03",ACGQT=3:"06",1:"09")_$S(ACGQT<3:31,1:30)
S ACGBEGIN=ACGFY_$S(ACGQT=1!(ACGQT=5):10,ACGQT=2:"01",ACGQT=3:"04",1:"07")_"00",ACGEND=ACGFY_$S(ACGQT=1:12,ACGQT=2:"03",ACGQT=3:"06",1:"09")_$S(ACGQT<3:31,1:30) ;y2k;mlp
;S:ACGQT=5 ACGEND=2_(ACGFY+1)_"0930"
S:ACGQT=5 ACGEND=(ACGFY+1)_"0930" ;y2k;mlp
S:ACGQT=1!(ACGQT=5) ACGFY=ACGFY+1
Q
CO S DIR(0)="SO^102:OES Seattle;121:OES New York;161:OES Dallas;235:California;236:Headquarters;239:Bemidji;241:Aberdeen;242:Albuquerque;243:Alaska;244:Billings;245:Navajo;246:Oklahoma;247:Phoenix;248:Portland;249:Tucson"
S DIR(0)=DIR(0)_";284:Perry Point;285:Nashville;88:Each Office;99:Summary Report",DIR("A")="Contracting Office",DIR("?")="Enter the number of the Contracting office"
D DIR^ACGSDIC
Q:$D(ACGQUIT)
S (ACG4X,ACG4XX)=+Y
Q
HEAD ;EP;TO PRINT HEADER
S Y=DT X ^DD("DD") S ACGTODAY=Y
W !?15,"FEDERAL PROCUREMENT DATA SYSTEM (FPDS)",!?15,"SUMMARY CONTRACT ACTION REPORT ($100,000 OR LESS)"
W !,"A. REPORT PERIOD",?25,"B. REPORT TYPE",?55,"C. REPORTING AGENCY CODE"
W !,"FY: ",ACGFY," QT: ",ACGQT,?25,"|",$S(ACGORIGN=1:"XX",1:" "),"| ORIGINAL |",$S(ACGORIGN=2:"XX",1:" "),"| REVISION"
D L
W !,"D. REPORTING AGENCY NAME",?27,"E. CONTRACT OFFICE CODE",?52,"F. CONTRACT OFFICE NAME"
W !?3,"INDIAN HEALTH SERVICE",?30,ACG4XX,?55,$P(^ACGPO($P(ACGPARA,U),0),U)
D L
W !?15,"PART I - PRIME CONTRACT ACTIONS OF $100,000 OR LESS"
D L
W !,"NEW AWARDS AND MODIFICATIONS",?30,"|",?40,"NET DOLLAR AMOUNTS (THOUSANDS)"
W !,"------------------------------|-------------------------------------------------"
W !?20,"| NUMBER | SMALL | LARGE |DOMESTIC | |"
W !,?20,"| OF |BUSINESS |BUSINESS |OUTSIDE/ | OTHER | TOTAL"
W !,"PROCUREMENT METHOD",?20,"| ACTIONS |CONCERNS |CONCERNS |FOREIGN | ENTITIES| DOLLARS"
W !?20,"| (a) | (b) | (c) | (d) | (e) | (f) "
D ^ACGS2811
Q
L W !,"--------------------------------------------------------------------------------"
Q
ACGS282 ;IHS/OIRM/DSD/THL,AEF - UTILITY TO PRINT THE SMALL PURCHASE 281 REPORT - CONT; [ 03/27/2000 2:22 PM ]
+1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
+2 ;;UTILITY TO PRINT THE SMALL PURCHASE 281 REPORT
+3 ;;modified for y2k;mlp;01/31/2000
B1 ;EP
+1 SET ACGRDA=0
+2 FOR
SET ACGRDA=$ORDER(^ACGS("R",ACGBEG,ACGRDA))
IF 'ACGRDA
QUIT
IF "^15^17^"[(U_+^ACGS(ACGRDA,"DT")_U)
IF $DATA(^("SP"))
SET ACGDT=^("DT")
SET ACG26=$PIECE($PIECE(^("DT1"),U,5),".")
SET ACGSP=^("SP")
Begin DoDot:1
+3 IF $PIECE(ACGDT,U,2)["PENDING"
QUIT
+4 IF ACG4X'=99
IF $PIECE(ACGDT,U,4)'=ACG4X
QUIT
+5 IF $PIECE(ACGSP,U,7)=""
SET ACG12=$PIECE(ACGDT,U,12)
IF ACG12]""
IF ACG12="D"
SET ACG12="C"
SET DA=ACGRDA
SET DIE="^ACGS("
SET DR="307////"_ACG12
DO DIE^ACGSDIC
WRITE "."
+6 FOR ACG=3:1:7
SET @("ACG30"_ACG)=$PIECE(ACGSP,U,ACG)
+7 FOR ACG=3:1:7
IF @("ACG30"_ACG)=""
SET ACGQUIT=""
QUIT
+8 IF $DATA(ACGQUIT)
KILL ACGQUIT
QUIT
+9 ;SET PROCUREMENT METHOD/TYPE OF BUSINESS BUCKETS
+10 SET $PIECE(ACGPM(ACG4XX,ACG306,ACG304),U)=$PIECE(ACGPM(ACG4XX,ACG306,ACG304),U)+ACG26
SET $PIECE(ACGPM(ACG4XX,ACG306),U)=$PIECE(ACGPM(ACG4XX,ACG306),U)+ACG26
SET $PIECE(ACGPM(ACG4XX,ACG304),U)=$PIECE(ACGPM(ACG4XX,ACG304),U)+ACG26
SET ACGPM(ACG4XX)=ACGPM(ACG4XX)+ACG26
+11 SET $PIECE(ACGPM(ACG4XX,ACG306),U,2)=$PIECE(ACGPM(ACG4XX,ACG306),U,2)+1
SET $PIECE(ACGPM(ACG4XX,1),U,3)=$PIECE(ACGPM(ACG4XX,1),U,3)+1
SET $PIECE(ACGPM(ACG4XX,1),U,4)=$PIECE(ACGPM(ACG4XX,1),U,4)+ACG26
+12 ;SET PREFERENCE PROGRAM BUCKETS
+13 SET $PIECE(ACGPP(ACG4XX,ACG303),U)=$PIECE(ACGPP(ACG4XX,ACG303),U)+ACG26
SET $PIECE(ACGPP(ACG4XX,ACG303),U,2)=$PIECE(ACGPP(ACG4XX,ACG303),U,2)+1
+14 ;SET TYPE OF CONTRACTOR BUCKETS
+15 SET $PIECE(ACGTC(ACG4XX,ACG305),U)=$PIECE(ACGTC(ACG4XX,ACG305),U)+ACG26
SET $PIECE(ACGTC(ACG4XX,ACG305),U,2)=$PIECE(ACGTC(ACG4XX,ACG305),U,2)+1
+16 ;SET EXTEND COMPETED BUCKETS
+17 SET $PIECE(ACGPM(ACG4XX,ACG307,ACG304),U)=$PIECE(ACGPM(ACG4XX,ACG307,ACG304),U)+ACG26
SET $PIECE(ACGPM(ACG4XX,ACG307),U)=$PIECE(ACGPM(ACG4XX,ACG307),U)+ACG26
SET $PIECE(ACGPM(ACG4XX,ACG307),U,2)=$PIECE(ACGPM(ACG4XX,ACG307),U,2)+1
End DoDot:1
+18 QUIT
QT ;EP;TO DETERMINE DATE RANGE FOR QUARTERS
+1 SET DIR(0)="SO^1:FIRST;2:SECOND;3:THIRD;4:FOURTH;5:YEAR-TO-DATE"
SET DIR("A")="Quarter...."
SET DIR("?")="Enter the quarter for the report"
+2 WRITE !
+3 DO DIR^ACGSDIC
+4 IF $DATA(ACGQUIT)
QUIT
+5 SET ACGQT=+Y
+6 IF ACGQT=5
SET ACGQTX=5
SET ACGQT=1
+7 DO FY^ACGSEXP
+8 IF $DATA(ACGQTX)
SET ACGQT=5
KILL ACGQTX
+9 IF $DATA(ACGQUIT)
QUIT
PERIOD IF ACGQT=1!(ACGQT=5)
SET ACGFY=ACGFY-1
+1 ;S ACGBEGIN=2_ACGFY_$S(ACGQT=1!(ACGQT=5):10,ACGQT=2:"01",ACGQT=3:"04",1:"07")_"00",ACGEND=2_ACGFY_$S(ACGQT=1:12,ACGQT=2:"03",ACGQT=3:"06",1:"09")_$S(ACGQT<3:31,1:30)
+2 ;y2k;mlp
SET ACGBEGIN=ACGFY_$SELECT(ACGQT=1!(ACGQT=5):10,ACGQT=2:"01",ACGQT=3:"04",1:"07")_"00"
SET ACGEND=ACGFY_$SELECT(ACGQT=1:12,ACGQT=2:"03",ACGQT=3:"06",1:"09")_$SELECT(ACGQT<3:31,1:30)
+3 ;S:ACGQT=5 ACGEND=2_(ACGFY+1)_"0930"
+4 ;y2k;mlp
IF ACGQT=5
SET ACGEND=(ACGFY+1)_"0930"
+5 IF ACGQT=1!(ACGQT=5)
SET ACGFY=ACGFY+1
+6 QUIT
CO SET DIR(0)="SO^102:OES Seattle;121:OES New York;161:OES Dallas;235:California;236:Headquarters;239:Bemidji;241:Aberdeen;242:Albuquerque;243:Alaska;244:Billings;245:Navajo;246:Oklahoma;247:Phoenix;248:Portland;249:Tucson"
+1 SET DIR(0)=DIR(0)_";284:Perry Point;285:Nashville;88:Each Office;99:Summary Report"
SET DIR("A")="Contracting Office"
SET DIR("?")="Enter the number of the Contracting office"
+2 DO DIR^ACGSDIC
+3 IF $DATA(ACGQUIT)
QUIT
+4 SET (ACG4X,ACG4XX)=+Y
+5 QUIT
HEAD ;EP;TO PRINT HEADER
+1 SET Y=DT
XECUTE ^DD("DD")
SET ACGTODAY=Y
+2 WRITE !?15,"FEDERAL PROCUREMENT DATA SYSTEM (FPDS)",!?15,"SUMMARY CONTRACT ACTION REPORT ($100,000 OR LESS)"
+3 WRITE !,"A. REPORT PERIOD",?25,"B. REPORT TYPE",?55,"C. REPORTING AGENCY CODE"
+4 WRITE !,"FY: ",ACGFY," QT: ",ACGQT,?25,"|",$SELECT(ACGORIGN=1:"XX",1:" "),"| ORIGINAL |",$SELECT(ACGORIGN=2:"XX",1:" "),"| REVISION"
+5 DO L
+6 WRITE !,"D. REPORTING AGENCY NAME",?27,"E. CONTRACT OFFICE CODE",?52,"F. CONTRACT OFFICE NAME"
+7 WRITE !?3,"INDIAN HEALTH SERVICE",?30,ACG4XX,?55,$PIECE(^ACGPO($PIECE(ACGPARA,U),0),U)
+8 DO L
+9 WRITE !?15,"PART I - PRIME CONTRACT ACTIONS OF $100,000 OR LESS"
+10 DO L
+11 WRITE !,"NEW AWARDS AND MODIFICATIONS",?30,"|",?40,"NET DOLLAR AMOUNTS (THOUSANDS)"
+12 WRITE !,"------------------------------|-------------------------------------------------"
+13 WRITE !?20,"| NUMBER | SMALL | LARGE |DOMESTIC | |"
+14 WRITE !,?20,"| OF |BUSINESS |BUSINESS |OUTSIDE/ | OTHER | TOTAL"
+15 WRITE !,"PROCUREMENT METHOD",?20,"| ACTIONS |CONCERNS |CONCERNS |FOREIGN | ENTITIES| DOLLARS"
+16 WRITE !?20,"| (a) | (b) | (c) | (d) | (e) | (f) "
+17 DO ^ACGS2811
+18 QUIT
L WRITE !,"--------------------------------------------------------------------------------"
+1 QUIT
