ACGSUTIL ;IHS/OIRM/DSD/THL,AEF - UTILITY PROGRAMS TO CHECK DATABASE INTEGRITY; [ 03/27/2000 2:22 PM ]
;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
;;UTILITY PROGRAMS TO CHECK DATABASE INTEGRITY
Q
RQD ;EP;CHECKS ALL CIS ENTRIES FOR DATA IN REQUIRED FIELDS
S ACGRDA=0 F S ACGRDA=$O(^ACGS(ACGRDA)) Q:'ACGRDA S ACGCNO=$P(^ACGS(ACGRDA,0),U,3) I ACGRDA'=ACGCNO S ACG1=$P(^ACGTPA($P(^("DT"),U),0),U) D @ACG1^ACGSRQD
K ACGRDA,ACG1
Q
PP ;EP;CHECKS THE PLACE OF PERFORMANCE FOR CONSISTENCY WITH RQD FORMAT
N ACGRDA,ACG,ACG28DA
S ACGRDA=0
F S ACGRDA=$O(^ACGS(ACGRDA)) Q:'ACGRDA D
.S ACG=$P(^ACGS(ACGRDA,"DT1"),U,7)
.I ACG'="" D
..I $E(ACG)?1N S ACG=$P(ACG,+ACG,2)
..I ACG'="" D
...S ACG28DA=$O(^AUTTGL("B",ACG,""))
...I 'ACG28DA D SET
...I ACG28DA,ACG28DA'=$P(^ACGS(ACGRDA,10),U,2) S $P(^(10),U,2)=ACG28DA
S DIK="^ACGS("
F DIK(1)="1028^1","1005" D ENALL^DIK
K DIK
Q
VENDOR ;EP;UPDATES THE VENDOR/CONTRACTOR GEOGRAPHICAL LOCATION XREF'S
S DIK="^AUTTVNDR(",DIK(1)="1125"
D ENALL^DIK
K DIK
Q
SET ;CREATES NEW GEOGRAPHICAL LOCATION IF NO MATCH EXISTS
S X=ACG,DIC="^AUTTGL(",DIC(0)="L"
D FILE^ACGSDIC
K DIC
S (ACG28DA,$P(^ACGS(ACGRDA,10),U,2))=+Y
Q
CLEAN ;EP;CLEANS DANGLING XREF'S
N ACG,ACG1,ACG2,X
;F X=66:1:82 S ACG=$C(X),ACG1="" W:IOST["C-" "." F S ACG1=$O(^ACGS(ACG,ACG1)) Q:ACG1="" S ACG2=0 F S ACG2=$O(^ACGS(ACG,ACG1,ACG2)) Q:'ACG2 I '$D(^ACGS(ACG2,0)) K ^ACGS(ACG,ACG1,ACG2),^ACGS(ACG2)
F ACG=66:1:82 S ACGX=$C(ACG) W:IOST["C-" !,ACGX," Cross Reference being checked." K ^ACGS(ACGX)
F ACG=1,2,4,5,10,11,15,16,19,24,30,103,121,1099 W !,"Re-indexing field ",ACG S DIK="^ACGS(",DIK(1)=ACG_"^1" S:ACG=19 DIK(1)="19^2" D ENALL^DIK
Q
XREF ;EP;RE-INDEX SELECTED XREF'S
N ACG,ACG1,ACG2,X
F X=66:1:82 S ACG=$C(X),ACG1="" W:IOST["C-" "." K ^ACGS(ACG)
S DIK="^ACGS(",DIK(1)=""
D IX1^DIK
Q
ORIG ;EP;SETS MISSING REQUIRED DATA IN MODIFICATIONS FROM ORIGINAL ACTION
S X=0,U="^"
F S X=$O(^ACGS("C",X)) Q:'X D
.F ACG=12:1:20 S @("ACG"_ACG)=$P(^ACGS(X,"DT"),U,ACG)
.F ACG=22,27,28 S @("ACG"_ACG)=$P(^ACGS(X,"DT1"),U,(ACG-21))
.S ACG53=$P(^ACGS(X,"DT2"),U,18)
.S Y=0 F S Y=$O(^ACGS("C",X,Y)) Q:'Y D:X'=Y
..F ACG=12:1:20 S:$P(^ACGS(Y,"DT"),U,ACG)=""&(@("ACG"_ACG)'="") $P(^("DT"),U,ACG)=@("ACG"_ACG)
..F ACG=22,27,28 S:$P(^ACGS(Y,"DT1"),U,(ACG-21))=""&(@("ACG"_ACG)'="") $P(^("DT1"),U,(ACG-21))=@("ACG"_ACG)
..S:$P(^ACGS(Y,"DT2"),U,18)=""&(ACG53'="") $P(^("DT2"),U,18)=ACG53
Q
;
ACGSUTIL ;IHS/OIRM/DSD/THL,AEF - UTILITY PROGRAMS TO CHECK DATABASE INTEGRITY; [ 03/27/2000 2:22 PM ]
+1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
+2 ;;UTILITY PROGRAMS TO CHECK DATABASE INTEGRITY
+3 QUIT
RQD ;EP;CHECKS ALL CIS ENTRIES FOR DATA IN REQUIRED FIELDS
+1 SET ACGRDA=0
FOR
SET ACGRDA=$ORDER(^ACGS(ACGRDA))
IF 'ACGRDA
QUIT
SET ACGCNO=$PIECE(^ACGS(ACGRDA,0),U,3)
IF ACGRDA'=ACGCNO
SET ACG1=$PIECE(^ACGTPA($PIECE(^("DT"),U),0),U)
DO @ACG1^ACGSRQD
+2 KILL ACGRDA,ACG1
+3 QUIT
PP ;EP;CHECKS THE PLACE OF PERFORMANCE FOR CONSISTENCY WITH RQD FORMAT
+1 NEW ACGRDA,ACG,ACG28DA
+2 SET ACGRDA=0
+3 FOR
SET ACGRDA=$ORDER(^ACGS(ACGRDA))
IF 'ACGRDA
QUIT
Begin DoDot:1
+4 SET ACG=$PIECE(^ACGS(ACGRDA,"DT1"),U,7)
+5 IF ACG'=""
Begin DoDot:2
+6 IF $EXTRACT(ACG)?1N
SET ACG=$PIECE(ACG,+ACG,2)
+7 IF ACG'=""
Begin DoDot:3
+8 SET ACG28DA=$ORDER(^AUTTGL("B",ACG,""))
+9 IF 'ACG28DA
DO SET
+10 IF ACG28DA
IF ACG28DA'=$PIECE(^ACGS(ACGRDA,10),U,2)
SET $PIECE(^(10),U,2)=ACG28DA
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET DIK="^ACGS("
+12 FOR DIK(1)="1028^1","1005"
DO ENALL^DIK
+13 KILL DIK
+14 QUIT
VENDOR ;EP;UPDATES THE VENDOR/CONTRACTOR GEOGRAPHICAL LOCATION XREF'S
+1 SET DIK="^AUTTVNDR("
SET DIK(1)="1125"
+2 DO ENALL^DIK
+3 KILL DIK
+4 QUIT
SET ;CREATES NEW GEOGRAPHICAL LOCATION IF NO MATCH EXISTS
+1 SET X=ACG
SET DIC="^AUTTGL("
SET DIC(0)="L"
+2 DO FILE^ACGSDIC
+3 KILL DIC
+4 SET (ACG28DA,$PIECE(^ACGS(ACGRDA,10),U,2))=+Y
+5 QUIT
CLEAN ;EP;CLEANS DANGLING XREF'S
+1 NEW ACG,ACG1,ACG2,X
+2 ;F X=66:1:82 S ACG=$C(X),ACG1="" W:IOST["C-" "." F S ACG1=$O(^ACGS(ACG,ACG1)) Q:ACG1="" S ACG2=0 F S ACG2=$O(^ACGS(ACG,ACG1,ACG2)) Q:'ACG2 I '$D(^ACGS(ACG2,0)) K ^ACGS(ACG,ACG1,ACG2),^ACGS(ACG2)
+3 FOR ACG=66:1:82
SET ACGX=$CHAR(ACG)
IF IOST["C-"
WRITE !,ACGX," Cross Reference being checked."
KILL ^ACGS(ACGX)
+4 FOR ACG=1,2,4,5,10,11,15,16,19,24,30,103,121,1099
WRITE !,"Re-indexing field ",ACG
SET DIK="^ACGS("
SET DIK(1)=ACG_"^1"
IF ACG=19
SET DIK(1)="19^2"
DO ENALL^DIK
+5 QUIT
XREF ;EP;RE-INDEX SELECTED XREF'S
+1 NEW ACG,ACG1,ACG2,X
+2 FOR X=66:1:82
SET ACG=$CHAR(X)
SET ACG1=""
IF IOST["C-"
WRITE "."
KILL ^ACGS(ACG)
+3 SET DIK="^ACGS("
SET DIK(1)=""
+4 DO IX1^DIK
+5 QUIT
ORIG ;EP;SETS MISSING REQUIRED DATA IN MODIFICATIONS FROM ORIGINAL ACTION
+1 SET X=0
SET U="^"
+2 FOR
SET X=$ORDER(^ACGS("C",X))
IF 'X
QUIT
Begin DoDot:1
+3 FOR ACG=12:1:20
SET @("ACG"_ACG)=$PIECE(^ACGS(X,"DT"),U,ACG)
+4 FOR ACG=22,27,28
SET @("ACG"_ACG)=$PIECE(^ACGS(X,"DT1"),U,(ACG-21))
+5 SET ACG53=$PIECE(^ACGS(X,"DT2"),U,18)
+6 SET Y=0
FOR
SET Y=$ORDER(^ACGS("C",X,Y))
IF 'Y
QUIT
IF X'=Y
Begin DoDot:2
+7 FOR ACG=12:1:20
IF $PIECE(^ACGS(Y,"DT"),U,ACG)=""&(@("ACG"_ACG)'="")
SET $PIECE(^("DT"),U,ACG)=@("ACG"_ACG)
+8 FOR ACG=22,27,28
IF $PIECE(^ACGS(Y,"DT1"),U,(ACG-21))=""&(@("ACG"_ACG)'="")
SET $PIECE(^("DT1"),U,(ACG-21))=@("ACG"_ACG)
+9 IF $PIECE(^ACGS(Y,"DT2"),U,18)=""&(ACG53'="")
SET $PIECE(^("DT2"),U,18)=ACG53
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
