BLRMERGT ; IHS/ISD/EDE - MANUAL PROCESS MERGE BLRMERG ; [ 12/21/1998 3:56 PM ]
;;5.2;BLR;**1005,1030**;NOV 01, 1997
;
; NOTE: This routine was originally just for testing. It has been
; modified to work correctly for merging Lab Data since previous
; versions of the Lab Merge routines would sometimes fail during
; the merge.
;
START ;
S DIC=2,DIC(0)="AQEM",DIC("A")="Select Patient to be PURGED: " D ^DIC Q:+Y<1 S BLRP1=+Y
I '$D(^DPT(+Y,"LR")) W !,"This patient has no lab data to purge. ",!! G START
S DIC=2,DIC(0)="AQEM",DIC("A")="Select Patient to RECEIVE lab data: " D ^DIC Q:+Y<1 S BLRP2=+Y
OK W !,"Is everything OK" S %=2 D YN^DICN Q:%<0 W:%=0 !,"Answer NO if you are unsure, or '^' to quit.",! G:%=0 OK
I %=2 G START
W !!,"This will take about one minute..."
S XDRMRG("FR")=BLRP1,XDRMRG("TO")=BLRP2
K ^TMP("XDRMRGFR",$J)
K ^TMP("XDRMRGTO",$J)
S ^TMP("XDRMRGFR",$J,XDRMRG("FR"),"LR")=^DPT(BLRP1,"LR")
; S:$D(^DPT(P2,"LR")) ^TMP("XDRMRGTO",$J,XDRMRG("TO"),"LR")=^DPT(BLRP2,"LR")
; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1030 -- Fix ^DPT(P2 typo
S:$D(^DPT(BLRP2,"LR")) ^TMP("XDRMRGTO",$J,XDRMRG("TO"),"LR")=^DPT(BLRP2,"LR")
; ----- END IHS/OIT/MKK -- LR*5.2*1030
D ^BLRMERG
W !!,"Done..." H 2
Q
;
TEST ; EP -- LR*5.2*1030 Note: OLD, DEAD CODE -- All lines commented out
; D SETDPT
; S XDRMRG("FR")=222
; S XDRMRG("TO")=333
; S ^TMP("XDRMRGFR",$J,XDRMRG("FR"),"LR")=^DPT(222,"LR")
; S ^TMP("XDRMRGTO",$J,XDRMRG("TO"),"LR")=^DPT(333,"LR")
; D ^BLRMERG
Q
;
SETDPT ; SET ^DPT "LR" NODES -- LR*5.2*1030 Note: OLD, DEAD CODE -- All lines commented out
; S ^DPT(222,"LR")=8
;;S ^DPT(222,"LR")=10
; S ^DPT(333,"LR")=9
Q
;
; ======================================================================
; Two LRDFNs point to SAME Patient. Merge the Lab Data
;
; Note that this routine should only be run in programmer mode by
; a person extremely knowledgeable with the RPMS Lab Module.
TWOLRDFN ; EP
NEW LRDFN1,LRDFN2,DPTIEN,FIXLRDFN,QFLG
W !!
D ^XBFMK
S DIR(0)="PO^63"
S DIR("A")="FROM LRDFN"
D ^DIR
I +$G(Y)<1 D Q
. W !,"No or invalid Entry. Routine Stops.",!!
;
S LRDFN1=+$G(Y)
;
W !!
D ^XBFMK
S DIR(0)="PO^63"
S DIR("A")="TO LRDFN"
D ^DIR
I +$G(Y)<1 D Q
. W !,"No or invalid Entry. Routine Stops.",!!
;
S (FIXLRDFN,LRDFN2)=+$G(Y)
;
W !!
D ^XBFMK
S DIR(0)="NO"
S DIR("A")="DPT IEN"
D ^DIR
I +$G(Y)<1 D Q
. W !,"No or invalid entry. Routine Stops.",!!
;
S DPTIEN=+$G(Y)
;
W !!,"Variables Setup:",!
W ?5,"FROM LRDFN:",LRDFN1,!
W ?5,"TO LRDFN:",LRDFN2,!
W ?5,"DPT IEN:",DPTIEN,!
D ^XBFMK
S DIR(0)="Y"
S DIR("A")="Continue"
S DIR("B")="NO"
D ^DIR
I +$G(Y)<1 D Q
. W !,"NO or invalid entry. Routine Stops.",!!
;
S XDRMRG("FR")=DPTIEN
S XDRMRG("TO")=DPTIEN
K ^TMP("XDRMRGFR",$J)
K ^TMP("XDRMRGTO",$J)
S ^TMP("XDRMRGFR",$J,XDRMRG("FR"),"LR")=LRDFN1
S ^TMP("XDRMRGTO",$J,XDRMRG("TO"),"LR")=LRDFN2
;
D ^BLRMERG
;
S:$G(^DPT(DPTIEN,"LR"))="" ^DPT(DPTIEN,"LR")=FIXLRDFN
Q
; ----- END IHS/OIT/MKK -- LR*5.2*1030
;
WALTCHEK ; EP
;This SubRtn checks for BAD Ptrs in ^LR subsequent to PtMerge processes
;This Rtn does not change anything currently... it just displays.
NEW CNT,CNTIEN,IEN,TOIEN,LRIEN,LRREC,PTR,MREC
S (CNT,CNTIEN,IEN)=0
F S IEN=$O(^DPT(IEN)) Q:'IEN D
. S CNTIEN=CNTIEN+1
. W:CNT<1 $$LJ^XLFSTR(CNTIEN,20),$C(13)
. ;
. S TOIEN=$G(^DPT(IEN,-9)) ;-9 indicates this record has been merged.
. I TOIEN D ;if it has a value it has the 'to' pointer
.. S LRIEN=$G(^DPT(TOIEN,"LR")) ;get the Lab Ptr
.. I LRIEN D ;If the Ptr exists
... S LRREC=$G(^LR(LRIEN,0)) ;attempt to get the record
... I LRREC D ;If the Lab record exists
.... I $P(LRREC,U,3)'=TOIEN D
..... S PTR=$P(LRREC,U,3)_";DPT(" ;setup to get date merged
..... S MREC=$O(^XDRM("B",PTR,0)) ;ditto
..... W !!,"Merged On:",$P(^XDRM(MREC,0),U,3)," PatNam= ",$P(^DPT(IEN,0),"^",1)
..... W !," ^DPT(",IEN,",-9) PointsTo:",TOIEN," the DPT 'LR' Ptr=",LRIEN
..... W !," LR ptr Back To DPT=",$P(LRREC,U,3)," it should be->",TOIEN
..... S CNT=CNT+1
;
W !!,"Total Number of ^DPT IENs = ",CNTIEN,!
W !,?5,"# of BAD ^LR Ptrs = ",CNT,!!
Q
BLRMERGT ; IHS/ISD/EDE - MANUAL PROCESS MERGE BLRMERG ; [ 12/21/1998 3:56 PM ]
+1 ;;5.2;BLR;**1005,1030**;NOV 01, 1997
+2 ;
+3 ; NOTE: This routine was originally just for testing. It has been
+4 ; modified to work correctly for merging Lab Data since previous
+5 ; versions of the Lab Merge routines would sometimes fail during
+6 ; the merge.
+7 ;
START ;
+1 SET DIC=2
SET DIC(0)="AQEM"
SET DIC("A")="Select Patient to be PURGED: "
DO ^DIC
IF +Y<1
QUIT
SET BLRP1=+Y
+2 IF '$DATA(^DPT(+Y,"LR"))
WRITE !,"This patient has no lab data to purge. ",!!
GOTO START
+3 SET DIC=2
SET DIC(0)="AQEM"
SET DIC("A")="Select Patient to RECEIVE lab data: "
DO ^DIC
IF +Y<1
QUIT
SET BLRP2=+Y
OK WRITE !,"Is everything OK"
SET %=2
DO YN^DICN
IF %<0
QUIT
IF %=0
WRITE !,"Answer NO if you are unsure, or '^' to quit.",!
IF %=0
GOTO OK
+1 IF %=2
GOTO START
+2 WRITE !!,"This will take about one minute..."
+3 SET XDRMRG("FR")=BLRP1
SET XDRMRG("TO")=BLRP2
+4 KILL ^TMP("XDRMRGFR",$JOB)
+5 KILL ^TMP("XDRMRGTO",$JOB)
+6 SET ^TMP("XDRMRGFR",$JOB,XDRMRG("FR"),"LR")=^DPT(BLRP1,"LR")
+7 ; S:$D(^DPT(P2,"LR")) ^TMP("XDRMRGTO",$J,XDRMRG("TO"),"LR")=^DPT(BLRP2,"LR")
+8 ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1030 -- Fix ^DPT(P2 typo
+9 IF $DATA(^DPT(BLRP2,"LR"))
SET ^TMP("XDRMRGTO",$JOB,XDRMRG("TO"),"LR")=^DPT(BLRP2,"LR")
+10 ; ----- END IHS/OIT/MKK -- LR*5.2*1030
+11 DO ^BLRMERG
+12 WRITE !!,"Done..."
HANG 2
+13 QUIT
+14 ;
TEST ; EP -- LR*5.2*1030 Note: OLD, DEAD CODE -- All lines commented out
+1 ; D SETDPT
+2 ; S XDRMRG("FR")=222
+3 ; S XDRMRG("TO")=333
+4 ; S ^TMP("XDRMRGFR",$J,XDRMRG("FR"),"LR")=^DPT(222,"LR")
+5 ; S ^TMP("XDRMRGTO",$J,XDRMRG("TO"),"LR")=^DPT(333,"LR")
+6 ; D ^BLRMERG
+7 QUIT
+8 ;
SETDPT ; SET ^DPT "LR" NODES -- LR*5.2*1030 Note: OLD, DEAD CODE -- All lines commented out
+1 ; S ^DPT(222,"LR")=8
+2 ;;S ^DPT(222,"LR")=10
+3 ; S ^DPT(333,"LR")=9
+4 QUIT
+5 ;
+6 ; ======================================================================
+7 ; Two LRDFNs point to SAME Patient. Merge the Lab Data
+8 ;
+9 ; Note that this routine should only be run in programmer mode by
+10 ; a person extremely knowledgeable with the RPMS Lab Module.
TWOLRDFN ; EP
+1 NEW LRDFN1,LRDFN2,DPTIEN,FIXLRDFN,QFLG
+2 WRITE !!
+3 DO ^XBFMK
+4 SET DIR(0)="PO^63"
+5 SET DIR("A")="FROM LRDFN"
+6 DO ^DIR
+7 IF +$GET(Y)<1
Begin DoDot:1
+8 WRITE !,"No or invalid Entry. Routine Stops.",!!
End DoDot:1
QUIT
+9 ;
+10 SET LRDFN1=+$GET(Y)
+11 ;
+12 WRITE !!
+13 DO ^XBFMK
+14 SET DIR(0)="PO^63"
+15 SET DIR("A")="TO LRDFN"
+16 DO ^DIR
+17 IF +$GET(Y)<1
Begin DoDot:1
+18 WRITE !,"No or invalid Entry. Routine Stops.",!!
End DoDot:1
QUIT
+19 ;
+20 SET (FIXLRDFN,LRDFN2)=+$GET(Y)
+21 ;
+22 WRITE !!
+23 DO ^XBFMK
+24 SET DIR(0)="NO"
+25 SET DIR("A")="DPT IEN"
+26 DO ^DIR
+27 IF +$GET(Y)<1
Begin DoDot:1
+28 WRITE !,"No or invalid entry. Routine Stops.",!!
End DoDot:1
QUIT
+29 ;
+30 SET DPTIEN=+$GET(Y)
+31 ;
+32 WRITE !!,"Variables Setup:",!
+33 WRITE ?5,"FROM LRDFN:",LRDFN1,!
+34 WRITE ?5,"TO LRDFN:",LRDFN2,!
+35 WRITE ?5,"DPT IEN:",DPTIEN,!
+36 DO ^XBFMK
+37 SET DIR(0)="Y"
+38 SET DIR("A")="Continue"
+39 SET DIR("B")="NO"
+40 DO ^DIR
+41 IF +$GET(Y)<1
Begin DoDot:1
+42 WRITE !,"NO or invalid entry. Routine Stops.",!!
End DoDot:1
QUIT
+43 ;
+44 SET XDRMRG("FR")=DPTIEN
+45 SET XDRMRG("TO")=DPTIEN
+46 KILL ^TMP("XDRMRGFR",$JOB)
+47 KILL ^TMP("XDRMRGTO",$JOB)
+48 SET ^TMP("XDRMRGFR",$JOB,XDRMRG("FR"),"LR")=LRDFN1
+49 SET ^TMP("XDRMRGTO",$JOB,XDRMRG("TO"),"LR")=LRDFN2
+50 ;
+51 DO ^BLRMERG
+52 ;
+53 IF $GET(^DPT(DPTIEN,"LR"))=""
SET ^DPT(DPTIEN,"LR")=FIXLRDFN
+54 QUIT
+55 ; ----- END IHS/OIT/MKK -- LR*5.2*1030
+56 ;
WALTCHEK ; EP
+1 ;This SubRtn checks for BAD Ptrs in ^LR subsequent to PtMerge processes
+2 ;This Rtn does not change anything currently... it just displays.
+3 NEW CNT,CNTIEN,IEN,TOIEN,LRIEN,LRREC,PTR,MREC
+4 SET (CNT,CNTIEN,IEN)=0
+5 FOR
SET IEN=$ORDER(^DPT(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 SET CNTIEN=CNTIEN+1
+7 IF CNT<1
WRITE $$LJ^XLFSTR(CNTIEN,20),$CHAR(13)
+8 ;
+9 ;-9 indicates this record has been merged.
SET TOIEN=$GET(^DPT(IEN,-9))
+10 ;if it has a value it has the 'to' pointer
IF TOIEN
Begin DoDot:2
+11 ;get the Lab Ptr
SET LRIEN=$GET(^DPT(TOIEN,"LR"))
+12 ;If the Ptr exists
IF LRIEN
Begin DoDot:3
+13 ;attempt to get the record
SET LRREC=$GET(^LR(LRIEN,0))
+14 ;If the Lab record exists
IF LRREC
Begin DoDot:4
+15 IF $PIECE(LRREC,U,3)'=TOIEN
Begin DoDot:5
+16 ;setup to get date merged
SET PTR=$PIECE(LRREC,U,3)_";DPT("
+17 ;ditto
SET MREC=$ORDER(^XDRM("B",PTR,0))
+18 WRITE !!,"Merged On:",$PIECE(^XDRM(MREC,0),U,3)," PatNam= ",$PIECE(^DPT(IEN,0),"^",1)
+19 WRITE !," ^DPT(",IEN,",-9) PointsTo:",TOIEN," the DPT 'LR' Ptr=",LRIEN
+20 WRITE !," LR ptr Back To DPT=",$PIECE(LRREC,U,3)," it should be->",TOIEN
+21 SET CNT=CNT+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 WRITE !!,"Total Number of ^DPT IENs = ",CNTIEN,!
+24 WRITE !,?5,"# of BAD ^LR Ptrs = ",CNT,!!
+25 QUIT
