DGYM78PT.m

DGYM78PT ;ALB/MLI - Post-install routine for DG*5.3*78 ; 3/4/96@925

 ;;5.3;Registration;**78,1015**;Aug 13, 1993;Build 21

 ;

 ; This post-install routine will check the Medical Center Division

 ; file to ensure that each entry has a unique pointer to the

 ; Institution file.  It will also delete the .001 field in the

 ; Eligibility code file (#8) if one exists.

 ;

EN ; begin processing

 D ELIG

 D DIV

 Q

 ;

 ;

ELIG ; look for .001 field in file 8...delete if there

 N DA,DIK

 I $D(^DD(8,.001)) D

 . D BMES^XPDUTL(">>> .001 Field of Eligibility code file found and deleted...")

 . S DIK="^DD(8,",DA=.001,DA(1)=8

 . D ^DIK

 Q

 ;

 ;

DIV ; search for problems with medical center division/institution relationship

 N CT,I,X

 D BMES^XPDUTL(">>> Searching for entries in the Medical Center Division file that")

 D MES^XPDUTL("    don't have a pointer to the Institution file...")

 S (CT,I)=0 F  S I=$O(^DG(40.8,I)) Q:'I  D

 . S X=$G(^DG(40.8,I,0))

 . I $G(^DIC(4,+$P(X,"^",7),0))']"" D

 . . D DIVNAME(I)

 . . S CT=CT+1

 I 'CT D MES^XPDUTL("       All divisions ok.  No problems found!")

 ;

 ;

 D BMES^XPDUTL(">>> Searching for entries in the Medical Center Division file that")

 D MES^XPDUTL("    point to the same Institution file entry...")

 S (CT,I)=0 F  S I=$O(^DG(40.8,"AD",I)) Q:'I  D

 . S X=$O(^DG(40.8,"AD",I,0))

 . I '$O(^DG(40.8,"AD",I,X)) Q  ; no duplicate pointers

 . S J=0 F  S J=$O(^DG(40.8,"AD",I,J)) Q:'J  D

 . . S CT=CT+1

 . . D DIVNAME(J)

 I 'CT D MES^XPDUTL("       All divisions ok.  No problems found!")

 Q

 ;

 ;

DIVNAME(IEN) ; print out division with institution pointer

 ;

 ; input - IEN as IEN of the entry in the Medical Center Division file.

 ;

 N X,Y

 S X=$G(^DG(40.8,+IEN,0)),Y=$P($G(^DIC(4,+$P(X,"^",7),0)),"^",1)

 S STRING=$S($P(X,"^",1)]"":$P(X,"^",1),1:"UNKNOWN DIVISION")_" (IEN #"_IEN_")"

 S STRING=STRING_" points to "_$S(Y]"":Y_" institution (IEN #"_+$P(X,"^",7)_")",1:"no institution")

 D MES^XPDUTL(STRING)

 Q

DGYM78PT  ;ALB/MLI - Post-install routine for DG*5.3*78 ; 3/4/96@925

 +1       ;;5.3;Registration;**78,1015**;Aug 13, 1993;Build 21

 +2       ;

 +3       ; This post-install routine will check the Medical Center Division

 +4       ; file to ensure that each entry has a unique pointer to the

 +5       ; Institution file.  It will also delete the .001 field in the

 +6       ; Eligibility code file (#8) if one exists.

 +7       ;

EN        ; begin processing

 +1        DO ELIG

 +2        DO DIV

 +3        QUIT 

 +4       ;

 +5       ;

ELIG      ; look for .001 field in file 8...delete if there

 +1        NEW DA,DIK

 +2        IF $DATA(^DD(8,.001))

               Begin DoDot:1

 +3                DO BMES^XPDUTL(">>> .001 Field of Eligibility code file found and deleted...")

 +4                SET DIK="^DD(8,"

                   SET DA=.001

                   SET DA(1)=8

 +5                DO ^DIK

               End DoDot:1

 +6        QUIT 

 +7       ;

 +8       ;

DIV       ; search for problems with medical center division/institution relationship

 +1        NEW CT,I,X

 +2        DO BMES^XPDUTL(">>> Searching for entries in the Medical Center Division file that")

 +3        DO MES^XPDUTL("    don't have a pointer to the Institution file...")

 +4        SET (CT,I)=0

           FOR 

               SET I=$ORDER(^DG(40.8,I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +5                SET X=$GET(^DG(40.8,I,0))

 +6                IF $GET(^DIC(4,+$PIECE(X,"^",7),0))']""

                       Begin DoDot:2

 +7                        DO DIVNAME(I)

 +8                        SET CT=CT+1

                       End DoDot:2

               End DoDot:1

 +9        IF 'CT

               DO MES^XPDUTL("       All divisions ok.  No problems found!")

 +10      ;

 +11      ;

 +12       DO BMES^XPDUTL(">>> Searching for entries in the Medical Center Division file that")

 +13       DO MES^XPDUTL("    point to the same Institution file entry...")

 +14       SET (CT,I)=0

           FOR 

               SET I=$ORDER(^DG(40.8,"AD",I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +15               SET X=$ORDER(^DG(40.8,"AD",I,0))

 +16      ; no duplicate pointers

                   IF '$ORDER(^DG(40.8,"AD",I,X))

                       QUIT 

 +17               SET J=0

                   FOR 

                       SET J=$ORDER(^DG(40.8,"AD",I,J))

                       IF 'J

                           QUIT 

                       Begin DoDot:2

 +18                       SET CT=CT+1

 +19                       DO DIVNAME(J)

                       End DoDot:2

               End DoDot:1

 +20       IF 'CT

               DO MES^XPDUTL("       All divisions ok.  No problems found!")

 +21       QUIT 

 +22      ;

 +23      ;

DIVNAME(IEN) ; print out division with institution pointer

 +1       ;

 +2       ; input - IEN as IEN of the entry in the Medical Center Division file.

 +3       ;

 +4        NEW X,Y

 +5        SET X=$GET(^DG(40.8,+IEN,0))

           SET Y=$PIECE($GET(^DIC(4,+$PIECE(X,"^",7),0)),"^",1)

 +6        SET STRING=$SELECT($PIECE(X,"^",1)]"":$PIECE(X,"^",1),1:"UNKNOWN DIVISION")_" (IEN #"_IEN_")"

 +7        SET STRING=STRING_" points to "_$SELECT(Y]"":Y_" institution (IEN #"_+$PIECE(X,"^",7)_")",1:"no institution")

 +8        DO MES^XPDUTL(STRING)

 +9        QUIT