LRBLFX72.m

LRBLFX72 ; IHS/DIR/AAB -PUT DIVISION ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 ;S DUZ(2)=+$$SITE^VASITE

 D ^LR127PO  ;IHS/OIRM TUC/AAB 2/17/98 PATCH 127

 D LR72PO   ;IHS/DIR TUC/AAB 5/18/98   PATCH 72

 D ^LRARIPOS  ;IHS/DIR TUC/AAB 5/18/98 PATCH 59

 D ^LR138PO  ;IHS/DIR TUC/AAB 05/19/98 PATCH 138

 D ^LRFIXAU  ;IHS/DIR TUC/AAB 05/19/98 PATCH 134

 D ^LR132P  ;IHS/DIR TUC/AAB 05/20/98  PATCH 132

 D POST^LR157  ;IHS/DIR TUC/AAB 05/20/98 PATCH 157

 D POST^LR163  ;IHS/DIR TUC/AAB 05/20/98 PATCH 163

 Q

LR72PO ;

 S DUZ(2)=+$$SITE^HLZFUNC  ;IHS/OIRM TUC/AAB 3/1/98

 I $D(^LRO(68,"VR")) D ^LRAPFIX Q

 ;

 ; Populate file 68 ASSOCIATED DIVISION field multiple

 N DO,DD,DA,LRSS,X

 S DA=0 F  S DA=$O(^LRO(68,DA)) Q:DA'>0  D

 . S DA(1)=DA

 . S LRSS=$P(^LRO(68,DA,0),U,2)

 . S DIC="^LRO(68,"_DA(1)_",3,"

 . S DIC(0)="L"

 . S DIC("P")="68.03PA"

 . S X=DUZ(2),DINUM=X

 . D FILE^DICN

 D BMES^XPDUTL("Your ASSOCIATED DIVISION field in file 68 has been populated for all accession areas.")

 ;

 ; Populate file 65 DIVISION field.

 S DA=0 F  S DA=$O(^LRD(65,DA)) Q:'DA  S X=^(DA,0) I '$P(X,"^",16) S $P(^(0),"^",16)=DUZ(2),^LRD(65,"D",DUZ(2),DA)=""

 ;

 ; Populate file 66 ASSOCIATED DIVISION field

BP S DA=0 F  S DA=$O(^LAB(66,DA)) Q:+DA'>0  I '$O(^LAB(66,DA,10,0)) S ^(DUZ(2),0)=DUZ(2),^LAB(66,DA,10,0)="^66.1PA^"_DUZ(2)_"^"_1

 D BMES^XPDUTL("Your new DIVISION field in files 65 & 66 has been populated") W $C(7),!!!

 D BMES^XPDUTL("You MAY NOW let users back on--HOWEVER, all ANATOMIC PATHOLOGY options should be DISABLED while I convert the AP accession numbers to their new format") W $C(7),$C(7),!!

 D ^LRAPFIX Q

LRBLFX72  ; IHS/DIR/AAB -PUT DIVISION ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3       ;S DUZ(2)=+$$SITE^VASITE

 +4       ;IHS/OIRM TUC/AAB 2/17/98 PATCH 127

           DO ^LR127PO

 +5       ;IHS/DIR TUC/AAB 5/18/98   PATCH 72

           DO LR72PO

 +6       ;IHS/DIR TUC/AAB 5/18/98 PATCH 59

           DO ^LRARIPOS

 +7       ;IHS/DIR TUC/AAB 05/19/98 PATCH 138

           DO ^LR138PO

 +8       ;IHS/DIR TUC/AAB 05/19/98 PATCH 134

           DO ^LRFIXAU

 +9       ;IHS/DIR TUC/AAB 05/20/98  PATCH 132

           DO ^LR132P

 +10      ;IHS/DIR TUC/AAB 05/20/98 PATCH 157

           DO POST^LR157

 +11      ;IHS/DIR TUC/AAB 05/20/98 PATCH 163

           DO POST^LR163

 +12       QUIT 

LR72PO    ;

 +1       ;IHS/OIRM TUC/AAB 3/1/98

           SET DUZ(2)=+$$SITE^HLZFUNC

 +2        IF $DATA(^LRO(68,"VR"))

               DO ^LRAPFIX

               QUIT 

 +3       ;

 +4       ; Populate file 68 ASSOCIATED DIVISION field multiple

 +5        NEW DO,DD,DA,LRSS,X

 +6        SET DA=0

           FOR 

               SET DA=$ORDER(^LRO(68,DA))

               IF DA'>0

                   QUIT 

               Begin DoDot:1

 +7                SET DA(1)=DA

 +8                SET LRSS=$PIECE(^LRO(68,DA,0),U,2)

 +9                SET DIC="^LRO(68,"_DA(1)_",3,"

 +10               SET DIC(0)="L"

 +11               SET DIC("P")="68.03PA"

 +12               SET X=DUZ(2)

                   SET DINUM=X

 +13               DO FILE^DICN

               End DoDot:1

 +14       DO BMES^XPDUTL("Your ASSOCIATED DIVISION field in file 68 has been populated for all accession areas.")

 +15      ;

 +16      ; Populate file 65 DIVISION field.

 +17       SET DA=0

           FOR 

               SET DA=$ORDER(^LRD(65,DA))

               IF 'DA

                   QUIT 

               SET X=^(DA,0)

               IF '$PIECE(X,"^",16)

                   SET $PIECE(^(0),"^",16)=DUZ(2)

                   SET ^LRD(65,"D",DUZ(2),DA)=""

 +18      ;

 +19      ; Populate file 66 ASSOCIATED DIVISION field

BP         SET DA=0

           FOR 

               SET DA=$ORDER(^LAB(66,DA))

               IF +DA'>0

                   QUIT 

               IF '$ORDER(^LAB(66,DA,10,0))

                   SET ^(DUZ(2),0)=DUZ(2)

                   SET ^LAB(66,DA,10,0)="^66.1PA^"_DUZ(2)_"^"_1

 +1        DO BMES^XPDUTL("Your new DIVISION field in files 65 & 66 has been populated")

           WRITE $CHAR(7),!!!

 +2        DO BMES^XPDUTL("You MAY NOW let users back on--HOWEVER, all ANATOMIC PATHOLOGY options should be DISABLED while I convert the AP accession numbers to their new format")

           WRITE $CHAR(7),$CHAR(7),!!

 +3        DO ^LRAPFIX

           QUIT