ACGPTCS ; GENERATED FROM 'ACG PHSCIS SUMMARY' PRINT TEMPLATE (#4000) ; 10/01/09 ; (FILE 9002330, MARGIN=80)
G BEGIN
N W !
T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP^DIO2
Q
DT I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
W Y Q
M D @DIXX
Q
BEGIN ;
S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)
I $D(DXS)<9 M DXS=^DIPT(4000,"DXS")
S I(0)="^ACGS(",J(0)=9002330
W ?0 I 1 W:$D(IOF)&$D(ACGAH) @IOF K DIP K:DN Y
D N:$X>54 Q:'DN W ?54 W "PAGE:"
W ?61 S X=$S($D(DC)#2:DC,1:"") K DIP K:DN Y W X
D N:$X>0 Q:'DN W ?0 W "1 TYPE ACTION:"
W ?17 S DIP(1)=$S($D(^ACGS(D0,"DT")):^("DT"),1:"") S X="("_$S('$D(^ACGTPA(+$P(DIP(1),U,1),0)):"",1:$P(^(0),U,1))_") " K DIP K:DN Y W X
X DXS(1,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,16)
D N:$X>39 Q:'DN W ?39 W "2 CONTRACT NO:"
S X=$G(^ACGS(D0,"DT")) W ?56,$E($P(X,U,2),1,15)
D N:$X>0 Q:'DN W ?0 W "3 AGENCY ORD#:"
W ?17,$E($P(X,U,3),1,14)
D N:$X>39 Q:'DN W ?39 W "4 CONT OFFICE:"
W ?56,$E($P(X,U,4),1,3)
D N:$X>0 Q:'DN W ?0 W "5 CONTRACTOR.:"
W ?17,$E($P(X,U,5),1,30)
D N:$X>0 Q:'DN W ?0 W "6 ADDRESS....:"
W ?17,$E($P(X,U,6),1,30)
W " "
W ?0,$E($P(X,U,7),1,23)
W ", "
S Y=$P(X,U,8) S Y=$S(Y="":Y,$D(^DIC(5,Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,30)
W " "
W ?0,$E($P(X,U,9),1,5)
D N:$X>0 Q:'DN W ?0 W "10 CONGRS DIST:"
W ?17,$E($P(X,U,10),1,3)
D N:$X>39 Q:'DN W ?39 W "11 EIN........:"
W ?56,$E($P(X,U,11),1,12)
D N:$X>0 Q:'DN W ?0 W "12 EXTENT CMPD:"
W ?17 S Y=$P(X,U,12) W:Y]"" $S($D(DXS(9,Y)):DXS(9,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "13 TYPE OF BUS:"
W ?56 X DXS(2,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,20)
D N:$X>0 Q:'DN W ?0 W "14 NEG AUTH...:"
S X=$G(^ACGS(D0,"DT")) W ?17,$E($P(X,U,14),1,2)
D N:$X>39 Q:'DN W ?39 W "15 CONTR TYPE.:"
W ?56 X DXS(3,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,20)
D N:$X>0 Q:'DN W ?0 W "16 AA SRV CONT:"
S X=$G(^ACGS(D0,"DT")) W ?17 S Y=$P(X,U,16) W:Y]"" $S($D(DXS(10,Y)):DXS(10,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "17 SOLICITATN.:"
W ?56 X DXS(4,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,20)
D N:$X>0 Q:'DN W ?0 W "18 AOFOC......:"
W ?17 X DXS(5,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,20)
D N:$X>39 Q:'DN W ?39 W "19 EXTENT COMP:"
W ?56 X DXS(6,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,20)
D N:$X>0 Q:'DN W ?0 W "20 CONT METHOD:"
W ?17 X DXS(7,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W $E(X,1,20)
D N:$X>39 Q:'DN W ?39 W "21 OFFERS RCVD:"
S X=$G(^ACGS(D0,"DT")) W ?56 S Y=$P(X,U,21) W:Y]"" $J(Y,3,0)
D N:$X>0 Q:'DN W ?0 W "22 PROJECT TTL:"
D N:$X>17 Q:'DN W ?17 S DIP(1)=$S($D(^ACGS(D0,"DT1")):^("DT1"),1:"") S X=$P(DIP(1),U,1),DIP(2)=X S X=1,DIP(3)=X S X=63,X=$E(DIP(2),DIP(3),X) K DIP K:DN Y W X
W ?28 I $D(^ACGS(D0,"DT1")),$L($P(^("DT1"),U))>63 W !?17,$E($P(^("DT1"),U),64,97) K DIP K:DN Y
W ?39 W " " K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "23 AWARD DATE.:"
S X=$G(^ACGS(D0,"DT1")) W ?17 S Y=$P(X,U,2) D DT
D N:$X>39 Q:'DN W ?39 W "24 START DATE.:"
W ?56 S Y=$P(X,U,3) D DT
D N:$X>0 Q:'DN W ?0 W "25 END DATE...:"
W ?17 S Y=$P(X,U,4) D DT
D N:$X>39 Q:'DN W ?39 W "26 DOLLAR AMNT:"
W ?56 S Y=$P(X,U,5) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "27 PURPOSE CDE:"
W ?17 S Y=$P(X,U,6) S Y=$S(Y="":Y,$D(^ACGPPC(Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,4)
D N:$X>39 Q:'DN W ?39 W "28 PLACE PERF.:"
W ?56,$E($P(X,U,7),1,20)
D N:$X>0 Q:'DN W ?0 W "29 COST ACCNTG:"
W ?17 S Y=$P(X,U,8) W:Y]"" $S($D(DXS(11,Y)):DXS(11,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "30 WOMEN-OWNED:"
W ?56 S Y=$P(X,U,9) W:Y]"" $S($D(DXS(12,Y)):DXS(12,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "31 STAT REQS..:"
W ?17 S Y=$P(X,U,10) W:Y]"" $S($D(DXS(13,Y)):DXS(13,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "32 AFFIRM ACT.:"
W ?56 S Y=$P(X,U,11) W:Y]"" $S($D(DXS(14,Y)):DXS(14,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "33 TRADE DATA.:"
W ?17,$E($P(X,U,12),1,8)
D N:$X>39 Q:'DN W ?39 W "34 DATE OF RFC:"
W ?56 S Y=$P(X,U,13) D DT
W ?69 I $E(IOST,1,2)="C-" D HOLD^ACGSMENU W:$D(IOF) @IOF K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "35 PROJECT OFF:"
S X=$G(^ACGS(D0,"DT1")) W ?17,$E($P(X,U,14),1,20)
D N:$X>39 Q:'DN W ?39 W "36 INDIR COST.:"
S X=$G(^ACGS(D0,"DT2")) W ?56 S Y=$P(X,U,1) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "37 FIRST CAN #:"
W ?17,$E($P(X,U,2),1,8)
D N:$X>39 Q:'DN W ?39 W "38 FIRST CAN $:"
W ?56 S Y=$P(X,U,3) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "39 SECOND CAN#:"
W ?17,$E($P(X,U,4),1,8)
D N:$X>39 Q:'DN W ?39 W "40 SECOND CAN$:"
W ?56 S Y=$P(X,U,5) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "41 THIRD CAN #:"
W ?17,$E($P(X,U,6),1,8)
D N:$X>39 Q:'DN W ?39 W "42 THIRD CAN $:"
W ?56 S Y=$P(X,U,7) W:Y]"" $J(Y,8,0)
D N:$X>0 Q:'DN W ?0 W "43 CO-DIRECT..:"
W ?17 S Y=$P(X,U,8) W:Y]"" $J(Y,10,0)
D N:$X>39 Q:'DN W ?39 W "44 CO-INDIR...:"
W ?56 S Y=$P(X,U,9) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "45 SYNOPSIS...:"
W ?17 S Y=$P(X,U,10) W:Y]"" $S($D(DXS(15,Y)):DXS(15,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "46 FEE AWARDED:"
W ?56 S Y=$P(X,U,11) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "47 SUB-C $$...:"
W ?17 S Y=$P(X,U,12) W:Y]"" $J(Y,10,0)
D N:$X>39 Q:'DN W ?39 W "48 S-C NOT DIS:"
W ?56 S Y=$P(X,U,13) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "49 S-C DISADV.:"
W ?17 S Y=$P(X,U,14) W:Y]"" $J(Y,10,0)
D N:$X>39 Q:'DN W ?39 W "50 INCR FUNDED:"
W ?56 S Y=$P(X,U,15) W:Y]"" $J(Y,10,0)
D N:$X>0 Q:'DN W ?0 W "51 FORGN/INTRN:"
W ?17 S Y=$P(X,U,16) W:Y]"" $S($D(DXS(16,Y)):DXS(16,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "52 TAR/REGULAT:"
W ?56 S Y=$P(X,U,17) W:Y]"" $S($D(DXS(17,Y)):DXS(17,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "53 SIC CODE...:"
W ?17,$E($P(X,U,18),1,4)
D N:$X>39 Q:'DN W ?39 W "54 CP NAME....:"
W ?56,$E($P(X,U,19),1,20)
D N:$X>0 Q:'DN W ?0 W "55 CP TIN.....:"
W ?17,$E($P(X,U,20),1,9)
D N:$X>39 Q:'DN W ?39 W "56 SUB-C PLAN.:"
S X=$G(^ACGS(D0,"DT3")) W ?56 S Y=$P(X,U,1) W:Y]"" $S($D(DXS(18,Y)):DXS(18,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "57 SUB-K PLAN.:"
W ?17 S Y=$P(X,U,2) W:Y]"" $S($D(DXS(19,Y)):DXS(19,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "58 AIDS AFFLTD:"
W ?56 S Y=$P(X,U,3) W:Y]"" $S($D(DXS(20,Y)):DXS(20,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "59 AIDS DOLLAR:"
W ?17 S Y=$P(X,U,4) W:Y]"" $J(Y,10,0)
D N:$X>39 Q:'DN W ?39 W "60 MULT PLACE.:"
W ?56 S Y=$P(X,U,5) W:Y]"" $S($D(DXS(21,Y)):DXS(21,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "61 MULTPLE PSC:"
W ?17,$E($P(X,U,6),1,4)
D N:$X>39 Q:'DN W ?39 W "62 CICA APPLIC:"
W ?56 S Y=$P(X,U,7) W:Y]"" $S($D(DXS(22,Y)):DXS(22,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "63 SB DEMO TST:"
W ?17 S Y=$P(X,U,8) W:Y]"" $S($D(DXS(23,Y)):DXS(23,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "64 EMERGING SB:"
W ?56 S Y=$P(X,U,9) W:Y]"" $S($D(DXS(24,Y)):DXS(24,Y),1:Y)
D N:$X>0 Q:'DN W ?0 W "65 EM SB RES..:"
W ?17 S Y=$P(X,U,10) W:Y]"" $S($D(DXS(25,Y)):DXS(25,Y),1:Y)
D N:$X>39 Q:'DN W ?39 W "66 SIZE OF SB.:"
W ?56 X DXS(8,9.2) S X=$P(DIP(101),U,2) S D0=I(0,0) K DIP K:DN Y W X
D N:$X>0 Q:'DN W ?0 W "67 HANDICAP $$:"
G ^ACGPTCS1
ACGPTCS ; GENERATED FROM 'ACG PHSCIS SUMMARY' PRINT TEMPLATE (#4000) ; 10/01/09 ; (FILE 9002330, MARGIN=80)
+1 GOTO BEGIN
N WRITE !
T IF $X
WRITE !
IF '$DATA(DIOT(2))
IF DN
IF $DATA(IOSL)
IF $SELECT('$DATA(DIWF):1,$PIECE(DIWF,"B",2):$PIECE(DIWF,"B",2),1:1)+$Y'<IOSL
IF $DATA(^UTILITY($JOB,1))#2
IF ^(1)?1U1P1E.E
XECUTE ^(1)
+1 SET DISTP=DISTP+1
SET DILCT=DILCT+1
IF '(DISTP#100)
DO CSTP^DIO2
+2 QUIT
DT IF $GET(DUZ("LANG"))>1
IF Y
WRITE $$OUT^DIALOGU(Y,"DD")
QUIT
+1 IF Y
WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))_" "
IF Y#100
WRITE $JUSTIFY(Y#100\1,2)_","
WRITE Y\10000+1700
IF Y#1
WRITE " "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12)
QUIT
+2 WRITE Y
QUIT
M DO @DIXX
+1 QUIT
BEGIN ;
+1 IF '$DATA(DN)
SET DN=1
SET DISTP=$GET(DISTP)
SET DILCT=$GET(DILCT)
+2 IF $DATA(DXS)<9
MERGE DXS=^DIPT(4000,"DXS")
+3 SET I(0)="^ACGS("
SET J(0)=9002330
+4 WRITE ?0
IF 1
IF $DATA(IOF)&$DATA(ACGAH)
WRITE @IOF
KILL DIP
IF DN
KILL Y
+5 IF $X>54
DO N
IF 'DN
QUIT
WRITE ?54
WRITE "PAGE:"
+6 WRITE ?61
SET X=$SELECT($DATA(DC)#2:DC,1:"")
KILL DIP
IF DN
KILL Y
WRITE X
+7 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "1 TYPE ACTION:"
+8 WRITE ?17
SET DIP(1)=$SELECT($DATA(^ACGS(D0,"DT")):^("DT"),1:"")
SET X="("_$SELECT('$DATA(^ACGTPA(+$PIECE(DIP(1),U,1),0)):"",1:$PIECE(^(0),U,1))_") "
KILL DIP
IF DN
KILL Y
WRITE X
+9 XECUTE DXS(1,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,16)
+10 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "2 CONTRACT NO:"
+11 SET X=$GET(^ACGS(D0,"DT"))
WRITE ?56,$EXTRACT($PIECE(X,U,2),1,15)
+12 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "3 AGENCY ORD#:"
+13 WRITE ?17,$EXTRACT($PIECE(X,U,3),1,14)
+14 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "4 CONT OFFICE:"
+15 WRITE ?56,$EXTRACT($PIECE(X,U,4),1,3)
+16 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "5 CONTRACTOR.:"
+17 WRITE ?17,$EXTRACT($PIECE(X,U,5),1,30)
+18 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "6 ADDRESS....:"
+19 WRITE ?17,$EXTRACT($PIECE(X,U,6),1,30)
+20 WRITE " "
+21 WRITE ?0,$EXTRACT($PIECE(X,U,7),1,23)
+22 WRITE ", "
+23 SET Y=$PIECE(X,U,8)
SET Y=$SELECT(Y="":Y,$DATA(^DIC(5,Y,0))#2:$PIECE(^(0),U),1:Y)
WRITE $EXTRACT(Y,1,30)
+24 WRITE " "
+25 WRITE ?0,$EXTRACT($PIECE(X,U,9),1,5)
+26 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "10 CONGRS DIST:"
+27 WRITE ?17,$EXTRACT($PIECE(X,U,10),1,3)
+28 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "11 EIN........:"
+29 WRITE ?56,$EXTRACT($PIECE(X,U,11),1,12)
+30 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "12 EXTENT CMPD:"
+31 WRITE ?17
SET Y=$PIECE(X,U,12)
IF Y]""
WRITE $SELECT($DATA(DXS(9,Y)):DXS(9,Y),1:Y)
+32 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "13 TYPE OF BUS:"
+33 WRITE ?56
XECUTE DXS(2,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,20)
+34 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "14 NEG AUTH...:"
+35 SET X=$GET(^ACGS(D0,"DT"))
WRITE ?17,$EXTRACT($PIECE(X,U,14),1,2)
+36 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "15 CONTR TYPE.:"
+37 WRITE ?56
XECUTE DXS(3,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,20)
+38 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "16 AA SRV CONT:"
+39 SET X=$GET(^ACGS(D0,"DT"))
WRITE ?17
SET Y=$PIECE(X,U,16)
IF Y]""
WRITE $SELECT($DATA(DXS(10,Y)):DXS(10,Y),1:Y)
+40 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "17 SOLICITATN.:"
+41 WRITE ?56
XECUTE DXS(4,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,20)
+42 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "18 AOFOC......:"
+43 WRITE ?17
XECUTE DXS(5,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,20)
+44 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "19 EXTENT COMP:"
+45 WRITE ?56
XECUTE DXS(6,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,20)
+46 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "20 CONT METHOD:"
+47 WRITE ?17
XECUTE DXS(7,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE $EXTRACT(X,1,20)
+48 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "21 OFFERS RCVD:"
+49 SET X=$GET(^ACGS(D0,"DT"))
WRITE ?56
SET Y=$PIECE(X,U,21)
IF Y]""
WRITE $JUSTIFY(Y,3,0)
+50 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "22 PROJECT TTL:"
+51 IF $X>17
DO N
IF 'DN
QUIT
WRITE ?17
SET DIP(1)=$SELECT($DATA(^ACGS(D0,"DT1")):^("DT1"),1:"")
SET X=$PIECE(DIP(1),U,1)
SET DIP(2)=X
SET X=1
SET DIP(3)=X
SET X=63
SET X=$EXTRACT(DIP(2),DIP(3),X)
KILL DIP
IF DN
KILL Y
WRITE X
+52 WRITE ?28
IF $DATA(^ACGS(D0,"DT1"))
IF $LENGTH($PIECE(^("DT1"),U))>63
WRITE !?17,$EXTRACT($PIECE(^("DT1"),U),64,97)
KILL DIP
IF DN
KILL Y
+53 WRITE ?39
WRITE " "
KILL DIP
IF DN
KILL Y
+54 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "23 AWARD DATE.:"
+55 SET X=$GET(^ACGS(D0,"DT1"))
WRITE ?17
SET Y=$PIECE(X,U,2)
DO DT
+56 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "24 START DATE.:"
+57 WRITE ?56
SET Y=$PIECE(X,U,3)
DO DT
+58 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "25 END DATE...:"
+59 WRITE ?17
SET Y=$PIECE(X,U,4)
DO DT
+60 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "26 DOLLAR AMNT:"
+61 WRITE ?56
SET Y=$PIECE(X,U,5)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+62 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "27 PURPOSE CDE:"
+63 WRITE ?17
SET Y=$PIECE(X,U,6)
SET Y=$SELECT(Y="":Y,$DATA(^ACGPPC(Y,0))#2:$PIECE(^(0),U),1:Y)
WRITE $EXTRACT(Y,1,4)
+64 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "28 PLACE PERF.:"
+65 WRITE ?56,$EXTRACT($PIECE(X,U,7),1,20)
+66 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "29 COST ACCNTG:"
+67 WRITE ?17
SET Y=$PIECE(X,U,8)
IF Y]""
WRITE $SELECT($DATA(DXS(11,Y)):DXS(11,Y),1:Y)
+68 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "30 WOMEN-OWNED:"
+69 WRITE ?56
SET Y=$PIECE(X,U,9)
IF Y]""
WRITE $SELECT($DATA(DXS(12,Y)):DXS(12,Y),1:Y)
+70 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "31 STAT REQS..:"
+71 WRITE ?17
SET Y=$PIECE(X,U,10)
IF Y]""
WRITE $SELECT($DATA(DXS(13,Y)):DXS(13,Y),1:Y)
+72 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "32 AFFIRM ACT.:"
+73 WRITE ?56
SET Y=$PIECE(X,U,11)
IF Y]""
WRITE $SELECT($DATA(DXS(14,Y)):DXS(14,Y),1:Y)
+74 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "33 TRADE DATA.:"
+75 WRITE ?17,$EXTRACT($PIECE(X,U,12),1,8)
+76 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "34 DATE OF RFC:"
+77 WRITE ?56
SET Y=$PIECE(X,U,13)
DO DT
+78 WRITE ?69
IF $EXTRACT(IOST,1,2)="C-"
DO HOLD^ACGSMENU
IF $DATA(IOF)
WRITE @IOF
KILL DIP
IF DN
KILL Y
+79 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "35 PROJECT OFF:"
+80 SET X=$GET(^ACGS(D0,"DT1"))
WRITE ?17,$EXTRACT($PIECE(X,U,14),1,20)
+81 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "36 INDIR COST.:"
+82 SET X=$GET(^ACGS(D0,"DT2"))
WRITE ?56
SET Y=$PIECE(X,U,1)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+83 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "37 FIRST CAN #:"
+84 WRITE ?17,$EXTRACT($PIECE(X,U,2),1,8)
+85 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "38 FIRST CAN $:"
+86 WRITE ?56
SET Y=$PIECE(X,U,3)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+87 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "39 SECOND CAN#:"
+88 WRITE ?17,$EXTRACT($PIECE(X,U,4),1,8)
+89 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "40 SECOND CAN$:"
+90 WRITE ?56
SET Y=$PIECE(X,U,5)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+91 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "41 THIRD CAN #:"
+92 WRITE ?17,$EXTRACT($PIECE(X,U,6),1,8)
+93 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "42 THIRD CAN $:"
+94 WRITE ?56
SET Y=$PIECE(X,U,7)
IF Y]""
WRITE $JUSTIFY(Y,8,0)
+95 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "43 CO-DIRECT..:"
+96 WRITE ?17
SET Y=$PIECE(X,U,8)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+97 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "44 CO-INDIR...:"
+98 WRITE ?56
SET Y=$PIECE(X,U,9)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+99 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "45 SYNOPSIS...:"
+100 WRITE ?17
SET Y=$PIECE(X,U,10)
IF Y]""
WRITE $SELECT($DATA(DXS(15,Y)):DXS(15,Y),1:Y)
+101 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "46 FEE AWARDED:"
+102 WRITE ?56
SET Y=$PIECE(X,U,11)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+103 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "47 SUB-C $$...:"
+104 WRITE ?17
SET Y=$PIECE(X,U,12)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+105 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "48 S-C NOT DIS:"
+106 WRITE ?56
SET Y=$PIECE(X,U,13)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+107 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "49 S-C DISADV.:"
+108 WRITE ?17
SET Y=$PIECE(X,U,14)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+109 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "50 INCR FUNDED:"
+110 WRITE ?56
SET Y=$PIECE(X,U,15)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+111 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "51 FORGN/INTRN:"
+112 WRITE ?17
SET Y=$PIECE(X,U,16)
IF Y]""
WRITE $SELECT($DATA(DXS(16,Y)):DXS(16,Y),1:Y)
+113 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "52 TAR/REGULAT:"
+114 WRITE ?56
SET Y=$PIECE(X,U,17)
IF Y]""
WRITE $SELECT($DATA(DXS(17,Y)):DXS(17,Y),1:Y)
+115 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "53 SIC CODE...:"
+116 WRITE ?17,$EXTRACT($PIECE(X,U,18),1,4)
+117 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "54 CP NAME....:"
+118 WRITE ?56,$EXTRACT($PIECE(X,U,19),1,20)
+119 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "55 CP TIN.....:"
+120 WRITE ?17,$EXTRACT($PIECE(X,U,20),1,9)
+121 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "56 SUB-C PLAN.:"
+122 SET X=$GET(^ACGS(D0,"DT3"))
WRITE ?56
SET Y=$PIECE(X,U,1)
IF Y]""
WRITE $SELECT($DATA(DXS(18,Y)):DXS(18,Y),1:Y)
+123 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "57 SUB-K PLAN.:"
+124 WRITE ?17
SET Y=$PIECE(X,U,2)
IF Y]""
WRITE $SELECT($DATA(DXS(19,Y)):DXS(19,Y),1:Y)
+125 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "58 AIDS AFFLTD:"
+126 WRITE ?56
SET Y=$PIECE(X,U,3)
IF Y]""
WRITE $SELECT($DATA(DXS(20,Y)):DXS(20,Y),1:Y)
+127 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "59 AIDS DOLLAR:"
+128 WRITE ?17
SET Y=$PIECE(X,U,4)
IF Y]""
WRITE $JUSTIFY(Y,10,0)
+129 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "60 MULT PLACE.:"
+130 WRITE ?56
SET Y=$PIECE(X,U,5)
IF Y]""
WRITE $SELECT($DATA(DXS(21,Y)):DXS(21,Y),1:Y)
+131 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "61 MULTPLE PSC:"
+132 WRITE ?17,$EXTRACT($PIECE(X,U,6),1,4)
+133 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "62 CICA APPLIC:"
+134 WRITE ?56
SET Y=$PIECE(X,U,7)
IF Y]""
WRITE $SELECT($DATA(DXS(22,Y)):DXS(22,Y),1:Y)
+135 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "63 SB DEMO TST:"
+136 WRITE ?17
SET Y=$PIECE(X,U,8)
IF Y]""
WRITE $SELECT($DATA(DXS(23,Y)):DXS(23,Y),1:Y)
+137 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "64 EMERGING SB:"
+138 WRITE ?56
SET Y=$PIECE(X,U,9)
IF Y]""
WRITE $SELECT($DATA(DXS(24,Y)):DXS(24,Y),1:Y)
+139 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "65 EM SB RES..:"
+140 WRITE ?17
SET Y=$PIECE(X,U,10)
IF Y]""
WRITE $SELECT($DATA(DXS(25,Y)):DXS(25,Y),1:Y)
+141 IF $X>39
DO N
IF 'DN
QUIT
WRITE ?39
WRITE "66 SIZE OF SB.:"
+142 WRITE ?56
XECUTE DXS(8,9.2)
SET X=$PIECE(DIP(101),U,2)
SET D0=I(0,0)
KILL DIP
IF DN
KILL Y
WRITE X
+143 IF $X>0
DO N
IF 'DN
QUIT
WRITE ?0
WRITE "67 HANDICAP $$:"
+144 GOTO ^ACGPTCS1
