DGYM78PT ;ALB/MLI - Post-install routine for DG*5.3*78 ; 3/4/96@925
;;5.3;Registration;**78**;Aug 13, 1993
;
; 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYM78PT 1988 printed Dec 13, 2024@03:00:16 Page 2
DGYM78PT ;ALB/MLI - Post-install routine for DG*5.3*78 ; 3/4/96@925
+1 ;;5.3;Registration;**78**;Aug 13, 1993
+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
