BDGPOST3.m

BDGPOST3 ; IHS/ANMC/LJF - ADT POSTINIT (TRANSFER FACILITY) ; 

 ;;5.3;PIMS;;APR 26, 2002

 ;

 Q

 ;

EN ;EP; builds new transfer facility file while converting entries in

 ; both ADT and PCC to point to new file

 ; Changes made in Patient Movement file and V Hospitalization file

 NEW BDGN,FAC,NAME,FILE,IEN,DIE,DR,DR

 ;

 Q:$D(^BDGX(10))   ;already done

 D BMES^XPDUTL("Converting transfer facility entries to straight pointers...")

 ;

 ; first loop thru Patient Movement file

 S BDGN=0 F  S BDGN=$O(^DGPM(BDGN)) Q:'BDGN  D

 . Q:$P($G(^DGPM(BDGN,0)),U,5)'[";"   ;no data to convert

 . S FAC=$P(^DGPM(BDGN,0),U,5),FILE=$S(FAC["DIC":4,1:9999999.11)

 . S NAME=$$GET1^DIQ(FILE,+FAC,.01) Q:NAME=""   ;get name

 . S ^XTMP("BDGPOST3A",$J,"LAST")="DGPM^"_BDGN

 . ;

 . ; create entry in new file if not already there

 . I '$D(^AUTTTFAC("B",NAME)) D ADD(NAME,FAC) Q:'$D(^AUTTTFAC("B",NAME))

 . ;

 . ; change pointer in file 405

 . S IEN=$O(^AUTTTFAC("B",NAME,0)) I 'IEN D ERRLOG Q

 . S DIE=405,DA=BDGN,DR=".05///`"_IEN D ^DIE

 ;

 ; now change all V Hospitalization entries

 K X S X="  Now converting transfer facility entries in V Hospitalization file..."

 D MES^XPDUTL(.X)

 S BDGN=0 F  S BDGN=$O(^AUPNVINP(BDGN)) Q:'BDGN  D

 . Q:$P($G(^AUPNVINP(BDGN,0)),U,9)'[";"  ;no data to convert

 . S FAC=$P(^AUPNVINP(BDGN,0),U,9),FILE=$S(FAC["DIC":4,1:9999999.11)

 . S NAME=$$GET1^DIQ(FILE,+FAC,.01) Q:NAME=""   ;get name

 . S ^XTMP("BDGPOST3A",$J,"LAST")="VHOSP^"_BDGN

 . ;

 . ; create entry in new file if not already there

 . I '$D(^AUTTTFAC("B",NAME)) D ADD(NAME,FAC) Q:'$D(^AUTTTFAC("B",NAME))

 . ;

 . ; change pointer in file 405

 . S IEN=$O(^AUTTTFAC("B",NAME,0)) I 'IEN D ERRLOG Q

 . S DIE=9000010.02,DA=BDGN,DR=".09///`"_IEN D ^DIE

 K X S X=$$REPEAT^XLFSTR(" ",20)_"Done." D MES^XPDUTL(.X)

 Q

 ;

ADD(NAME,FAC) ; add entry to ^AUTTTFAC

 NEW DIC,DD,DO,X,DIE,DR,DA,Y

 S DIC="^AUTTTFAC(",DLAYGO=9999999.91,X=NAME,DIC(0)="L" D FILE^DICN

 I Y<1 D ERRLOG Q

 ; add link if IHS facility

 I FAC["DIC" S DIE=9999999.91,DA=+Y,DR=".03///"_(+FAC) D ^DIE

 Q

 ;

ERRLOG ; record errors

 S ^XTMP("BDGPOST3",$J,FAC)="" Q

BDGPOST3  ; IHS/ANMC/LJF - ADT POSTINIT (TRANSFER FACILITY) ; 

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

 +2       ;

 +3        QUIT 

 +4       ;

EN        ;EP; builds new transfer facility file while converting entries in

 +1       ; both ADT and PCC to point to new file

 +2       ; Changes made in Patient Movement file and V Hospitalization file

 +3        NEW BDGN,FAC,NAME,FILE,IEN,DIE,DR,DR

 +4       ;

 +5       ;already done

           IF $DATA(^BDGX(10))

               QUIT 

 +6        DO BMES^XPDUTL("Converting transfer facility entries to straight pointers...")

 +7       ;

 +8       ; first loop thru Patient Movement file

 +9        SET BDGN=0

           FOR 

               SET BDGN=$ORDER(^DGPM(BDGN))

               IF 'BDGN

                   QUIT 

               Begin DoDot:1

 +10      ;no data to convert

                   IF $PIECE($GET(^DGPM(BDGN,0)),U,5)'[";"

                       QUIT 

 +11               SET FAC=$PIECE(^DGPM(BDGN,0),U,5)

                   SET FILE=$SELECT(FAC["DIC":4,1:9999999.11)

 +12      ;get name

                   SET NAME=$$GET1^DIQ(FILE,+FAC,.01)

                   IF NAME=""

                       QUIT 

 +13               SET ^XTMP("BDGPOST3A",$JOB,"LAST")="DGPM^"_BDGN

 +14      ;

 +15      ; create entry in new file if not already there

 +16               IF '$DATA(^AUTTTFAC("B",NAME))

                       DO ADD(NAME,FAC)

                       IF '$DATA(^AUTTTFAC("B",NAME))

                           QUIT 

 +17      ;

 +18      ; change pointer in file 405

 +19               SET IEN=$ORDER(^AUTTTFAC("B",NAME,0))

                   IF 'IEN

                       DO ERRLOG

                       QUIT 

 +20               SET DIE=405

                   SET DA=BDGN

                   SET DR=".05///`"_IEN

                   DO ^DIE

               End DoDot:1

 +21      ;

 +22      ; now change all V Hospitalization entries

 +23       KILL X

           SET X="  Now converting transfer facility entries in V Hospitalization file..."

 +24       DO MES^XPDUTL(.X)

 +25       SET BDGN=0

           FOR 

               SET BDGN=$ORDER(^AUPNVINP(BDGN))

               IF 'BDGN

                   QUIT 

               Begin DoDot:1

 +26      ;no data to convert

                   IF $PIECE($GET(^AUPNVINP(BDGN,0)),U,9)'[";"

                       QUIT 

 +27               SET FAC=$PIECE(^AUPNVINP(BDGN,0),U,9)

                   SET FILE=$SELECT(FAC["DIC":4,1:9999999.11)

 +28      ;get name

                   SET NAME=$$GET1^DIQ(FILE,+FAC,.01)

                   IF NAME=""

                       QUIT 

 +29               SET ^XTMP("BDGPOST3A",$JOB,"LAST")="VHOSP^"_BDGN

 +30      ;

 +31      ; create entry in new file if not already there

 +32               IF '$DATA(^AUTTTFAC("B",NAME))

                       DO ADD(NAME,FAC)

                       IF '$DATA(^AUTTTFAC("B",NAME))

                           QUIT 

 +33      ;

 +34      ; change pointer in file 405

 +35               SET IEN=$ORDER(^AUTTTFAC("B",NAME,0))

                   IF 'IEN

                       DO ERRLOG

                       QUIT 

 +36               SET DIE=9000010.02

                   SET DA=BDGN

                   SET DR=".09///`"_IEN

                   DO ^DIE

               End DoDot:1

 +37       KILL X

           SET X=$$REPEAT^XLFSTR(" ",20)_"Done."

           DO MES^XPDUTL(.X)

 +38       QUIT 

 +39      ;

ADD(NAME,FAC) ; add entry to ^AUTTTFAC

 +1        NEW DIC,DD,DO,X,DIE,DR,DA,Y

 +2        SET DIC="^AUTTTFAC("

           SET DLAYGO=9999999.91

           SET X=NAME

           SET DIC(0)="L"

           DO FILE^DICN

 +3        IF Y<1

               DO ERRLOG

               QUIT 

 +4       ; add link if IHS facility

 +5        IF FAC["DIC"

               SET DIE=9999999.91

               SET DA=+Y

               SET DR=".03///"_(+FAC)

               DO ^DIE

 +6        QUIT 

 +7       ;

ERRLOG    ; record errors

 +1        SET ^XTMP("BDGPOST3",$JOB,FAC)=""

           QUIT