- 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
