BLRMERG2 ; IHS/TUCSON/DG/ANMC/CLS/ISD/EDE - LAB MERGE ROUTINE [ 12/21/1998 3:55 PM ]
;;5.2;LR;**1005,1022,1024**;May 02, 2008
;
;Variables:
; BLROLD=from patient's LR ien
; BLRNEW=to patient's LR ien
; BLRQ=quit flag
; BLRSUB=accession area subscript
; BLRDINVDT=subfile entry ien within BLRSUB in ^LR(BLROLD,
; BLRAIEN=accession area ien in file 68 ^LRO(68,
; BLRDTSUB=date subscript in ^LRO(68, within accession area, ^LRO(69,
;
START ;
D PREMERGE
D MERGE
D BULLT
Q
;
PREMERGE ; PREMERGE CHECK
; Check to see if any "From" patient nodes have same collection
; date/time as "To" patient nodes, if they do, then uptick by one
; second until date/time unique for both "From" and "To" patients.
;
F BLRSUB="CH","BB","MI","CY","SP","EM" D
. S BLRINVDT=0
. F S BLRINVDT=$O(^LR(BLROLD,BLRSUB,BLRINVDT)) Q:BLRINVDT'=+BLRINVDT I $D(^LR(BLRNEW,BLRSUB,BLRINVDT)) D SHIFT
. Q
Q
;
SHIFT ; MAKE DATE/TIME UNIQUE FOR BOTH PATIENTS (SUBSCRIPT)
S (BLRODT,BLRNDT)=+^LR(BLROLD,BLRSUB,BLRINVDT,0)
D SHIFT2 ; find inverse date slot
D CHG68 ; chg accession file
D CHG69 ; chg order entry file
; chg .01 field value
S $P(^LR(BLROLD,BLRSUB,BLRNINVD,0),U)=BLRNDT ; chg .01 field
S BLROGBL="^LR(BLROLD,BLRSUB,BLRINVDT)" ;set gbl root of old entry
; copy old gbl entries to new gbl entries (by inverse date)
F S BLROGBL=$Q(@BLROGBL) Q:+$P(BLROGBL,",",3)'=BLRINVDT D
. S BLRNGBL=$P(BLROGBL,BLRINVDT)_BLRNINVD_$P(BLROGBL,BLRINVDT,2)
. S @BLRNGBL=@BLROGBL
. Q
S $P(^LR(BLROLD,BLRSUB,0),U,3,4)=BLRNINVD_"^"_($P($G(^LR(BLROLD,BLRSUB,0)),U,4)+1) ;PHXAO/AEF ADDED $G TO PREVENT <UNDEFINED>SHIFT+13^BLRMERG2 ERROR
; delete old ^LR entry
S DA(1)=BLROLD,DA=BLRINVDT,DIK="^LR("_BLROLD_","""_BLRSUB_"""," D DIK^BLRMERGU
; set xrefs for new entry
S DA(1)=BLROLD,DA=BLRNINVD,DIK="^LR("_BLROLD_","""_BLRSUB_"""," D IX1^BLRMERGU
Q
;
SHIFT2 ; FIND INVERSE DATE/TIME SLOT
; Up by .000001 old date/time variable, check if $D(BLRODT+.000001)
; "From" patient, if it does exist, up by another .000001, check
; again, if okay, check to see if the "To" patient has this date/time
;
F S BLRNDT=BLRNDT+.000001,BLRNINVD=9999999-BLRNDT I '$D(^LR(BLROLD,BLRSUB,BLRNINVD)),'$D(^LR(BLRNEW,BLRSUB,BLRNINVD)) Q
Q
;
CHG68 ; Changes INVERSE DATE field (^DD(68.01,13.5,0)) value
D SETVARS^BLRMERGU
Q:'BLRAIEN ;PHXAO/AEF - NEW LINE TO PREVENT <SUBSCRIPT> ERROR
Q:'BLRDTSUB ;PHXAO/AEF - NEW LINE TO PREVENT <SUBSCRIPT> ERROR
Q:'$D(^LRO(68,BLRAIEN,1,BLRDTSUB))
S DIE="^LRO(68,BLRAIEN,1,BLRDTSUB,1,",DA(2)=BLRAIEN,DA(1)=BLRDTSUB,DA=BLRNUM,DR="13.5////"_BLRNINVD
D DIE^BLRMERGU
Q
;
CHG69 ; Changes DATE(TIME) COLLECTION field (^DD(69.01,10,0)) value
; the following code not for CY,SP,EM,AU because they do not have
; a .1 node, which points to file 69 (Order).
I BLRSUB'="CH",BLRSUB'="BB",BLRSUB'="MI" Q
S BLRDATE=$P(+^LR(BLROLD,BLRSUB,BLRINVDT,0),"."),BLRACC=$P(^(0),U,6),BLRNUM=$P(BLRACC," ",3),BLRAIEN=$O(^LRO(68,"B",$P(BLRACC," "),""))
Q:'$G(BLRAIEN) ;PHXAO/AEF - ADDED NEW LINE TO PREVENT <SUBSCRIPT>CHG69+5^BLRMERG2 ERROR
Q:'$D(^LRO(68,BLRAIEN,1,BLRDATE))
S BLRORDN=$G(^LRO(68,BLRAIEN,1,BLRDATE,1,BLRNUM,.1)) ;PHXAO/AEF - ADDED $G TO PREVENT <UNDEFINED> ERROR
Q:'BLRORDN ; quit if no order #
S BLRSPECN=0
F S BLRSPECN=$O(^LRO(69,"C",BLRORDN,BLRDATE,BLRSPECN)) Q:'BLRSPECN D
. Q:+$G(^LRO(69,BLRDATE,1,BLRSPECN,1))'=BLRODT ;PHXAO/AEF - ADDED $G TO PREVENT <UNDEFINED> ERROR
. S DA(1)=BLRDATE,DA=BLRSPECN,DR="10////"_BLRNDT,DIE="^LRO(69,BLRDATE,1,"
. D DIE^BLRMERGU
. Q
Q
;
MERGE ;TRANSFER ^LR ENTRIES FROM OLD TO NEW
F BLRSUB="CH","BB","MI","CY","SP","EM" D
. S BLROGBL="^LR(BLROLD,BLRSUB)" ;set gbl root of old entry
. Q:'$D(^LR(BLROLD,BLRSUB)) ; quit if no old nodes to copy
. ; copy old gbl entries to new gbl entries (by accession area)
. F S BLROGBL=$Q(@BLROGBL) Q:$P($P(BLROGBL,",",2),"""",2)'=BLRSUB D
.. S BLRNGBL="^LR("_BLRNEW_","""_BLRSUB_$P(BLROGBL,BLRSUB,2,999) ;PHXAO/AEF - REPLACED 2) WITH 2,999) TO PREVENT <SYNTAX> ERROR WHEN SUBSCRIPT CONTAINS MORE THAN ONE CH
.. S @BLRNGBL=@BLROGBL
.. Q
. ; set piece 3 & 4 of 0th node
. NEW C,L,X,Y
. S (C,L,Y)=0
. F S Y=$O(^LR(BLRNEW,BLRSUB,Y)) Q:'Y S C=C+1,L=Y
. S X=^LR(BLRNEW,BLRSUB,0)
. S X=$P(X,U,1,2)_U_L_U_C
. S ^LR(BLRNEW,BLRSUB,0)=X
. ; set xrefs for new entries
. S BLRINVD=0
. F S BLRINVDT=$O(^LR(BLRNEW,BLRSUB,BLRINVDT)) Q:'BLRINVDT D
.. S DA(1)=BLRNEW,DA=BLRINVDT,DIK="^LR("_BLRNEW_","""_BLRSUB_""","
.. D IX1^BLRMERGU
.. Q
. Q
I $D(^LR(BLROLD,"AU")) D ; set autopsy xrefs
. S BLRSTKL="S" D AUTXREF ; set xrefs for new entry
. S BLRSTKL="K" D AUTXREF ; kill xrefs for old entry
. Q
; copy other old gbl entries to new gbl entries
S BLRSUB=0
F S BLRSUB=$O(^LR(BLROLD,BLRSUB)) Q:BLRSUB="" D
. I BLRSUB'="CH",BLRSUB'="BB",BLRSUB'="MI",BLRSUB'="CY",BLRSUB'="SP",BLRSUB'="EM"
. E Q ; quit if BLRSUB already moved
. I ($D(^LR(BLROLD,BLRSUB))#10) S ^LR(BLRNEW,BLRSUB)=^LR(BLROLD,BLRSUB)
. S BLROGBL="^LR(BLROLD,BLRSUB)" ;set gbl root of old entry
. ; copy old gbl entries to new gbl entries (by accession area)
. F S BLROGBL=$Q(@BLROGBL) Q:$P($P(BLROGBL,",",2),"""",2)'=BLRSUB D
.. S BLRNGBL="^LR("_BLRNEW_","""_BLRSUB_$P(BLROGBL,BLRSUB,2)
.. S @BLRNGBL=@BLROGBL
.. Q
. Q
; delete old LR entry from ^LR(
S DIK="^LR(",DA=BLROLD D DIK^BLRMERGU ; removes old LRDFN entry in ^LR
I $D(^LAC("LRAC",BLROLD)) S DA=BLROLD,DIK="^LAC(""LRAC""," D DIK^BLRMERGU ; removes entry in cumulative file, 64.7 for old LRDFN
K ^DPT(BLRFM,"LR") ; remove LR pointer from ^DPT on old pat
Q
;
AUTXREF ; KILL/SET AUTOPSY X-REFS IN FILE 63 FIELDS 11 AND 14
I BLRSTKL="S" S DA=BLRNEW I 1
E S DA=BLROLD
D FLD11
D FLD14
Q
;
FLD11 ; KILL/SET "AAU" XREF FROM FILE 63 FIELD 11
S X=$P($G(^LR(DA,"AU")),U)
Q:X="" ; quit if field 11 not valued
D ^XBGXREFS(63,11,.BLRXREF)
S BLRN=0
F S BLRN=$O(BLRXREF(11,BLRN)) Q:'BLRN X BLRXREF(11,BLRN,BLRSTKL)
K BLRXREF
Q
;
FLD14 ; KILL/SET "AAUA" XREF FROM FILE 63 FIELD 14
S X=$P($G(^LR(DA,"AU")),U,6)
Q:X="" ; quit if field 14 not valued
D ^XBGXREFS(63,14,.BLRXREF)
S BLRN=0
F S BLRN=$O(BLRXREF(14,BLRN)) Q:'BLRN X BLRXREF(14,BLRN,BLRSTKL)
K BLRXREF
Q
;
BULLT ; Send bulletin re: reprinting of cumulative report
S BLRDUZ=DUZ,DUZ=.5
S XMB(1)=BLROLD
S XMB(2)=BLRNEW
S XMB(3)=$P(^DPT(BLRFM,0),U)
S XMB(4)=$P(^DPT(BLRTO,0),U)
I $G(DUZ(2)) S XMB(5)=$P($G(^AUPNPAT(BLRFM,41,DUZ(2),0)),U,2)
I $G(XMB(5))
E S XMB(5)="NOT INDICATED"
I $G(DUZ(2)) S XMB(6)=$P($G(^AUPNPAT(BLRTO,41,DUZ(2),0)),U,2)
I $G(XMB(6))
E S XMB(6)="NOT INDICATED"
S XMB="BLR LAB PATIENT MERGE"
D ^XMB
S DUZ=BLRDUZ
D EN^XBVK("XMB") ; kill off mail variables
K Y1,XMDT
Q
BLRMERG2 ; IHS/TUCSON/DG/ANMC/CLS/ISD/EDE - LAB MERGE ROUTINE [ 12/21/1998 3:55 PM ]
+1 ;;5.2;LR;**1005,1022,1024**;May 02, 2008
+2 ;
+3 ;Variables:
+4 ; BLROLD=from patient's LR ien
+5 ; BLRNEW=to patient's LR ien
+6 ; BLRQ=quit flag
+7 ; BLRSUB=accession area subscript
+8 ; BLRDINVDT=subfile entry ien within BLRSUB in ^LR(BLROLD,
+9 ; BLRAIEN=accession area ien in file 68 ^LRO(68,
+10 ; BLRDTSUB=date subscript in ^LRO(68, within accession area, ^LRO(69,
+11 ;
START ;
+1 DO PREMERGE
+2 DO MERGE
+3 DO BULLT
+4 QUIT
+5 ;
PREMERGE ; PREMERGE CHECK
+1 ; Check to see if any "From" patient nodes have same collection
+2 ; date/time as "To" patient nodes, if they do, then uptick by one
+3 ; second until date/time unique for both "From" and "To" patients.
+4 ;
+5 FOR BLRSUB="CH","BB","MI","CY","SP","EM"
Begin DoDot:1
+6 SET BLRINVDT=0
+7 FOR
SET BLRINVDT=$ORDER(^LR(BLROLD,BLRSUB,BLRINVDT))
IF BLRINVDT'=+BLRINVDT
QUIT
IF $DATA(^LR(BLRNEW,BLRSUB,BLRINVDT))
DO SHIFT
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
SHIFT ; MAKE DATE/TIME UNIQUE FOR BOTH PATIENTS (SUBSCRIPT)
+1 SET (BLRODT,BLRNDT)=+^LR(BLROLD,BLRSUB,BLRINVDT,0)
+2 ; find inverse date slot
DO SHIFT2
+3 ; chg accession file
DO CHG68
+4 ; chg order entry file
DO CHG69
+5 ; chg .01 field value
+6 ; chg .01 field
SET $PIECE(^LR(BLROLD,BLRSUB,BLRNINVD,0),U)=BLRNDT
+7 ;set gbl root of old entry
SET BLROGBL="^LR(BLROLD,BLRSUB,BLRINVDT)"
+8 ; copy old gbl entries to new gbl entries (by inverse date)
+9 FOR
SET BLROGBL=$QUERY(@BLROGBL)
IF +$PIECE(BLROGBL,",",3)'=BLRINVDT
QUIT
Begin DoDot:1
+10 SET BLRNGBL=$PIECE(BLROGBL,BLRINVDT)_BLRNINVD_$PIECE(BLROGBL,BLRINVDT,2)
+11 SET @BLRNGBL=@BLROGBL
+12 QUIT
End DoDot:1
+13 ;PHXAO/AEF ADDED $G TO PREVENT <UNDEFINED>SHIFT+13^BLRMERG2 ERROR
SET $PIECE(^LR(BLROLD,BLRSUB,0),U,3,4)=BLRNINVD_"^"_($PIECE($GET(^LR(BLROLD,BLRSUB,0)),U,4)+1)
+14 ; delete old ^LR entry
+15 SET DA(1)=BLROLD
SET DA=BLRINVDT
SET DIK="^LR("_BLROLD_","""_BLRSUB_""","
DO DIK^BLRMERGU
+16 ; set xrefs for new entry
+17 SET DA(1)=BLROLD
SET DA=BLRNINVD
SET DIK="^LR("_BLROLD_","""_BLRSUB_""","
DO IX1^BLRMERGU
+18 QUIT
+19 ;
SHIFT2 ; FIND INVERSE DATE/TIME SLOT
+1 ; Up by .000001 old date/time variable, check if $D(BLRODT+.000001)
+2 ; "From" patient, if it does exist, up by another .000001, check
+3 ; again, if okay, check to see if the "To" patient has this date/time
+4 ;
+5 FOR
SET BLRNDT=BLRNDT+.000001
SET BLRNINVD=9999999-BLRNDT
IF '$DATA(^LR(BLROLD,BLRSUB,BLRNINVD))
IF '$DATA(^LR(BLRNEW,BLRSUB,BLRNINVD))
QUIT
+6 QUIT
+7 ;
CHG68 ; Changes INVERSE DATE field (^DD(68.01,13.5,0)) value
+1 DO SETVARS^BLRMERGU
+2 ;PHXAO/AEF - NEW LINE TO PREVENT <SUBSCRIPT> ERROR
IF 'BLRAIEN
QUIT
+3 ;PHXAO/AEF - NEW LINE TO PREVENT <SUBSCRIPT> ERROR
IF 'BLRDTSUB
QUIT
+4 IF '$DATA(^LRO(68,BLRAIEN,1,BLRDTSUB))
QUIT
+5 SET DIE="^LRO(68,BLRAIEN,1,BLRDTSUB,1,"
SET DA(2)=BLRAIEN
SET DA(1)=BLRDTSUB
SET DA=BLRNUM
SET DR="13.5////"_BLRNINVD
+6 DO DIE^BLRMERGU
+7 QUIT
+8 ;
CHG69 ; Changes DATE(TIME) COLLECTION field (^DD(69.01,10,0)) value
+1 ; the following code not for CY,SP,EM,AU because they do not have
+2 ; a .1 node, which points to file 69 (Order).
+3 IF BLRSUB'="CH"
IF BLRSUB'="BB"
IF BLRSUB'="MI"
QUIT
+4 SET BLRDATE=$PIECE(+^LR(BLROLD,BLRSUB,BLRINVDT,0),".")
SET BLRACC=$PIECE(^(0),U,6)
SET BLRNUM=$PIECE(BLRACC," ",3)
SET BLRAIEN=$ORDER(^LRO(68,"B",$PIECE(BLRACC," "),""))
+5 ;PHXAO/AEF - ADDED NEW LINE TO PREVENT <SUBSCRIPT>CHG69+5^BLRMERG2 ERROR
IF '$GET(BLRAIEN)
QUIT
+6 IF '$DATA(^LRO(68,BLRAIEN,1,BLRDATE))
QUIT
+7 ;PHXAO/AEF - ADDED $G TO PREVENT <UNDEFINED> ERROR
SET BLRORDN=$GET(^LRO(68,BLRAIEN,1,BLRDATE,1,BLRNUM,.1))
+8 ; quit if no order #
IF 'BLRORDN
QUIT
+9 SET BLRSPECN=0
+10 FOR
SET BLRSPECN=$ORDER(^LRO(69,"C",BLRORDN,BLRDATE,BLRSPECN))
IF 'BLRSPECN
QUIT
Begin DoDot:1
+11 ;PHXAO/AEF - ADDED $G TO PREVENT <UNDEFINED> ERROR
IF +$GET(^LRO(69,BLRDATE,1,BLRSPECN,1))'=BLRODT
QUIT
+12 SET DA(1)=BLRDATE
SET DA=BLRSPECN
SET DR="10////"_BLRNDT
SET DIE="^LRO(69,BLRDATE,1,"
+13 DO DIE^BLRMERGU
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
MERGE ;TRANSFER ^LR ENTRIES FROM OLD TO NEW
+1 FOR BLRSUB="CH","BB","MI","CY","SP","EM"
Begin DoDot:1
+2 ;set gbl root of old entry
SET BLROGBL="^LR(BLROLD,BLRSUB)"
+3 ; quit if no old nodes to copy
IF '$DATA(^LR(BLROLD,BLRSUB))
QUIT
+4 ; copy old gbl entries to new gbl entries (by accession area)
+5 FOR
SET BLROGBL=$QUERY(@BLROGBL)
IF $PIECE($PIECE(BLROGBL,",",2),"""",2)'=BLRSUB
QUIT
Begin DoDot:2
+6 ;PHXAO/AEF - REPLACED 2) WITH 2,999) TO PREVENT <SYNTAX> ERROR WHEN SUBSCRIPT CONTAINS MORE THAN ONE CH
SET BLRNGBL="^LR("_BLRNEW_","""_BLRSUB_$PIECE(BLROGBL,BLRSUB,2,999)
+7 SET @BLRNGBL=@BLROGBL
+8 QUIT
End DoDot:2
+9 ; set piece 3 & 4 of 0th node
+10 NEW C,L,X,Y
+11 SET (C,L,Y)=0
+12 FOR
SET Y=$ORDER(^LR(BLRNEW,BLRSUB,Y))
IF 'Y
QUIT
SET C=C+1
SET L=Y
+13 SET X=^LR(BLRNEW,BLRSUB,0)
+14 SET X=$PIECE(X,U,1,2)_U_L_U_C
+15 SET ^LR(BLRNEW,BLRSUB,0)=X
+16 ; set xrefs for new entries
+17 SET BLRINVD=0
+18 FOR
SET BLRINVDT=$ORDER(^LR(BLRNEW,BLRSUB,BLRINVDT))
IF 'BLRINVDT
QUIT
Begin DoDot:2
+19 SET DA(1)=BLRNEW
SET DA=BLRINVDT
SET DIK="^LR("_BLRNEW_","""_BLRSUB_""","
+20 DO IX1^BLRMERGU
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 ; set autopsy xrefs
IF $DATA(^LR(BLROLD,"AU"))
Begin DoDot:1
+24 ; set xrefs for new entry
SET BLRSTKL="S"
DO AUTXREF
+25 ; kill xrefs for old entry
SET BLRSTKL="K"
DO AUTXREF
+26 QUIT
End DoDot:1
+27 ; copy other old gbl entries to new gbl entries
+28 SET BLRSUB=0
+29 FOR
SET BLRSUB=$ORDER(^LR(BLROLD,BLRSUB))
IF BLRSUB=""
QUIT
Begin DoDot:1
+30 IF BLRSUB'="CH"
IF BLRSUB'="BB"
IF BLRSUB'="MI"
IF BLRSUB'="CY"
IF BLRSUB'="SP"
IF BLRSUB'="EM"
+31 ; quit if BLRSUB already moved
IF '$TEST
QUIT
+32 IF ($DATA(^LR(BLROLD,BLRSUB))#10)
SET ^LR(BLRNEW,BLRSUB)=^LR(BLROLD,BLRSUB)
+33 ;set gbl root of old entry
SET BLROGBL="^LR(BLROLD,BLRSUB)"
+34 ; copy old gbl entries to new gbl entries (by accession area)
+35 FOR
SET BLROGBL=$QUERY(@BLROGBL)
IF $PIECE($PIECE(BLROGBL,",",2),"""",2)'=BLRSUB
QUIT
Begin DoDot:2
+36 SET BLRNGBL="^LR("_BLRNEW_","""_BLRSUB_$PIECE(BLROGBL,BLRSUB,2)
+37 SET @BLRNGBL=@BLROGBL
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 ; delete old LR entry from ^LR(
+41 ; removes old LRDFN entry in ^LR
SET DIK="^LR("
SET DA=BLROLD
DO DIK^BLRMERGU
+42 ; removes entry in cumulative file, 64.7 for old LRDFN
IF $DATA(^LAC("LRAC",BLROLD))
SET DA=BLROLD
SET DIK="^LAC(""LRAC"","
DO DIK^BLRMERGU
+43 ; remove LR pointer from ^DPT on old pat
KILL ^DPT(BLRFM,"LR")
+44 QUIT
+45 ;
AUTXREF ; KILL/SET AUTOPSY X-REFS IN FILE 63 FIELDS 11 AND 14
+1 IF BLRSTKL="S"
SET DA=BLRNEW
IF 1
+2 IF '$TEST
SET DA=BLROLD
+3 DO FLD11
+4 DO FLD14
+5 QUIT
+6 ;
FLD11 ; KILL/SET "AAU" XREF FROM FILE 63 FIELD 11
+1 SET X=$PIECE($GET(^LR(DA,"AU")),U)
+2 ; quit if field 11 not valued
IF X=""
QUIT
+3 DO ^XBGXREFS(63,11,.BLRXREF)
+4 SET BLRN=0
+5 FOR
SET BLRN=$ORDER(BLRXREF(11,BLRN))
IF 'BLRN
QUIT
XECUTE BLRXREF(11,BLRN,BLRSTKL)
+6 KILL BLRXREF
+7 QUIT
+8 ;
FLD14 ; KILL/SET "AAUA" XREF FROM FILE 63 FIELD 14
+1 SET X=$PIECE($GET(^LR(DA,"AU")),U,6)
+2 ; quit if field 14 not valued
IF X=""
QUIT
+3 DO ^XBGXREFS(63,14,.BLRXREF)
+4 SET BLRN=0
+5 FOR
SET BLRN=$ORDER(BLRXREF(14,BLRN))
IF 'BLRN
QUIT
XECUTE BLRXREF(14,BLRN,BLRSTKL)
+6 KILL BLRXREF
+7 QUIT
+8 ;
BULLT ; Send bulletin re: reprinting of cumulative report
+1 SET BLRDUZ=DUZ
SET DUZ=.5
+2 SET XMB(1)=BLROLD
+3 SET XMB(2)=BLRNEW
+4 SET XMB(3)=$PIECE(^DPT(BLRFM,0),U)
+5 SET XMB(4)=$PIECE(^DPT(BLRTO,0),U)
+6 IF $GET(DUZ(2))
SET XMB(5)=$PIECE($GET(^AUPNPAT(BLRFM,41,DUZ(2),0)),U,2)
+7 IF $GET(XMB(5))
+8 IF '$TEST
SET XMB(5)="NOT INDICATED"
+9 IF $GET(DUZ(2))
SET XMB(6)=$PIECE($GET(^AUPNPAT(BLRTO,41,DUZ(2),0)),U,2)
+10 IF $GET(XMB(6))
+11 IF '$TEST
SET XMB(6)="NOT INDICATED"
+12 SET XMB="BLR LAB PATIENT MERGE"
+13 DO ^XMB
+14 SET DUZ=BLRDUZ
+15 ; kill off mail variables
DO EN^XBVK("XMB")
+16 KILL Y1,XMDT
+17 QUIT
