BLRMERGT.m

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