BDGPRE.m

BDGPRE ; IHS/ANMC/LJF - PIMS PREINIT ;  [ 12/02/2002  4:25 PM ]

 ;;5.3;PIMS;;APR 26, 2002

 ;

 ; Changes that must be made BEFORE running install

 ;11/6/2002 WAR - added a call to ^BDGPRE1

 ;D DPTDEL,BULLD,BULLC Q

 D ^BDGPRE1,DPTDEL,BULLD,BULLC Q

 ;

DPTDEL ; -- delete old dd for files 2,40.8, 42, 43, 44, 405

 ; -- VA removed lots of fields

 S ADIFROM("IHS")=""     ;so user won't be asked continue question

 K ^UTILITY("XBDSET",$J)

 S ^UTILITY("XBDSET",$J,2)="S^S"

 S ^UTILITY("XBDSET",$J,40.8)="S^S"

 S ^UTILITY("XBDSET",$J,42)="S^S"

 S ^UTILITY("XBDSET",$J,43)="S^S"

 S ^UTILITY("XBDSET",$J,44)="S^S"

 S ^UTILITY("XBDSET",$J,405)="S^S"

 D EN2^XBKD

 K ADIFROM("IHS")

 Q

 ;

BULLD ; delete obsolete bulletins

 NEW BDGI,DIK,DA,NAME

 S DIK="^XMB(3.6,"

 F BDGI=1:1:3 S NAME=$P($T(OLDBUL+BDGI),";;",2) D

 . Q:'$D(^XMB(3.6,"B",NAME))    ;does not have old bulletins

 . S DA=$O(^XMB(3.6,"B",NAME,0)) I DA D ^DIK

 Q

 ;

BULLC ; change names of ADT bulletins if already on system

 ; and delete message text to start fresh

 NEW DIE,DA,DR,OLD,IEN,X,BDGI

 F BDGI=1:1:9 S OLD=$P($T(BULLNM+BDGI),";;",2) D

 . Q:'$D(^XMB(3.6,"B",OLD))    ;does not have old bulletin

 . S IEN=$O(^XMB(3.6,"B",OLD,0)) Q:'IEN   ;bad xref

 . ;

 . ; change name

 . S DIE=3.6,DA=IEN,DR=".01///"_$P($T(BULLNM+BDGI),";;",3) D ^DIE

 . ;

 . ; now remove message text

 . S X=0 F  S X=$O(^XMB(3.6,IEN,1,X)) Q:'X  D

 .. K ^XMB(3.6,IEN,1,X,0)

 Q

 ;

 ;

OLDBUL ;; obsolete bulletins

 ;;DG IHS INCOMPLETE MOVEMENT;;

 ;;DG IHS ADCORR;;

 ;;DG IHS VHOSP;;

 ;

 ;

BULLNM ;; bulletin names (old;;new)

 ;;DG IHS A&D;;BDG A&D READY;;

 ;;DG IHS B ADMIT AFTER DAY SURG;;BDG ADMIT AFTER DAY SURG;;

 ;;DG IHS B AMA DISCHARGE;;BDG AMA DISCHARGE;;

 ;;DG IHS B DEATH;;BDG DEATH;;

 ;;DG IHS B ICU TRANSFER;;BDG ICU TRANSFER;;

 ;;DG IHS B READMISSION;;BDG READMISSION;;

 ;;DG IHS B TRANSFER IN ADMIT;;BDG TRANSFER IN ADMIT;;

 ;;DG IHS B TRANSFER OUT DISCH;;BDG TRANSFER OUT DISCH;;

 ;;DG IHS DELETED ADMITS;;BDG DELETED ADMITS;;

BDGPRE    ; IHS/ANMC/LJF - PIMS PREINIT ;  [ 12/02/2002  4:25 PM ]

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

 +2       ;

 +3       ; Changes that must be made BEFORE running install

 +4       ;11/6/2002 WAR - added a call to ^BDGPRE1

 +5       ;D DPTDEL,BULLD,BULLC Q

 +6        DO ^BDGPRE1

           DO DPTDEL

           DO BULLD

           DO BULLC

           QUIT 

 +7       ;

