Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACGSTEMP

ACGSTEMP.m

Go to the documentation of this file.
  1. 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
  1. ;This routine has been renovated for Y2k Compliance ;MLP;01/24/2000
  1. Q
  1. EN ;EP;TO BEGIN DATA INTEGRITY CHECK
  1. D ^XBKVAR
  1. D ACG53,ACG27
  1. S DA=0
  1. 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
  1. .Q:'$P(ACG0,U,3)
  1. .Q:+ACGDT=15!(+ACGDT=17)
  1. .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)
  1. .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
  1. .I $E(ACG2,10)="Q" S $E(ACG2,10)=9,DR="2////"_ACG2_";" ;W !?20,"Q ACTIONS"
  1. .I ACG13DA,$D(^AUTTTOB(ACG13DA,0)) S ACG13=$P(^(0),U)
  1. .I ACG17DA,$D(^ACGSP(ACG17DA,0)) S ACG17=$P(^(0),U)
  1. .I ACG19DA,$D(^ACGEOC(ACG19DA,0)) S ACG19=$P(^(0),U)
  1. .D 63
  1. .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"
  1. .I ACG13DA>3,ACG30=1 S DR=DR_"30////2;" ;W !,ACG2,?20,"WOB"
  1. .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"
  1. .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
  1. .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"
  1. .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"
  1. .I $D(ACG19),ACG19=59,ACG13="A1",ACG17'="4J" S DR=DR_"17////10;" ;W !,ACG2,?20,"SOLICITATION PROCEDURE MUST = '4J'"
  1. .I DR]"",ACG2]"" D ^DIE ;W !?20,DR
  1. Q
  1. 63 ;
  1. S ACG53=$P(ACGDT2,U,18),ACG27=$P(ACGDT1,U,6)
  1. S:ACG53="" ACG53="XXXX"
  1. Q:ACG27=""
  1. S ACG27=$S($D(^ACGPPC(ACG27,0)):$P(^(0),U),1:"")
  1. Q:ACG27=""
  1. ;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
  1. ;.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
  1. 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
  1. .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
  1. ;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"
  1. 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
  1. 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."
  1. Q
  1. 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)=""
  1. Q
  1. ACG27 F X=11:1:19,21:1:24,29,30 S ACG27("C1"_X)=""
  1. F X=11,13:1:16,19 S ACG27("C2"_X)=""
  1. F X="G004","J099","J999","K099","Q201","R404","R406","R497","S205" S ACG27(X)=""
  1. F X=2,4,6,8,9 S ACG27("T00"_X)=""
  1. F X="T014",6505,7045,7110,7510 S ACG27(X)=""
  1. Q