- 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 ;
