- 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