- 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