BPMXLR ;IHS/PHXAO/AEF - REPOINT LAB DATA - 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 BZXM to BPM
;IHS/OIT/NKD 6/13/2012 Save and restore "AC" x-ref
; Moved processing check from BPMXDRV
;
DESC ;----- ROUTINE DESCRIPTION
;;
;;BPMXLR:
;;THIS ROUTINE RUNS THE ^BLRMERG ROUTINE TO MERGE LAB DATA.
;;
;;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 UP BY 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
;
; BLRFM = PATIENT DFN BEING MERGED FROM
; BLRTO = PATIENT DFN BEING MERGED INTO
;
;IHS/OIT/NKD BPM*1.0*2 QUIT IF BLRMERG NOT INSTALLED
Q:'$L($T(EN^BLRMERG))
;
N BLRFM,BLRNEW,BLROLD,BLRTO,XDRMRG,DA,DIE,DR,X,Y,I,J
;
S BLRFM=$O(@BPMRY@(0))
Q:'BLRFM
S BLRTO=$O(@BPMRY@(BLRFM,0))
Q:'BLRTO
;
S XDRMRG("FR")=BLRFM
S XDRMRG("TO")=BLRTO
S BLROLD=+$G(^DPT(BLRFM,"LR"))
S BLRNEW=+$G(^DPT(BLRTO,"LR"))
Q:'BLROLD&'BLRNEW
;
;If 'from' patient in Lab system but 'to' patient is not, then
;repoint 'from' patient's LR entry to 'to' patient, then quit.
I '+BLRNEW D Q
. S DIE="^LR("
. S DA=BLROLD
. S DR=".03////"_BLRTO
. D ^DIE
;
;IHS/OIT/NKD BPM*1.0*2 STORE VALUES OF "AC" X-REF
I $D(^LRO(68,"AC",BLROLD)) K ^TMP("BPMLR",$J) M ^TMP("BPMLR",$J,68,"AC",BLROLD)=^LRO(68,"AC",BLROLD)
;
D MERGE^BLRMERG
;
;IHS/OIT/NKD BPM*1.0*2 RESTORE VALUES OF "AC" X-REF
I $D(^TMP("BPMLR",$J)) D
. S I=0
. F S I=$O(^LRO(68,"AC",BLRNEW,I)) Q:+I'=I D
. . S J=0
. . F S J=$O(^LRO(68,"AC",BLRNEW,I,J)) Q:+J'=J D
. . . ; QUIT IF X-REF HAS A VALUE
. . . Q:$L(^LRO(68,"AC",BLRNEW,I,J))>0
. . . ; QUIT IF X-REF DID NOT COME FROM BLROLD
. . . Q:'$D(^TMP("BPMLR",$J,68,"AC",BLROLD,I,J))
. . . S ^LRO(68,"AC",BLRNEW,I,J)=$G(^TMP("BPMLR",$J,68,"AC",BLROLD,I,J))
;
;Repoint ^LR("BLRA") ESIG xref in Lab Data file #63
D EN^BPMXLR2(BLRFM,BLRTO)
;
Q
BPMXLR ;IHS/PHXAO/AEF - REPOINT LAB DATA - 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 BZXM to BPM
+4 ;IHS/OIT/NKD 6/13/2012 Save and restore "AC" x-ref
+5 ; Moved processing check from BPMXDRV
+6 ;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;BPMXLR:
+3 ;;THIS ROUTINE RUNS THE ^BLRMERG ROUTINE TO MERGE LAB DATA.
+4 ;;
+5 ;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
+6 ;;
+7 ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
+8 ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT
+9 ;;MERGE SOFTWARE:
+10 ;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+11 ;;EXAMPLE:
+12 ;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+13 ;;
+14 ;;$$END
+15 ;
+16 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
WRITE !,X
+17 QUIT
EN(BPMRY) ;EP
+1 ;----- MAIN ENTRY POINT
+2 ;
+3 ; BLRFM = PATIENT DFN BEING MERGED FROM
+4 ; BLRTO = PATIENT DFN BEING MERGED INTO
+5 ;
+6 ;IHS/OIT/NKD BPM*1.0*2 QUIT IF BLRMERG NOT INSTALLED
+7 IF '$LENGTH($TEXT(EN^BLRMERG))
QUIT
+8 ;
+9 NEW BLRFM,BLRNEW,BLROLD,BLRTO,XDRMRG,DA,DIE,DR,X,Y,I,J
+10 ;
+11 SET BLRFM=$ORDER(@BPMRY@(0))
+12 IF 'BLRFM
QUIT
+13 SET BLRTO=$ORDER(@BPMRY@(BLRFM,0))
+14 IF 'BLRTO
QUIT
+15 ;
+16 SET XDRMRG("FR")=BLRFM
+17 SET XDRMRG("TO")=BLRTO
+18 SET BLROLD=+$GET(^DPT(BLRFM,"LR"))
+19 SET BLRNEW=+$GET(^DPT(BLRTO,"LR"))
+20 IF 'BLROLD&'BLRNEW
QUIT
+21 ;
+22 ;If 'from' patient in Lab system but 'to' patient is not, then
+23 ;repoint 'from' patient's LR entry to 'to' patient, then quit.
+24 IF '+BLRNEW
Begin DoDot:1
+25 SET DIE="^LR("
+26 SET DA=BLROLD
+27 SET DR=".03////"_BLRTO
+28 DO ^DIE
End DoDot:1
QUIT
+29 ;
+30 ;IHS/OIT/NKD BPM*1.0*2 STORE VALUES OF "AC" X-REF
+31 IF $DATA(^LRO(68,"AC",BLROLD))
KILL ^TMP("BPMLR",$JOB)
MERGE ^TMP("BPMLR",$JOB,68,"AC",BLROLD)=^LRO(68,"AC",BLROLD)
+32 ;
+33 DO MERGE^BLRMERG
+34 ;
+35 ;IHS/OIT/NKD BPM*1.0*2 RESTORE VALUES OF "AC" X-REF
+36 IF $DATA(^TMP("BPMLR",$JOB))
Begin DoDot:1
+37 SET I=0
+38 FOR
SET I=$ORDER(^LRO(68,"AC",BLRNEW,I))
IF +I'=I
QUIT
Begin DoDot:2
+39 SET J=0
+40 FOR
SET J=$ORDER(^LRO(68,"AC",BLRNEW,I,J))
IF +J'=J
QUIT
Begin DoDot:3
+41 ; QUIT IF X-REF HAS A VALUE
+42 IF $LENGTH(^LRO(68,"AC",BLRNEW,I,J))>0
QUIT
+43 ; QUIT IF X-REF DID NOT COME FROM BLROLD
+44 IF '$DATA(^TMP("BPMLR",$JOB,68,"AC",BLROLD,I,J))
QUIT
+45 SET ^LRO(68,"AC",BLRNEW,I,J)=$GET(^TMP("BPMLR",$JOB,68,"AC",BLROLD,I,J))
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 ;Repoint ^LR("BLRA") ESIG xref in Lab Data file #63
+48 DO EN^BPMXLR2(BLRFM,BLRTO)
+49 ;
+50 QUIT
