AVAP4.m

AVAP4 ;IHS/ORDC/LJF - CLEANUP PROVIDER CLASS ENTRIES; [ 05/11/94  2:57 PM ]

 ;;93.2;VA SUPPORT FILES;**4,5,6**;JUL 01, 1993;Build 12

 ;cleanup rtn for patches #4, 5, & 6

 ;

 Q  ;can only execute from line label

 ;

CLASS ;EP >> kill off file 6 entries if no zero node

 ;      then if provider class set in file 200, fire xrefs for

 ;      provider class, affiliation, and code

 ;

 S U="^"

 W !!!,"This program will cleanup bad entries in your PROVIDER file"

 W !,"and recreate them if a PROVIDER CLASS has been entered for the"

 W !,"provider in the NEW PERSON file."

 W !! K DIR S DIR(0)="YO",DIR("B")="NO"

 S DIR("A")="OKAY to run CLEANUP" D ^DIR Q:Y'=1

 ;

 S AVA6=0

 F  S AVA6=$O(^DIC(6,AVA6)) Q:AVA6'=+AVA6  D

 .Q:$D(^DIC(6,AVA6,0))  ;skip good entries

 .Q:'$D(^DIC(6,AVA6,9999999))  I $P(^(9999999),U,9)]""  D  ;PATCH 6

 ..K ^DIC(6,"GIHS",$P(^DIC(6,AVA6,9999999),U,9),AVA6) ;kill xref PATCH 6

 .K ^DIC(6,AVA6) ;kill bad entry in file 6

 .S AVA200=$P($G(^DIC(16,AVA6,"A3")),U) ;ifn in file 200

 .Q:AVA200=""  Q:'$D(^VA(200,AVA200,0))  ;no entry in file 200

 .Q:$P($G(^DIC(3,AVA200,0)),U,16)'=AVA6  ;bad pointers

 .S AVACLS=$P($G(^VA(200,AVA200,"PS")),U,5) ;IHS/ORDC/LJF PATCH 5

 .Q:AVACLS=""  ;no provider class entered

 .;

 .S DIE="^VA(200,",DA=AVA200,DR="53.5///@" D ^DIE

 .S DR="53.5////"_AVACLS D ^DIE

 .;

 .W !,"NEW PERSON entry #",AVA200," creating entry in file 6"

 ;

 W !!,"CLEANUP COMPLETE",!

 ;

EOJ ;     

 K AVA6,AVA200,DIR,DIE,DA,DR,X,Y

 Q

AVAP4     ;IHS/ORDC/LJF - CLEANUP PROVIDER CLASS ENTRIES; [ 05/11/94  2:57 PM ]

 +1       ;;93.2;VA SUPPORT FILES;**4,5,6**;JUL 01, 1993;Build 12

 +2       ;cleanup rtn for patches #4, 5, & 6

 +3       ;

 +4       ;can only execute from line label

           QUIT 

 +5       ;

CLASS     ;EP >> kill off file 6 entries if no zero node

 +1       ;      then if provider class set in file 200, fire xrefs for

 +2       ;      provider class, affiliation, and code

 +3       ;

 +4        SET U="^"

 +5        WRITE !!!,"This program will cleanup bad entries in your PROVIDER file"

 +6        WRITE !,"and recreate them if a PROVIDER CLASS has been entered for the"

 +7        WRITE !,"provider in the NEW PERSON file."

 +8        WRITE !!

           KILL DIR

           SET DIR(0)="YO"

           SET DIR("B")="NO"

 +9        SET DIR("A")="OKAY to run CLEANUP"

           DO ^DIR

           IF Y'=1

               QUIT 

 +10      ;

 +11       SET AVA6=0

 +12       FOR 

               SET AVA6=$ORDER(^DIC(6,AVA6))

               IF AVA6'=+AVA6

                   QUIT 

               Begin DoDot:1

 +13      ;skip good entries

                   IF $DATA(^DIC(6,AVA6,0))

                       QUIT 

 +14      ;PATCH 6

                   IF '$DATA(^DIC(6,AVA6,9999999))

                       QUIT 

                   IF $PIECE(^(9999999),U,9)]""

                       Begin DoDot:2

 +15      ;kill xref PATCH 6

                           KILL ^DIC(6,"GIHS",$PIECE(^DIC(6,AVA6,9999999),U,9),AVA6)

                       End DoDot:2

 +16      ;kill bad entry in file 6

                   KILL ^DIC(6,AVA6)

 +17      ;ifn in file 200

                   SET AVA200=$PIECE($GET(^DIC(16,AVA6,"A3")),U)

 +18      ;no entry in file 200

                   IF AVA200=""

                       QUIT 

                   IF '$DATA(^VA(200,AVA200,0))

                       QUIT 

 +19      ;bad pointers

                   IF $PIECE($GET(^DIC(3,AVA200,0)),U,16)'=AVA6

                       QUIT 

 +20      ;IHS/ORDC/LJF PATCH 5

                   SET AVACLS=$PIECE($GET(^VA(200,AVA200,"PS")),U,5)

 +21      ;no provider class entered

                   IF AVACLS=""

                       QUIT 

 +22      ;

 +23               SET DIE="^VA(200,"

                   SET DA=AVA200

                   SET DR="53.5///@"

                   DO ^DIE

 +24               SET DR="53.5////"_AVACLS

                   DO ^DIE

 +25      ;

 +26               WRITE !,"NEW PERSON entry #",AVA200," creating entry in file 6"

               End DoDot:1

 +27      ;

 +28       WRITE !!,"CLEANUP COMPLETE",!

 +29      ;

EOJ       ;     

 +1        KILL AVA6,AVA200,DIR,DIE,DA,DR,X,Y

 +2        QUIT