- 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