ACGSTEMP ;IHS/OIRM/DSD/THL,AEF - ROUTINE TO CHECK DATA INTEGRITY; [ 03/27/2000 2:22 PM ]
;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
;This routine has been renovated for Y2k Compliance ;MLP;01/24/2000
Q
EN ;EP;TO BEGIN DATA INTEGRITY CHECK
D ^XBKVAR
D ACG53,ACG27
S DA=0
ENX F S DA=$O(^ACGS(DA)) Q:'DA I $D(^ACGS(DA,0)),$D(^("DT")),$D(^("DT1")),$D(^("DT2")),$D(^("DT3")) S ACG0=^(0),ACGDT=^("DT"),ACGDT1=^("DT1"),ACGDT2=^("DT2"),ACGDT3=^("DT3") D
.Q:'$P(ACG0,U,3)
.Q:+ACGDT=15!(+ACGDT=17)
.S DR="",DIE="^ACGS(",ACG12=$P(ACGDT,U,12),ACG2=$P(ACGDT,U,2),ACG13DA=$P(ACGDT,U,13),ACG19DA=$P(ACGDT,U,19),ACG17DA=$P(ACGDT,U,17),ACG30=$P(ACGDT1,U,9),ACG5=$P(ACGDT,U,5)
.I DA'=$P(ACG0,U,3) S ACGCON=$O(^ACGS("B",$E($P(ACGDT,U,2),1,9)_"000",0)) I $P(ACG0,U,3)'=ACGCON S DR=DR_".03////"_ACGCON_";" ;W !,$P(ACGDT,U,2),?10,"ORIGINAL CONTRACT NUMBER CHANGE",?40,DA ;W ?50,DR
.I $E(ACG2,10)="Q" S $E(ACG2,10)=9,DR="2////"_ACG2_";" ;W !?20,"Q ACTIONS"
.I ACG13DA,$D(^AUTTTOB(ACG13DA,0)) S ACG13=$P(^(0),U)
.I ACG17DA,$D(^ACGSP(ACG17DA,0)) S ACG17=$P(^(0),U)
.I ACG19DA,$D(^ACGEOC(ACG19DA,0)) S ACG19=$P(^(0),U)
.D 63
.I DA'=$P(ACG0,U,3),$P(ACG0,U,3)]"",$D(^ACGS($P(ACG0,U,3),0)),$D(^("DT")) S ACGODT=^("DT") I ACG13DA'=$P(ACGODT,U,13) S DR=DR_"13////"_$P(ACGODT,U,13)_";" ;W !,ACG2,?20,"TOB"
.I ACG13DA>3,ACG30=1 S DR=DR_"30////2;" ;W !,ACG2,?20,"WOB"
.I $E(ACG2,4,5)>87,ACG12'="A",$P(ACGDT3,U,7)="C",$P(ACGDT,U,18)'=81 S DR=DR_"18////81;" ;W !,ACG2,?20,"EOC"
.I ACG13DA=1,5960'[$P(ACGDT,U,19) S DR=DR_"19////"_$S($P(ACGDT,U,12)="A":59,1:60)_";" ;W !,ACG2,?20,5960
.I $E(ACG2,4,5)>87,$E(ACG0)="0",+ACGDT=1!(+ACGDT=2),$P(ACGDT,U,21)<1 S DR=DR_"21////1;" ;W !,ACG2,?20,"1 OFFER"
.I $E($P(ACGDT,U,3),1,2)="3-" S DR=DR_"3////"_3_$E($P(ACGDT,U,3),3,99)_";" ;W !,ACG2,?20,"AGENCY ORDER NUMBER"
.I $D(ACG19),ACG19=59,ACG13="A1",ACG17'="4J" S DR=DR_"17////10;" ;W !,ACG2,?20,"SOLICITATION PROCEDURE MUST = '4J'"
.I DR]"",ACG2]"" D ^DIE ;W !?20,DR
Q
63 ;
S ACG53=$P(ACGDT2,U,18),ACG27=$P(ACGDT1,U,6)
S:ACG53="" ACG53="XXXX"
Q:ACG27=""
S ACG27=$S($D(^ACGPPC(ACG27,0)):$P(^(0),U),1:"")
Q:ACG27=""
;I $P(ACGDT3,U,8)=2,$E($P($G(^ACGS($P(ACG0,U,3),"DT1")),U,2),2,7)>890500,$D(ACG27(ACG27))!$D(ACG53(ACG53)),"A1A2A3B1B2"[ACG13,$P(ACGDT3,U,8)'=1 D
;.S DR=DR_"63////1;64////2;"_$S($P(ACGDT3,U,11)=""&("A1A2A3"[ACG13):"66////1;",1:"") ;W !,ACG2,?20,ACG13,?30,ACG27,?40,ACG53
I $P(ACGDT3,U,8)=2,$E($P($G(^ACGS($P(ACG0,U,3),"DT1")),U,2),1,7)>2890500,$D(ACG27(ACG27))!$D(ACG53(ACG53)),"A1A2A3B1B2"[ACG13,$P(ACGDT3,U,8)'=1 D ;Y2K;MLP
.S DR=DR_"63////1;64////2;"_$S($P(ACGDT3,U,11)=""&("A1A2A3"[ACG13):"66////1;",1:"") ;W !,ACG2,?20,ACG13,?30,ACG27,?40,ACG53 ;Y2K;MLP
;I $P(ACGDT3,U,8)=1,$E($P(^ACGS($P(ACG0,U,3),"DT1"),U,2),2,7)<890501 S DR=DR_"63////2;64///@;65///@;" ;W !,ACG2,?20,"INITIAL AWARD DATE < 890501"
I $P(ACGDT3,U,8)=1,$E($P(^ACGS($P(ACG0,U,3),"DT1"),U,2),1,7)<2890501 S DR=DR_"63////2;64///@;65///@;" ;W !,ACG2,?20,"INITIAL AWARD DATE < 890501" ;y2k;mlp
I $P(ACGDT3,U,8)=1,'$D(ACG27(ACG27))&'$D(ACG53(ACG53)) S DR=DR_"63////2;64///@;65///@;" ;W !,ACG2,?20,"63 = 1 BUT 27 & 53 NOT CORRECT CODES."
Q
ACG53 F X=1521,1522,1531,1541,1542,1611,1622,1623,1629,1711,1721,1731,1741,1742,1743,1751,1752,1761,1771,1781,1791,1793,1794,1795,1796,1799 S ACG53(X)=""
Q
ACG27 F X=11:1:19,21:1:24,29,30 S ACG27("C1"_X)=""
F X=11,13:1:16,19 S ACG27("C2"_X)=""
F X="G004","J099","J999","K099","Q201","R404","R406","R497","S205" S ACG27(X)=""
F X=2,4,6,8,9 S ACG27("T00"_X)=""
F X="T014",6505,7045,7110,7510 S ACG27(X)=""
Q
ACGSTEMP ;IHS/OIRM/DSD/THL,AEF - ROUTINE TO CHECK DATA INTEGRITY; [ 03/27/2000 2:22 PM ]
+1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
+2 ;This routine has been renovated for Y2k Compliance ;MLP;01/24/2000
+3 QUIT
EN ;EP;TO BEGIN DATA INTEGRITY CHECK
+1 DO ^XBKVAR
+2 DO ACG53
DO ACG27
+3 SET DA=0
ENX FOR
SET DA=$ORDER(^ACGS(DA))
IF 'DA
QUIT
IF $DATA(^ACGS(DA,0))
IF $DATA(^("DT"))
IF $DATA(^("DT1"))
IF $DATA(^("DT2"))
IF $DATA(^("DT3"))
SET ACG0=^(0)
SET ACGDT=^("DT")
SET ACGDT1=^("DT1")
SET ACGDT2=^("DT2")
SET ACGDT3=^("DT3")
Begin DoDot:1
+1 IF '$PIECE(ACG0,U,3)
QUIT
+2 IF +ACGDT=15!(+ACGDT=17)
QUIT
+3 SET DR=""
SET DIE="^ACGS("
SET ACG12=$PIECE(ACGDT,U,12)
SET ACG2=$PIECE(ACGDT,U,2)
SET ACG13DA=$PIECE(ACGDT,U,13)
SET ACG19DA=$PIECE(ACGDT,U,19)
SET ACG17DA=$PIECE(ACGDT,U,17)
SET ACG30=$PIECE(ACGDT1,U,9)
SET ACG5=$PIECE(ACGDT,U,5)
+4 ;W !,$P(ACGDT,U,2),?10,"ORIGINAL CONTRACT NUMBER CHANGE",?40,DA ;W ?50,DR
IF DA'=$PIECE(ACG0,U,3)
SET ACGCON=$ORDER(^ACGS("B",$EXTRACT($PIECE(ACGDT,U,2),1,9)_"000",0))
IF $PIECE(ACG0,U,3)'=ACGCON
SET DR=DR_".03////"_ACGCON_";"
+5 ;W !?20,"Q ACTIONS"
IF $EXTRACT(ACG2,10)="Q"
SET $EXTRACT(ACG2,10)=9
SET DR="2////"_ACG2_";"
+6 IF ACG13DA
IF $DATA(^AUTTTOB(ACG13DA,0))
SET ACG13=$PIECE(^(0),U)
+7 IF ACG17DA
IF $DATA(^ACGSP(ACG17DA,0))
SET ACG17=$PIECE(^(0),U)
+8 IF ACG19DA
IF $DATA(^ACGEOC(ACG19DA,0))
SET ACG19=$PIECE(^(0),U)
+9 DO 63
+10 ;W !,ACG2,?20,"TOB"
IF DA'=$PIECE(ACG0,U,3)
IF $PIECE(ACG0,U,3)]""
IF $DATA(^ACGS($PIECE(ACG0,U,3),0))
IF $DATA(^("DT"))
SET ACGODT=^("DT")
IF ACG13DA'=$PIECE(ACGODT,U,13)
SET DR=DR_"13////"_$PIECE(ACGODT,U,13)_";"
+11 ;W !,ACG2,?20,"WOB"
IF ACG13DA>3
IF ACG30=1
SET DR=DR_"30////2;"
+12 ;W !,ACG2,?20,"EOC"
IF $EXTRACT(ACG2,4,5)>87
IF ACG12'="A"
IF $PIECE(ACGDT3,U,7)="C"
IF $PIECE(ACGDT,U,18)'=81
SET DR=DR_"18////81;"
+13 ;W !,ACG2,?20,5960
IF ACG13DA=1
IF 5960'[$PIECE(ACGDT,U,19)
SET DR=DR_"19////"_$SELECT($PIECE(ACGDT,U,12)="A":59,1:60)_";"
+14 ;W !,ACG2,?20,"1 OFFER"
IF $EXTRACT(ACG2,4,5)>87
IF $EXTRACT(ACG0)="0"
IF +ACGDT=1!(+ACGDT=2)
IF $PIECE(ACGDT,U,21)<1
SET DR=DR_"21////1;"
+15 ;W !,ACG2,?20,"AGENCY ORDER NUMBER"
IF $EXTRACT($PIECE(ACGDT,U,3),1,2)="3-"
SET DR=DR_"3////"_3_$EXTRACT($PIECE(ACGDT,U,3),3,99)_";"
+16 ;W !,ACG2,?20,"SOLICITATION PROCEDURE MUST = '4J'"
IF $DATA(ACG19)
IF ACG19=59
IF ACG13="A1"
IF ACG17'="4J"
SET DR=DR_"17////10;"
+17 ;W !?20,DR
IF DR]""
IF ACG2]""
DO ^DIE
End DoDot:1
+18 QUIT
63 ;
+1 SET ACG53=$PIECE(ACGDT2,U,18)
SET ACG27=$PIECE(ACGDT1,U,6)
+2 IF ACG53=""
SET ACG53="XXXX"
+3 IF ACG27=""
QUIT
+4 SET ACG27=$SELECT($DATA(^ACGPPC(ACG27,0)):$PIECE(^(0),U),1:"")
+5 IF ACG27=""
QUIT
+6 ;I $P(ACGDT3,U,8)=2,$E($P($G(^ACGS($P(ACG0,U,3),"DT1")),U,2),2,7)>890500,$D(ACG27(ACG27))!$D(ACG53(ACG53)),"A1A2A3B1B2"[ACG13,$P(ACGDT3,U,8)'=1 D
+7 ;.S DR=DR_"63////1;64////2;"_$S($P(ACGDT3,U,11)=""&("A1A2A3"[ACG13):"66////1;",1:"") ;W !,ACG2,?20,ACG13,?30,ACG27,?40,ACG53
+8 ;Y2K;MLP
IF $PIECE(ACGDT3,U,8)=2
IF $EXTRACT($PIECE($GET(^ACGS($PIECE(ACG0,U,3),"DT1")),U,2),1,7)>2890500
IF $DATA(ACG27(ACG27))!$DATA(ACG53(ACG53))
IF "A1A2A3B1B2"[ACG13
IF $PIECE(ACGDT3,U,8)'=1
Begin DoDot:1
+9 ;W !,ACG2,?20,ACG13,?30,ACG27,?40,ACG53 ;Y2K;MLP
SET DR=DR_"63////1;64////2;"_$SELECT($PIECE(ACGDT3,U,11)=""&("A1A2A3"[ACG13):"66////1;",1:"")
End DoDot:1
+10 ;I $P(ACGDT3,U,8)=1,$E($P(^ACGS($P(ACG0,U,3),"DT1"),U,2),2,7)<890501 S DR=DR_"63////2;64///@;65///@;" ;W !,ACG2,?20,"INITIAL AWARD DATE < 890501"
+11 ;W !,ACG2,?20,"INITIAL AWARD DATE < 890501" ;y2k;mlp
IF $PIECE(ACGDT3,U,8)=1
IF $EXTRACT($PIECE(^ACGS($PIECE(ACG0,U,3),"DT1"),U,2),1,7)<2890501
SET DR=DR_"63////2;64///@;65///@;"
+12 ;W !,ACG2,?20,"63 = 1 BUT 27 & 53 NOT CORRECT CODES."
IF $PIECE(ACGDT3,U,8)=1
IF '$DATA(ACG27(ACG27))&'$DATA(ACG53(ACG53))
SET DR=DR_"63////2;64///@;65///@;"
+13 QUIT
ACG53 FOR X=1521,1522,1531,1541,1542,1611,1622,1623,1629,1711,1721,1731,1741,1742,1743,1751,1752,1761,1771,1781,1791,1793,1794,1795,1796,1799
SET ACG53(X)=""
+1 QUIT
ACG27 FOR X=11:1:19,21:1:24,29,30
SET ACG27("C1"_X)=""
+1 FOR X=11,13:1:16,19
SET ACG27("C2"_X)=""
+2 FOR X="G004","J099","J999","K099","Q201","R404","R406","R497","S205"
SET ACG27(X)=""
+3 FOR X=2,4,6,8,9
SET ACG27("T00"_X)=""
+4 FOR X="T014",6505,7045,7110,7510
SET ACG27(X)=""
+5 QUIT
