BPMXLR2.m

BPMXLR2 ;IHS/PHXAO/AEF - REPOINT LAB ^LR("BLRA") ESIG XREF

 ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010

 ;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office

 ;                       changed namespace from BZXM to BPM; BLR to BPM

 ;;

DESC ;----- ROUTINE DESCRIPTION

 ;;BPMXLR2:

 ;;THIS ROUTINE LOOPS THROUGH THE "BLRA" XREF ON THE LAB DATA FILE AND FINDS ALL

 ;;ENTRIES BELONGING TO THE PAIENT BEING MERGED FROM AND REPOINTS THEM TO THE 

 ;;PATIENT BEING MERGED TO.

 ;;

 ;;INPUT:

 ;;BPMFM  =  LRDFN OF PATIENT BEING MERGED FROM

 ;;BPMTO  =  LRDFN OF PATIENT BEING MERGED TO

 ;;

 ;;$$END

 ;

 N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END"  D EN^DDIOL(X)

 Q

EN(BPMFM,BPMTO) ;EP

 ;----- MAIN ENTRY POINT

 ;

 D ^XBKVAR

 D HOME^%ZIS

 ;

 D FIND(BPMFM)

 D MERGE(BPMFM,BPMTO)

 ;

 K ^TMP("BLRA",$J)

 ;

 Q

FIND(BPMFM) ;

 ;----- FIND "BLRA" XREFS FOR THE "FROM" PATIENT

 ;

 N BPMAPHY,BPMARFL,BPMDFN,BPMIDT,BPMSS

 ;

 K ^TMP("BPMLRA",$J)

 ;

 S BPMAPHY=0

 F  S BPMAPHY=$O(^LR("BLRA",BPMAPHY)) Q:'BPMAPHY  D

 . S BPMARFL=""

 . F  S BPMARFL=$O(^LR("BLRA",BPMAPHY,BPMARFL)) Q:BPMARFL']""  D

 . . S BPMIDT=""

 . . F  S BPMIDT=$O(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT)) Q:'BPMIDT  D

 . . . S BPMDFN=0

 . . . F  S BPMDFN=$O(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMDFN)) Q:'BPMDFN  D

 . . . . Q:BPMDFN'=BPMFM

 . . . . S BPMSS=""

 . . . . S BPMSS=$O(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMDFN,""))

 . . . . S ^TMP("BPMLRA",$J,BPMDFN,BPMIDT)=BPMAPHY_U_BPMARFL_U_BPMIDT_U_BPMDFN_U_BPMSS

 Q

 ;

MERGE(BPMFM,BPMTO) ;

 ;----- MERGE ENTRIES

 ;

 N BPMAPHY,BPMARFL,DATA,DATE,BPMDFN,BPMIDT,BPMSS

 ;

 S DATE=0

 F  S DATE=$O(^TMP("BPMLRA",$J,BPMFM,DATE)) Q:'DATE  D

 . S DATA=^TMP("BPMLRA",$J,BPMFM,DATE)

 . S BPMAPHY=$P(DATA,U)

 . S BPMARFL=$P(DATA,U,2)

 . S BPMIDT=$P(DATA,U,3)

 . S BPMDFN=$P(DATA,U,4)

 . S BPMSS=$P(DATA,U,5)

 . Q:'$D(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMFM))

 . ;S ^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMTO)=BPMSS

 . S ^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMTO,BPMSS)=BPMSS ; IHS/OIT/MKK - Data structure Change

 . K ^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMFM)

 . K ^TMP("BPMLRA",$J,BPMFM,DATE)

 ;

 Q

 ;

BPMXLR2   ;IHS/PHXAO/AEF - REPOINT LAB ^LR("BLRA") ESIG XREF

 +1       ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010

 +2       ;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office

 +3       ;                       changed namespace from BZXM to BPM; BLR to BPM

 +4       ;;

