BPMXTAX ;IHS/PHXAO/AEF - REPOINT PT TAXONOMY FILE POINTERS - 6/26/12 ;
;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
; changed namespace from BZXM to BPM
;
DESC ;----- ROUTINE DESCRIPTION
;;
;;BPMXTAX:
;;THIS ROUTINE LOOPS THROUGH EACH ENTRY IN THE PATIENT SUBFILE
;;OF THE PT TAXONOMY FILE AND REPOINTS THE NAME FIELD TO THE
;;SPECIFIED VA PATIENT FILE ENTRY.
;;
;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
;;
;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET U PBY THE PATIENT MERGE
;;SOFTWARE:
;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
;;EXAMPLE:
;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
;;
;;$$END
;
N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END" W !,X
Q
EN(BPMRY) ;EP
;----- MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
;
; BPMRY = TEMP GLOBAL SET UP BY THE PATIENT MERGE SOFTWARE,
; I.E., "^TMP(""XDFROM"",$J)"
;
N BPMFR,BPMTO
;
S BPMFR=$O(@BPMRY@(0))
Q:'BPMFR
S BPMTO=$O(@BPMRY@(BPMFR,0))
Q:'BPMTO
;
D REPOINT(BPMFR,BPMTO)
Q
REPOINT(BPMFR,BPMTO) ;EP
;----- FIND AND REPOINT POINTERS
;
N BPMD0,BPMD1
;
S BPMD0=0
F S BPMD0=$O(^ATXPAT(BPMD0)) Q:'BPMD0 D
. S BPMD1=0
. F S BPMD1=$O(^ATXPAT(BPMD0,11,BPMD1)) Q:'BPMD1 D
. . Q:$P($G(^ATXPAT(BPMD0,11,BPMD1,0)),U)'=BPMFR
. . D ONE(BPMD0,BPMD1,BPMFR,BPMTO)
;
Q
ONE(BPMD0,BPMD1,BPMFR,BPMTO) ;
;----- PROCESS ONE ENTRY
;
N BPMCNT,DA,DD,DIC,DIE,DIK,DINUM,DO,DR,X,Y,BPM02P2
;
S BPMCNT=$P($G(^ATXPAT(BPMD0,11,BPMFR,0)),U,2)+$P($G(^ATXPAT(BPMD0,11,BPMTO,0)),U,2)
;
S DA(1)=BPMD0
S DA=BPMD1
S DIK="^ATXPAT("_DA(1)_",11,"
D ^DIK
;
I '$D(^ATXPAT(BPMD0,11,BPMTO)) D
. S DIC="^ATXPAT("_DA(1)_",11,"
. S DIC(0)=""
. S X=BPMTO
. S DINUM=X
. K DD,DO
. D FILE^DICN
;
Q:'$D(^ATXPAT(BPMD0,11,BPMTO))
;
S BPM02P2=$P($G(^DD(9002227.01101,.02,0)),U,2)
S $P(^DD(9002227.01101,.02,0),U,2)=$TR(BPM02P2,"I","")
;
S DA=BPMTO
S DIE="^ATXPAT("_DA(1)_",11,"
S DR=".02///"_BPMCNT
D ^DIE
;
S $P(^DD(9002227.01101,.02,0),U,2)=BPM02P2
;
Q
BPMXTAX ;IHS/PHXAO/AEF - REPOINT PT TAXONOMY FILE POINTERS - 6/26/12 ;
+1 ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
+2 ;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
+3 ; changed namespace from BZXM to BPM
+4 ;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;BPMXTAX:
+3 ;;THIS ROUTINE LOOPS THROUGH EACH ENTRY IN THE PATIENT SUBFILE
+4 ;;OF THE PT TAXONOMY FILE AND REPOINTS THE NAME FIELD TO THE
+5 ;;SPECIFIED VA PATIENT FILE ENTRY.
+6 ;;
+7 ;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
+8 ;;
+9 ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
+10 ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET U PBY THE PATIENT MERGE
+11 ;;SOFTWARE:
+12 ;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+13 ;;EXAMPLE:
+14 ;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+15 ;;
+16 ;;$$END
+17 ;
+18 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
WRITE !,X
+19 QUIT
EN(BPMRY) ;EP
+1 ;----- MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
+2 ;
+3 ; BPMRY = TEMP GLOBAL SET UP BY THE PATIENT MERGE SOFTWARE,
+4 ; I.E., "^TMP(""XDFROM"",$J)"
+5 ;
+6 NEW BPMFR,BPMTO
+7 ;
+8 SET BPMFR=$ORDER(@BPMRY@(0))
+9 IF 'BPMFR
QUIT
+10 SET BPMTO=$ORDER(@BPMRY@(BPMFR,0))
+11 IF 'BPMTO
QUIT
+12 ;
+13 DO REPOINT(BPMFR,BPMTO)
+14 QUIT
REPOINT(BPMFR,BPMTO) ;EP
+1 ;----- FIND AND REPOINT POINTERS
+2 ;
+3 NEW BPMD0,BPMD1
+4 ;
+5 SET BPMD0=0
+6 FOR
SET BPMD0=$ORDER(^ATXPAT(BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+7 SET BPMD1=0
+8 FOR
SET BPMD1=$ORDER(^ATXPAT(BPMD0,11,BPMD1))
IF 'BPMD1
QUIT
Begin DoDot:2
+9 IF $PIECE($GET(^ATXPAT(BPMD0,11,BPMD1,0)),U)'=BPMFR
QUIT
+10 DO ONE(BPMD0,BPMD1,BPMFR,BPMTO)
End DoDot:2
End DoDot:1
+11 ;
+12 QUIT
ONE(BPMD0,BPMD1,BPMFR,BPMTO) ;
+1 ;----- PROCESS ONE ENTRY
+2 ;
+3 NEW BPMCNT,DA,DD,DIC,DIE,DIK,DINUM,DO,DR,X,Y,BPM02P2
+4 ;
+5 SET BPMCNT=$PIECE($GET(^ATXPAT(BPMD0,11,BPMFR,0)),U,2)+$PIECE($GET(^ATXPAT(BPMD0,11,BPMTO,0)),U,2)
+6 ;
+7 SET DA(1)=BPMD0
+8 SET DA=BPMD1
+9 SET DIK="^ATXPAT("_DA(1)_",11,"
+10 DO ^DIK
+11 ;
+12 IF '$DATA(^ATXPAT(BPMD0,11,BPMTO))
Begin DoDot:1
+13 SET DIC="^ATXPAT("_DA(1)_",11,"
+14 SET DIC(0)=""
+15 SET X=BPMTO
+16 SET DINUM=X
+17 KILL DD,DO
+18 DO FILE^DICN
End DoDot:1
+19 ;
+20 IF '$DATA(^ATXPAT(BPMD0,11,BPMTO))
QUIT
+21 ;
+22 SET BPM02P2=$PIECE($GET(^DD(9002227.01101,.02,0)),U,2)
+23 SET $PIECE(^DD(9002227.01101,.02,0),U,2)=$TRANSLATE(BPM02P2,"I","")
+24 ;
+25 SET DA=BPMTO
+26 SET DIE="^ATXPAT("_DA(1)_",11,"
+27 SET DR=".02///"_BPMCNT
+28 DO ^DIE
+29 ;
+30 SET $PIECE(^DD(9002227.01101,.02,0),U,2)=BPM02P2
+31 ;
+32 QUIT