DPTDEL    ; -- delete old dd for files 2,40.8, 42, 43, 44, 405

 +1       ; -- VA removed lots of fields

 +2       ;so user won't be asked continue question

           SET ADIFROM("IHS")=""

 +3        KILL ^UTILITY("XBDSET",$JOB)

 +4        SET ^UTILITY("XBDSET",$JOB,2)="S^S"

 +5        SET ^UTILITY("XBDSET",$JOB,40.8)="S^S"

 +6        SET ^UTILITY("XBDSET",$JOB,42)="S^S"

 +7        SET ^UTILITY("XBDSET",$JOB,43)="S^S"

 +8        SET ^UTILITY("XBDSET",$JOB,44)="S^S"

 +9        SET ^UTILITY("XBDSET",$JOB,405)="S^S"

 +10       DO EN2^XBKD

 +11       KILL ADIFROM("IHS")

 +12       QUIT 

 +13      ;

BULLD     ; delete obsolete bulletins

 +1        NEW BDGI,DIK,DA,NAME

 +2        SET DIK="^XMB(3.6,"

 +3        FOR BDGI=1:1:3

               SET NAME=$PIECE($TEXT(OLDBUL+BDGI),";;",2)

               Begin DoDot:1

 +4       ;does not have old bulletins

                   IF '$DATA(^XMB(3.6,"B",NAME))

                       QUIT 

 +5                SET DA=$ORDER(^XMB(3.6,"B",NAME,0))

                   IF DA

                       DO ^DIK

               End DoDot:1

 +6        QUIT 

 +7       ;

BULLC     ; change names of ADT bulletins if already on system

 +1       ; and delete message text to start fresh

 +2        NEW DIE,DA,DR,OLD,IEN,X,BDGI

 +3        FOR BDGI=1:1:9

               SET OLD=$PIECE($TEXT(BULLNM+BDGI),";;",2)

               Begin DoDot:1

 +4       ;does not have old bulletin

                   IF '$DATA(^XMB(3.6,"B",OLD))

                       QUIT 

 +5       ;bad xref

                   SET IEN=$ORDER(^XMB(3.6,"B",OLD,0))

                   IF 'IEN

                       QUIT 

 +6       ;

 +7       ; change name

 +8                SET DIE=3.6

                   SET DA=IEN

                   SET DR=".01///"_$PIECE($TEXT(BULLNM+BDGI),";;",3)

                   DO ^DIE

 +9       ;

 +10      ; now remove message text

 +11               SET X=0

                   FOR 

                       SET X=$ORDER(^XMB(3.6,IEN,1,X))

                       IF 'X

                           QUIT 

                       Begin DoDot:2

 +12                       KILL ^XMB(3.6,IEN,1,X,0)

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

 +14      ;

 +15      ;

OLDBUL    ;; obsolete bulletins

 +1       ;;DG IHS INCOMPLETE MOVEMENT;;

 +2       ;;DG IHS ADCORR;;

 +3       ;;DG IHS VHOSP;;

 +4       ;

 +5       ;

BULLNM    ;; bulletin names (old;;new)

 +1       ;;DG IHS A&D;;BDG A&D READY;;

 +2       ;;DG IHS B ADMIT AFTER DAY SURG;;BDG ADMIT AFTER DAY SURG;;

 +3       ;;DG IHS B AMA DISCHARGE;;BDG AMA DISCHARGE;;

 +4       ;;DG IHS B DEATH;;BDG DEATH;;

 +5       ;;DG IHS B ICU TRANSFER;;BDG ICU TRANSFER;;

 +6       ;;DG IHS B READMISSION;;BDG READMISSION;;

 +7       ;;DG IHS B TRANSFER IN ADMIT;;BDG TRANSFER IN ADMIT;;

 +8       ;;DG IHS B TRANSFER OUT DISCH;;BDG TRANSFER OUT DISCH;;

 +9       ;;DG IHS DELETED ADMITS;;BDG DELETED ADMITS;;