DESC      ;----- ROUTINE DESCRIPTION

 +1       ;;BPMXLR2:

 +2       ;;THIS ROUTINE LOOPS THROUGH THE "BLRA" XREF ON THE LAB DATA FILE AND FINDS ALL

 +3       ;;ENTRIES BELONGING TO THE PAIENT BEING MERGED FROM AND REPOINTS THEM TO THE 

 +4       ;;PATIENT BEING MERGED TO.

 +5       ;;

 +6       ;;INPUT:

 +7       ;;BPMFM  =  LRDFN OF PATIENT BEING MERGED FROM

 +8       ;;BPMTO  =  LRDFN OF PATIENT BEING MERGED TO

 +9       ;;

 +10      ;;$$END

 +11      ;

 +12       NEW I,X

           FOR I=1:1

               SET X=$PIECE($TEXT(DESC+I),";;",2)

               IF X["$$END"

                   QUIT 

               DO EN^DDIOL(X)

 +13       QUIT 

EN(BPMFM,BPMTO) ;EP

 +1       ;----- MAIN ENTRY POINT

 +2       ;

 +3        DO ^XBKVAR

 +4        DO HOME^%ZIS

 +5       ;

 +6        DO FIND(BPMFM)

 +7        DO MERGE(BPMFM,BPMTO)

 +8       ;

 +9        KILL ^TMP("BLRA",$JOB)

 +10      ;

 +11       QUIT 

FIND(BPMFM) ;

 +1       ;----- FIND "BLRA" XREFS FOR THE "FROM" PATIENT

 +2       ;

 +3        NEW BPMAPHY,BPMARFL,BPMDFN,BPMIDT,BPMSS

 +4       ;

 +5        KILL ^TMP("BPMLRA",$JOB)

 +6       ;

 +7        SET BPMAPHY=0

 +8        FOR 

               SET BPMAPHY=$ORDER(^LR("BLRA",BPMAPHY))

               IF 'BPMAPHY

                   QUIT 

               Begin DoDot:1

 +9                SET BPMARFL=""

 +10               FOR 

                       SET BPMARFL=$ORDER(^LR("BLRA",BPMAPHY,BPMARFL))

                       IF BPMARFL']""

                           QUIT 

                       Begin DoDot:2

 +11                       SET BPMIDT=""

 +12                       FOR 

                               SET BPMIDT=$ORDER(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT))

                               IF 'BPMIDT

                                   QUIT 

                               Begin DoDot:3

 +13                               SET BPMDFN=0

 +14                               FOR 

                                       SET BPMDFN=$ORDER(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMDFN))

                                       IF 'BPMDFN

                                           QUIT 

                                       Begin DoDot:4

 +15                                       IF BPMDFN'=BPMFM

                                               QUIT 

 +16                                       SET BPMSS=""

 +17                                       SET BPMSS=$ORDER(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMDFN,""))

 +18                                       SET ^TMP("BPMLRA",$JOB,BPMDFN,BPMIDT)=BPMAPHY_U_BPMARFL_U_BPMIDT_U_BPMDFN_U_BPMSS

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +19       QUIT 

 +20      ;

MERGE(BPMFM,BPMTO) ;

 +1       ;----- MERGE ENTRIES

 +2       ;

 +3        NEW BPMAPHY,BPMARFL,DATA,DATE,BPMDFN,BPMIDT,BPMSS

 +4       ;

 +5        SET DATE=0

 +6        FOR 

               SET DATE=$ORDER(^TMP("BPMLRA",$JOB,BPMFM,DATE))

               IF 'DATE

                   QUIT 

               Begin DoDot:1

 +7                SET DATA=^TMP("BPMLRA",$JOB,BPMFM,DATE)

 +8                SET BPMAPHY=$PIECE(DATA,U)

 +9                SET BPMARFL=$PIECE(DATA,U,2)

 +10               SET BPMIDT=$PIECE(DATA,U,3)

 +11               SET BPMDFN=$PIECE(DATA,U,4)

 +12               SET BPMSS=$PIECE(DATA,U,5)

 +13               IF '$DATA(^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMFM))

                       QUIT 

 +14      ;S ^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMTO)=BPMSS

 +15      ; IHS/OIT/MKK - Data structure Change

                   SET ^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMTO,BPMSS)=BPMSS

 +16               KILL ^LR("BLRA",BPMAPHY,BPMARFL,BPMIDT,BPMFM)

 +17               KILL ^TMP("BPMLRA",$JOB,BPMFM,DATE)

               End DoDot:1

 +18      ;

 +19       QUIT 

 +20      ;