- 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 ;
