AVAPCHK ;IHS/ORDC/LJF - CLEAN UP FILES 3,6,16&200 ; [ 10/03/95 7:57 AM ]
;;93.2;VA SUPPORT FILES;;SEPT 18, 1995;Build 12
;
;This routine checks the status of your User, Person, Provider, and
;New Person files. It attempts to correct links, if possible. Those
;links this routine cannot fix are listed in the ^AVA global.
;
;To Area Offices: Please run this on each machine with these 4 files.
; 1. Run ^XBCOUNT on files 3, 6, 16, and 200.
; 2. Make sure the 3rd piece of the zero nodes of ^DIC(3
; and ^VA(200 are the same. If not, set them to the larger
; number.
; 3. Run EN^AVAPCHK. There is no user interface. Then run
; RESULTS^AVAPCHK which displays to the screen the results.
; 4. If it did not run clean, call me at (999) 999-9999. I will
; need to hand fix those errors.
;
;To Developers: Use this routine to check the status of the 4 files
; before running your New Person conversions. To do so, call
; EN^AVAPCHK then check for the existence of ^AVA("OK"). Abort the
; conversion if it does not exist.
;
Q ;no direct entry to rtn
;
EN ;EP; called by A9AVA8
D DT^DICRW
K ^AVA(3),^AVA(16),^AVA("OK"),^AVA("NOT OK")
S X="AVAP7" X ^%ZOSF("TEST")
I '$T S ^AVA("NOT OK")="NEED AVA PATCH 7" Q
I $P($G(^DD(200,53.5,1,1,0)),U,2)'="AIHS" S ^AVA("NOT OK")="AVA PATCH 7 NOT INSTALLED" Q
D LOOP3,LOOP16,EXIT Q
;
;
LOOP200 ; loop thru new person for missing zero nodes
S X=0 F S X=$O(^VA(200,X)) Q:'X I '$D(^VA(200,X,0)) W !,X
Q
;
LOOP3 ; loop thru user file
K AVA3,AVAPER
S AVA3=0
F S AVA3=$O(^DIC(3,AVA3)) Q:AVA3'=+AVA3 D
. I '$D(^DIC(3,AVA3,0)) D ERR1
. I '$D(^VA(200,AVA3,0)) D ERR2
. S AVAPER=$P(^DIC(3,AVA3,0),U,16) I AVAPER="" D ERR3 Q:AVAPER=""
. I '$D(^DIC(16,AVAPER,0)) D ERR4
. I $G(^DIC(16,AVAPER,"A3"))="" D ERR5
. I $G(^DIC(16,AVAPER,"A3"))'=AVA3 D ERR6
Q
;
;
LOOP16 ; loop thru person files
K AVA3,AVA16
S AVA16=0
F S AVA16=$O(^DIC(16,AVA16)) Q:AVA16'=+AVA16 D
. I '$D(^DIC(16,AVA16,0)) D ERR7
. S AVA3=$G(^DIC(16,AVA16,"A3")) I AVA3="" D ERR8 Q:AVA3=""
. I '$D(^DIC(3,AVA3,0)) D ERR9 Q
. I $P(^DIC(3,AVA3,0),U,16)="" D ERR10
. I $P(^DIC(3,AVA3,0),U,16)'=AVA16 D ERR11
. ;
. I '$D(^DIC(6,AVA16,0)),$P($G(^DIC(6,AVA16,9999999)),U,9)]"" D ERR12
. I $P($G(^DIC(6,AVA16,0)),U,4)]"",$P($G(^VA(200,AVA3,"PS")),U,5)="" D ERR13
Q
;
EXIT ;
I '$D(^AVA(3)),'$D(^AVA(16)) S ^AVA("OK")=$H
K AVA3,AVAPER,AVA16,DIE,DA,DR,DIC Q
;
;
ERR1 ;1=USER ENTRY MISSING 0 NODE
NEW X
I '$D(^VA(200,AVA3,0)) D SETERR(3,AVA3,"NO ZERO NODE FOR USER AND NO CORRESPONDING FILE 200 ENTRY") Q
I $D(^VA(200,AVA3,0)) D Q
. S ^DIC(3,AVA3,0)=$P(^VA(200,AVA3,0),U,1,2)
. S $P(^DIC(3,AVA3,0),U,16)=$P(^VA(200,AVA3,0),U,16)
. S X=$P(^DIC(3,AVA3,0),U) I X]"" D
.. S ^DIC(3,"B",X,AVA3)=""
. S X=$P(^DIC(3,AVA3,0),U,2) I X]"" D
.. S ^DIC(3,"C",X,AVA3)=""
Q
;
ERR2 ;2=USER ENTRY NOT HAVE MATCHING VA(200 ENTRY
I $P(^DIC(3,AVA3,0),U)="" D ERR1 Q
S DIC="^VA(200,",DLAYGO=200,DINUM=AVA3,X=$P(^DIC(3,AVA3,0),U)
S DIC(0)="L",DIC("DR")=".02///"_$P(^DIC(3,AVA3,0),U,2)
K DD,DO D FILE^DICN
I '$D(^VA(200,AVA3,0)) D SETERR(3,AVA3,"NO COORESPONDING FILE 200 ENTRY FOR THIS USER")
Q
;
ERR3 ;3=USER ENTRY HAS NO 16TH PIECE
I $P($G(^VA(200,AVA3,0)),U,16)]"" D Q
. S AVAPER=$P(^VA(200,AVA3,0),U,16)
. S $P(^DIC(3,AVA3,0),U,16)=AVAPER
;D SETERR(3,AVA3,"NO USER OR FILE 200 LINK TO PERSON FILE")
Q
;
ERR4 ;4=USER ENTRY 16TH PIECE POINTS TO NON-EXISTING PERSON ENTRY
I $D(^DIC(16,+$P(^VA(200,AVA3,0),U,16),0)) D Q
. S $P(^DIC(3,AVA3,0),U,16)=$P(^VA(200,AVA3,0),U,16)
;
S $P(^DIC(3,AVA3,0),U,16)=""
S DIE=3,DA=AVA3,DR=".01///"_$P(^DIC(3,AVA3,0),U) D ^DIE
S DIE=200,DA=AVA3,DR="8980.16////"_$P(^DIC(3,AVA3,0),U,16) D ^DIE
I '$D(^DIC(16,$P(^DIC(3,AVA3,0),U,16),0)) D SETERR(3,AVA3,"NO PERSON MATCHED TO USER ENTRY")
Q
;
ERR5 ;5=USER ENTRY POINTS TO PERSON WITH NO A3 NODE
S ^DIC(16,AVAPER,"A3")=AVA3
Q
;
ERR6 ;6=USER ENTRY POINTS TO PERSON ENTRY WITH MISS-MATCHED A3 NODE
D SETERR(3,AVA3,"MISMATCHED 'A3' NODE & USER LINK; PERSON #"_AVAPER)
Q
;
ERR7 ;7=PERSON ENTRY HAS NO ZERO NODE
NEW X
S X=$G(^DIC(16,AVA16,"A3"))
I X]"",$P($G(^VA(200,X,0)),U)]"" D Q
. S $P(^DIC(16,AVA16,0),U)=$P(^VA(200,X,0),U)
. S ^DIC(16,"B",$P(^VA(200,X,0),U),AVA16)=""
D SETERR(16,AVA16,"NO ZERO NODE FOR PERSON")
Q
;
ERR8 ;8=PERSON ENTRY HAS NULL A3 NODE
NEW X
S X=$P(^DIC(16,AVA16,0),U,9)
I X]"" S Y=$O(^VA(200,"SSN",X,0)) I Y]"" S (^DIC(16,AVA16,"A3"),AVA3)=Y
I $G(^DIC(16,AVA16,"A3"))="" D SETERR(16,AVA16,"NULL OR NON-EXISTING A3 NODE")
Q
;
ERR9 ;9=PERSON ENTRY A3 NODE POINTS TO NON-EXISITING USER ENTRY
I $D(^VA(200,AVA3,0)) D Q
. D ERR1
. S $P(^DIC(3,AVA3,0),U,16)=AVA16,$P(^VA(200,AVA3,0),U,16)=AVA16
D SETERR(16,AVA16,"A3 POINTS TO NON-EXISTING USER ENTRY")
Q
;
ERR10 ;10=PERSON ENTRY A3 NODE POINTS TO USER ENTRY WITH NULL 16TH PIECE
I $P($G(^VA(200,AVA3,0)),U,16)'=AVA16 D SETERR(16,AVA16,"A3 POINTER NOT MATCHING FILE 200 OR 3") Q
S $P(^DIC(3,AVA3,0),U,16)=AVA16
S $P(^VA(200,AVA3,0),U,16)=AVA16
Q
;
ERR11 ;11=PERSON ENTRY A3 NODE POINTS TO USER ENTRY WITH MISMATCHED 16TH
NEW X
S X=$P(^DIC(3,AVA3,0),U,16)
I X,$G(^DIC(16,+X,"A3"))=AVA3 Q
D SETERR(16,AVA16,"A3 NODE POINTS TO MISMATCHED USER ENTRY")
Q
;
ERR12 ;12=PROVIDER ENTRY HAS NO ZERO NODE BUT HAS 99999999 NODE
K ^DIC(6,"GIHS",$P(^DIC(6,AVA16,9999999),U,9),AVA16)
K ^DIC(6,AVA16)
S AVA200=$P($G(^DIC(16,AVA16,"A3")),U) ;ifn in file 200
S AVACLS=$P($G(^VA(200,AVA200,"PS")),U,5) Q:AVACLS=""
;
S DIE="^VA(200,",DA=AVA200,DR="53.5///@" D ^DIE
S DR="53.5////"_AVACLS D ^DIE
I '$D(^DIC(6,AVA16,0)) D SETERR(16,AVA16,"NO PROVIDER ZERO NODE")
Q
;
ERR13 ;13=IF PROVIDER HAS PROVIDER CLASS BUT FILE 200 DOESN'T: FIX IT
S DIE="^VA(200,",DA=AVA3,DR="53.5////"_$P(^DIC(6,AVA16,0),U,4) D ^DIE
I $P(^VA(200,AVA3,"PS"),U,5)="" D SETERR(16,AVA16,"NO CLASS IN FILE 200")
Q
;
;
SETERR(FILE,IEN,MSG) ; -- SUBRTN to set entry into error file
I FILE=3 S ^AVA(3,IEN)=MSG Q
S ^AVA(16,IEN)=MSG Q
;
RESULTS ;EP; called to display results of run
D DT^DICRW,^XBCLS
W !!,"RESULTS OF AVA CHECK OF FILES 3, 6, 16, & 200",!
;
I $D(^AVA("OK")) D Q
. W !!,"ALL FILES OKAY! READY FOR CONVERSION."
. S %H=^AVA("OK") D YX^%DTC W !,"Check completed at ",Y D READ
;
I $D(^AVA("NOT OK")) D Q
. W !!,"FILE CHECK NOT RUN! ",^AVA("NOT OK") D READ
;
F AVAF=3,16 D
. I $O(^AVA(AVAF,0)) W !!,"ERRORS FROM FILE ",AVAF
. S AVAX=0 F S AVAX=$O(^AVA(AVAF,AVAX)) Q:'AVAX D
.. W !,"Entry #",AVAX,?15,^AVA(AVAF,AVAX)
.. I $Y>20 D READ,^XBCLS
;
K DIR,AVAF,AVAX Q
;
READ ;
K DIR S DIR(0)="E",DIR("A")="Press ENTER to continue" D ^DIR Q
;
ADD1(AVAX) ;EP; called to add new person & user entries for person entry
NEW AVA3,X
S AVA3=$P(^VA(200,0),U,3)+1
Q:$D(^VA(200,AVA3)) Q:$D(^DIC(3,AVA3))
S $P(^VA(200,0),U,3)=AVA3,$P(^DIC(3,0),U,3)=AVA3
;
S ^VA(200,AVA3,0)=$P(^DIC(16,AVAX,0),U) ;name
S ^VA(200,"B",$P(^VA(200,AVA3,0),U),AVA3)="" ;name xref
S $P(^VA(200,AVA3,0),U,16)=AVAX ;person pointer
S X=$P(^DIC(16,AVAX,0),U,9) I X]"" D
. S $P(^VA(200,AVA3,1),U,9)=X
. S ^VA(200,"SSN",X,AVA3)=""
;
S ^DIC(3,AVA3,0)=$P(^DIC(16,AVAX,0),U)
S ^DIC(3,"B",$P(^DIC(3,AVA3,0),U),AVA3)=""
S $P(^DIC(3,AVA3,0),U,16)=AVAX
;
S ^DIC(16,AVAX,"A3")=AVA3
Q
AVAPCHK ;IHS/ORDC/LJF - CLEAN UP FILES 3,6,16&200 ; [ 10/03/95 7:57 AM ]
+1 ;;93.2;VA SUPPORT FILES;;SEPT 18, 1995;Build 12
+2 ;
+3 ;This routine checks the status of your User, Person, Provider, and
+4 ;New Person files. It attempts to correct links, if possible. Those
+5 ;links this routine cannot fix are listed in the ^AVA global.
+6 ;
+7 ;To Area Offices: Please run this on each machine with these 4 files.
+8 ; 1. Run ^XBCOUNT on files 3, 6, 16, and 200.
+9 ; 2. Make sure the 3rd piece of the zero nodes of ^DIC(3
+10 ; and ^VA(200 are the same. If not, set them to the larger
+11 ; number.
+12 ; 3. Run EN^AVAPCHK. There is no user interface. Then run
+13 ; RESULTS^AVAPCHK which displays to the screen the results.
+14 ; 4. If it did not run clean, call me at (999) 999-9999. I will
+15 ; need to hand fix those errors.
+16 ;
+17 ;To Developers: Use this routine to check the status of the 4 files
+18 ; before running your New Person conversions. To do so, call
+19 ; EN^AVAPCHK then check for the existence of ^AVA("OK"). Abort the
+20 ; conversion if it does not exist.
+21 ;
+22 ;no direct entry to rtn
QUIT
+23 ;
EN ;EP; called by A9AVA8
+1 DO DT^DICRW
+2 KILL ^AVA(3),^AVA(16),^AVA("OK"),^AVA("NOT OK")
+3 SET X="AVAP7"
XECUTE ^%ZOSF("TEST")
+4 IF '$TEST
SET ^AVA("NOT OK")="NEED AVA PATCH 7"
QUIT
+5 IF $PIECE($GET(^DD(200,53.5,1,1,0)),U,2)'="AIHS"
SET ^AVA("NOT OK")="AVA PATCH 7 NOT INSTALLED"
QUIT
+6 DO LOOP3
DO LOOP16
DO EXIT
QUIT
+7 ;
+8 ;
LOOP200 ; loop thru new person for missing zero nodes
+1 SET X=0
FOR
SET X=$ORDER(^VA(200,X))
IF 'X
QUIT
IF '$DATA(^VA(200,X,0))
WRITE !,X
+2 QUIT
+3 ;
LOOP3 ; loop thru user file
+1 KILL AVA3,AVAPER
+2 SET AVA3=0
+3 FOR
SET AVA3=$ORDER(^DIC(3,AVA3))
IF AVA3'=+AVA3
QUIT
Begin DoDot:1
+4 IF '$DATA(^DIC(3,AVA3,0))
DO ERR1
+5 IF '$DATA(^VA(200,AVA3,0))
DO ERR2
+6 SET AVAPER=$PIECE(^DIC(3,AVA3,0),U,16)
IF AVAPER=""
DO ERR3
IF AVAPER=""
QUIT
+7 IF '$DATA(^DIC(16,AVAPER,0))
DO ERR4
+8 IF $GET(^DIC(16,AVAPER,"A3"))=""
DO ERR5
+9 IF $GET(^DIC(16,AVAPER,"A3"))'=AVA3
DO ERR6
End DoDot:1
+10 QUIT
+11 ;
+12 ;
LOOP16 ; loop thru person files
+1 KILL AVA3,AVA16
+2 SET AVA16=0
+3 FOR
SET AVA16=$ORDER(^DIC(16,AVA16))
IF AVA16'=+AVA16
QUIT
Begin DoDot:1
+4 IF '$DATA(^DIC(16,AVA16,0))
DO ERR7
+5 SET AVA3=$GET(^DIC(16,AVA16,"A3"))
IF AVA3=""
DO ERR8
IF AVA3=""
QUIT
+6 IF '$DATA(^DIC(3,AVA3,0))
DO ERR9
QUIT
+7 IF $PIECE(^DIC(3,AVA3,0),U,16)=""
DO ERR10
+8 IF $PIECE(^DIC(3,AVA3,0),U,16)'=AVA16
DO ERR11
+9 ;
+10 IF '$DATA(^DIC(6,AVA16,0))
IF $PIECE($GET(^DIC(6,AVA16,9999999)),U,9)]""
DO ERR12
+11 IF $PIECE($GET(^DIC(6,AVA16,0)),U,4)]""
IF $PIECE($GET(^VA(200,AVA3,"PS")),U,5)=""
DO ERR13
End DoDot:1
+12 QUIT
+13 ;
EXIT ;
+1 IF '$DATA(^AVA(3))
IF '$DATA(^AVA(16))
SET ^AVA("OK")=$HOROLOG
+2 KILL AVA3,AVAPER,AVA16,DIE,DA,DR,DIC
QUIT
+3 ;
+4 ;
ERR1 ;1=USER ENTRY MISSING 0 NODE
+1 NEW X
+2 IF '$DATA(^VA(200,AVA3,0))
DO SETERR(3,AVA3,"NO ZERO NODE FOR USER AND NO CORRESPONDING FILE 200 ENTRY")
QUIT
+3 IF $DATA(^VA(200,AVA3,0))
Begin DoDot:1
+4 SET ^DIC(3,AVA3,0)=$PIECE(^VA(200,AVA3,0),U,1,2)
+5 SET $PIECE(^DIC(3,AVA3,0),U,16)=$PIECE(^VA(200,AVA3,0),U,16)
+6 SET X=$PIECE(^DIC(3,AVA3,0),U)
IF X]""
Begin DoDot:2
+7 SET ^DIC(3,"B",X,AVA3)=""
End DoDot:2
+8 SET X=$PIECE(^DIC(3,AVA3,0),U,2)
IF X]""
Begin DoDot:2
+9 SET ^DIC(3,"C",X,AVA3)=""
End DoDot:2
End DoDot:1
QUIT
+10 QUIT
+11 ;
ERR2 ;2=USER ENTRY NOT HAVE MATCHING VA(200 ENTRY
+1 IF $PIECE(^DIC(3,AVA3,0),U)=""
DO ERR1
QUIT
+2 SET DIC="^VA(200,"
SET DLAYGO=200
SET DINUM=AVA3
SET X=$PIECE(^DIC(3,AVA3,0),U)
+3 SET DIC(0)="L"
SET DIC("DR")=".02///"_$PIECE(^DIC(3,AVA3,0),U,2)
+4 KILL DD,DO
DO FILE^DICN
+5 IF '$DATA(^VA(200,AVA3,0))
DO SETERR(3,AVA3,"NO COORESPONDING FILE 200 ENTRY FOR THIS USER")
+6 QUIT
+7 ;
ERR3 ;3=USER ENTRY HAS NO 16TH PIECE
+1 IF $PIECE($GET(^VA(200,AVA3,0)),U,16)]""
Begin DoDot:1
+2 SET AVAPER=$PIECE(^VA(200,AVA3,0),U,16)
+3 SET $PIECE(^DIC(3,AVA3,0),U,16)=AVAPER
End DoDot:1
QUIT
+4 ;D SETERR(3,AVA3,"NO USER OR FILE 200 LINK TO PERSON FILE")
+5 QUIT
+6 ;
ERR4 ;4=USER ENTRY 16TH PIECE POINTS TO NON-EXISTING PERSON ENTRY
+1 IF $DATA(^DIC(16,+$PIECE(^VA(200,AVA3,0),U,16),0))
Begin DoDot:1
+2 SET $PIECE(^DIC(3,AVA3,0),U,16)=$PIECE(^VA(200,AVA3,0),U,16)
End DoDot:1
QUIT
+3 ;
+4 SET $PIECE(^DIC(3,AVA3,0),U,16)=""
+5 SET DIE=3
SET DA=AVA3
SET DR=".01///"_$PIECE(^DIC(3,AVA3,0),U)
DO ^DIE
+6 SET DIE=200
SET DA=AVA3
SET DR="8980.16////"_$PIECE(^DIC(3,AVA3,0),U,16)
DO ^DIE
+7 IF '$DATA(^DIC(16,$PIECE(^DIC(3,AVA3,0),U,16),0))
DO SETERR(3,AVA3,"NO PERSON MATCHED TO USER ENTRY")
+8 QUIT
+9 ;
ERR5 ;5=USER ENTRY POINTS TO PERSON WITH NO A3 NODE
+1 SET ^DIC(16,AVAPER,"A3")=AVA3
+2 QUIT
+3 ;
ERR6 ;6=USER ENTRY POINTS TO PERSON ENTRY WITH MISS-MATCHED A3 NODE
+1 DO SETERR(3,AVA3,"MISMATCHED 'A3' NODE & USER LINK; PERSON #"_AVAPER)
+2 QUIT
+3 ;
ERR7 ;7=PERSON ENTRY HAS NO ZERO NODE
+1 NEW X
+2 SET X=$GET(^DIC(16,AVA16,"A3"))
+3 IF X]""
IF $PIECE($GET(^VA(200,X,0)),U)]""
Begin DoDot:1
+4 SET $PIECE(^DIC(16,AVA16,0),U)=$PIECE(^VA(200,X,0),U)
+5 SET ^DIC(16,"B",$PIECE(^VA(200,X,0),U),AVA16)=""
End DoDot:1
QUIT
+6 DO SETERR(16,AVA16,"NO ZERO NODE FOR PERSON")
+7 QUIT
+8 ;
ERR8 ;8=PERSON ENTRY HAS NULL A3 NODE
+1 NEW X
+2 SET X=$PIECE(^DIC(16,AVA16,0),U,9)
+3 IF X]""
SET Y=$ORDER(^VA(200,"SSN",X,0))
IF Y]""
SET (^DIC(16,AVA16,"A3"),AVA3)=Y
+4 IF $GET(^DIC(16,AVA16,"A3"))=""
DO SETERR(16,AVA16,"NULL OR NON-EXISTING A3 NODE")
+5 QUIT
+6 ;
ERR9 ;9=PERSON ENTRY A3 NODE POINTS TO NON-EXISITING USER ENTRY
+1 IF $DATA(^VA(200,AVA3,0))
Begin DoDot:1
+2 DO ERR1
+3 SET $PIECE(^DIC(3,AVA3,0),U,16)=AVA16
SET $PIECE(^VA(200,AVA3,0),U,16)=AVA16
End DoDot:1
QUIT
+4 DO SETERR(16,AVA16,"A3 POINTS TO NON-EXISTING USER ENTRY")
+5 QUIT
+6 ;
ERR10 ;10=PERSON ENTRY A3 NODE POINTS TO USER ENTRY WITH NULL 16TH PIECE
+1 IF $PIECE($GET(^VA(200,AVA3,0)),U,16)'=AVA16
DO SETERR(16,AVA16,"A3 POINTER NOT MATCHING FILE 200 OR 3")
QUIT
+2 SET $PIECE(^DIC(3,AVA3,0),U,16)=AVA16
+3 SET $PIECE(^VA(200,AVA3,0),U,16)=AVA16
+4 QUIT
+5 ;
ERR11 ;11=PERSON ENTRY A3 NODE POINTS TO USER ENTRY WITH MISMATCHED 16TH
+1 NEW X
+2 SET X=$PIECE(^DIC(3,AVA3,0),U,16)
+3 IF X
IF $GET(^DIC(16,+X,"A3"))=AVA3
QUIT
+4 DO SETERR(16,AVA16,"A3 NODE POINTS TO MISMATCHED USER ENTRY")
+5 QUIT
+6 ;
ERR12 ;12=PROVIDER ENTRY HAS NO ZERO NODE BUT HAS 99999999 NODE
+1 KILL ^DIC(6,"GIHS",$PIECE(^DIC(6,AVA16,9999999),U,9),AVA16)
+2 KILL ^DIC(6,AVA16)
+3 ;ifn in file 200
SET AVA200=$PIECE($GET(^DIC(16,AVA16,"A3")),U)
+4 SET AVACLS=$PIECE($GET(^VA(200,AVA200,"PS")),U,5)
IF AVACLS=""
QUIT
+5 ;
+6 SET DIE="^VA(200,"
SET DA=AVA200
SET DR="53.5///@"
DO ^DIE
+7 SET DR="53.5////"_AVACLS
DO ^DIE
+8 IF '$DATA(^DIC(6,AVA16,0))
DO SETERR(16,AVA16,"NO PROVIDER ZERO NODE")
+9 QUIT
+10 ;
ERR13 ;13=IF PROVIDER HAS PROVIDER CLASS BUT FILE 200 DOESN'T: FIX IT
+1 SET DIE="^VA(200,"
SET DA=AVA3
SET DR="53.5////"_$PIECE(^DIC(6,AVA16,0),U,4)
DO ^DIE
+2 IF $PIECE(^VA(200,AVA3,"PS"),U,5)=""
DO SETERR(16,AVA16,"NO CLASS IN FILE 200")
+3 QUIT
+4 ;
+5 ;
SETERR(FILE,IEN,MSG) ; -- SUBRTN to set entry into error file
+1 IF FILE=3
SET ^AVA(3,IEN)=MSG
QUIT
+2 SET ^AVA(16,IEN)=MSG
QUIT
+3 ;
RESULTS ;EP; called to display results of run
+1 DO DT^DICRW
DO ^XBCLS
+2 WRITE !!,"RESULTS OF AVA CHECK OF FILES 3, 6, 16, & 200",!
+3 ;
+4 IF $DATA(^AVA("OK"))
Begin DoDot:1
+5 WRITE !!,"ALL FILES OKAY! READY FOR CONVERSION."
+6 SET %H=^AVA("OK")
DO YX^%DTC
WRITE !,"Check completed at ",Y
DO READ
End DoDot:1
QUIT
+7 ;
+8 IF $DATA(^AVA("NOT OK"))
Begin DoDot:1
+9 WRITE !!,"FILE CHECK NOT RUN! ",^AVA("NOT OK")
DO READ
End DoDot:1
QUIT
+10 ;
+11 FOR AVAF=3,16
Begin DoDot:1
+12 IF $ORDER(^AVA(AVAF,0))
WRITE !!,"ERRORS FROM FILE ",AVAF
+13 SET AVAX=0
FOR
SET AVAX=$ORDER(^AVA(AVAF,AVAX))
IF 'AVAX
QUIT
Begin DoDot:2
+14 WRITE !,"Entry #",AVAX,?15,^AVA(AVAF,AVAX)
+15 IF $Y>20
DO READ
DO ^XBCLS
End DoDot:2
End DoDot:1
+16 ;
+17 KILL DIR,AVAF,AVAX
QUIT
+18 ;
READ ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press ENTER to continue"
DO ^DIR
QUIT
+2 ;
ADD1(AVAX) ;EP; called to add new person & user entries for person entry
+1 NEW AVA3,X
+2 SET AVA3=$PIECE(^VA(200,0),U,3)+1
+3 IF $DATA(^VA(200,AVA3))
QUIT
IF $DATA(^DIC(3,AVA3))
QUIT
+4 SET $PIECE(^VA(200,0),U,3)=AVA3
SET $PIECE(^DIC(3,0),U,3)=AVA3
+5 ;
+6 ;name
SET ^VA(200,AVA3,0)=$PIECE(^DIC(16,AVAX,0),U)
+7 ;name xref
SET ^VA(200,"B",$PIECE(^VA(200,AVA3,0),U),AVA3)=""
+8 ;person pointer
SET $PIECE(^VA(200,AVA3,0),U,16)=AVAX
+9 SET X=$PIECE(^DIC(16,AVAX,0),U,9)
IF X]""
Begin DoDot:1
+10 SET $PIECE(^VA(200,AVA3,1),U,9)=X
+11 SET ^VA(200,"SSN",X,AVA3)=""
End DoDot:1
+12 ;
+13 SET ^DIC(3,AVA3,0)=$PIECE(^DIC(16,AVAX,0),U)
+14 SET ^DIC(3,"B",$PIECE(^DIC(3,AVA3,0),U),AVA3)=""
+15 SET $PIECE(^DIC(3,AVA3,0),U,16)=AVAX
+16 ;
+17 SET ^DIC(16,AVAX,"A3")=AVA3
+18 QUIT
