BDGPRE1.m

BDGPRE1 ; IHS//ANMC/LJF - PIMS PREINIT ADDENDUM;  [ 05/12/2003  3:26 PM ]

 ;;5.3;PIMS;;APR 26, 2002

 ;

 ; Changes that must be made BEFORE running install

 ;11/5/2002 IHS/ITSC/WAR - created this small rtn to correct a problem

 ;   with the Institution field not being populated in ^DG(40.8 and

 ;   for outpatient only sites.

 ;4/15/2003 IHS/ITSC/WAR - added code to handle mulitiple facilities

 ;   and/or no facility pointer values (this was found to be a problem

 ;   with some sites that may have bogus or incomplete entries).

 N A,D

 S D=0,U="^"

 F  S D=$O(^DG(40.8,D)) Q:'D  D   ;Handles single & multi Div

 .S A=$P($G(^DG(40.8,D,0)),U,7)   ;Need Institution file pointer

 .I +A=0 D                        ;Invalid pointer

 ..S A=$P($G(^DG(40.8,D,0)),U,2)  ;use Facility pointer value

 ..I +A=0 D                       ;If no pointer value, set it to

 ...S A=29                        ;  UNDESIG UNSPEC Div and

 ...S $P(^DG(40.8,D,0),U,2)=A     ;  set Pc2 in Med Cntr Div file

 ..S $P(^DG(40.8,D,0),U,7)=A      ;stuff Instit pointer

 S DIK="^DG(40.8," D IXALL^DIK    ;Reindex all records

DG43CK ;

 ;3/11/2003 IHS/ITSC/WAR

 ;  This section checks the MAS PARAMETERS file (#43) to see if it

 ;  exists and corrects the file if necessary. A problem could arise

 ;  if the ^DG(43,1,0) node does not exist - see the line of code

 ;  Q:'$D(^DG(43,1,0), found in the ^BSDPARM routine.

 ;

 ;

 I $D(^DG(43)) D         ;If the global exists and

 .I '$D(^DG(43,1,0)) D   ;If this record does not exist,

 ..S ^DG(43,1,0)=1       ;create it

 .K ^DG(43,"B")          ;Kill off ALL "B" xref

 .S ^DG(43,"B",1,1)=""   ;Create the ONE and ONLY "B" xref and

 .S ^DG(43,0)="MAS PARAMETERS^43^1^1"      ;reset the zero node

 .;

 .;Now remove any remaining records - only ONE record for this file is

 .;allowed - NOTE: All "B" xref were removed earlier.

 .S A=1

 .F  S A=$O(^DG(43,A)) Q:A'>0  D

 ..K ^DG(43,A)

 Q

BDGPRE1   ; IHS//ANMC/LJF - PIMS PREINIT ADDENDUM;  [ 05/12/2003  3:26 PM ]

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

 +3       ; Changes that must be made BEFORE running install

 +4       ;11/5/2002 IHS/ITSC/WAR - created this small rtn to correct a problem

 +5       ;   with the Institution field not being populated in ^DG(40.8 and

 +6       ;   for outpatient only sites.

 +7       ;4/15/2003 IHS/ITSC/WAR - added code to handle mulitiple facilities

 +8       ;   and/or no facility pointer values (this was found to be a problem

 +9       ;   with some sites that may have bogus or incomplete entries).

 +10       NEW A,D

 +11       SET D=0

           SET U="^"

 +12      ;Handles single & multi Div

           FOR 

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

               IF 'D

                   QUIT 

               Begin DoDot:1

 +13      ;Need Institution file pointer

                   SET A=$PIECE($GET(^DG(40.8,D,0)),U,7)

 +14      ;Invalid pointer

                   IF +A=0

                       Begin DoDot:2

 +15      ;use Facility pointer value

                           SET A=$PIECE($GET(^DG(40.8,D,0)),U,2)

 +16      ;If no pointer value, set it to

                           IF +A=0

                               Begin DoDot:3

 +17      ;  UNDESIG UNSPEC Div and

                                   SET A=29

 +18      ;  set Pc2 in Med Cntr Div file

                                   SET $PIECE(^DG(40.8,D,0),U,2)=A

                               End DoDot:3

 +19      ;stuff Instit pointer

                           SET $PIECE(^DG(40.8,D,0),U,7)=A

                       End DoDot:2

               End DoDot:1

 +20      ;Reindex all records

           SET DIK="^DG(40.8,"

           DO IXALL^DIK

DG43CK    ;

 +1       ;3/11/2003 IHS/ITSC/WAR

 +2       ;  This section checks the MAS PARAMETERS file (#43) to see if it

 +3       ;  exists and corrects the file if necessary. A problem could arise

 +4       ;  if the ^DG(43,1,0) node does not exist - see the line of code

 +5       ;  Q:'$D(^DG(43,1,0), found in the ^BSDPARM routine.

 +6       ;

 +7       ;

 +8       ;If the global exists and

           IF $DATA(^DG(43))

               Begin DoDot:1

 +9       ;If this record does not exist,

                   IF '$DATA(^DG(43,1,0))

                       Begin DoDot:2

 +10      ;create it

                           SET ^DG(43,1,0)=1

                       End DoDot:2

 +11      ;Kill off ALL "B" xref

                   KILL ^DG(43,"B")

 +12      ;Create the ONE and ONLY "B" xref and

                   SET ^DG(43,"B",1,1)=""

 +13      ;reset the zero node

                   SET ^DG(43,0)="MAS PARAMETERS^43^1^1"

 +14      ;

 +15      ;Now remove any remaining records - only ONE record for this file is

 +16      ;allowed - NOTE: All "B" xref were removed earlier.

 +17               SET A=1

 +18               FOR 

                       SET A=$ORDER(^DG(43,A))

                       IF A'>0

                           QUIT 

                       Begin DoDot:2

 +19                       KILL ^DG(43,A)

                       End DoDot:2

               End DoDot:1

 +20       QUIT