BLRMERG ; IHS/TUCSON/DG/ANMC/CLS/ISD/EDE - LAB PATIENT MERGE [ 01/13/1999 4:29 PM ]
;;5.2;BLR;**1005**;DEC 14, 1998
;
; Modified ALRMERG by EDE
;
; Repoint entries in ^LR
; Change LRDFN & XREFs in ^LRO(68, ^LRO(69,
;
; *** MERGE ROUTINE FOR VA LAB V5.2 ***
;
; When VA LAB PACKAGE versions change, so must the version number
; that is checked. Confirm lab merge works in new package.
;
;Variables:
; XDRMRG("FR")=from patient's ien
; XDRMRG("TO")=to patient's ien
;
; BLRFM=from patient's ien
; BLRTO=to patient's ien
;
; 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,
; BLRNUM=subfile entry ien in file 68 ^LRO(68, within accession area
; BLRDATE=date of lab test order
; BLRSPECN=specimen ien in ^LRO(69,
; BLRLBPK=lab package ien in ^DIC(9.4,
;
EN ; Entry point for lab merge
D INIT
I BLRQ D EOJ Q
D MERGE
D EOJ
Q
;
INIT ;
S BLRQ=1
K ^TMP("BLRMERG",$J)
; insure correct version of Lab
S BLRLBPK=$O(^DIC(9.4,"C","LR","")) ; get Lab package ien
I 'BLRLBPK D Q
. I '$D(XDRM("NOTALK"))&'$D(ZTQUEUED) D
.. W !!,*7,"Cannot determine what version of Lab you are running!"
.. Q
. S:$D(^%ZOSF("$ZE")) X="VA Lab Merge: Cannot determine version",@^("$ZE")
. D MERGE^XDRMRG1 ; Causes merge to abort if lab merge cannot occur
. Q
I $G(^DIC(9.4,BLRLBPK,"VERSION"))'=5.2 D Q
. I '$D(XDRM("NOTALK"))&'$D(ZTQUEUED) D
.. W !!,*7,"The version of lab you are running is not compatible with this version of",!,"lab merge!"
.. Q
. S:$D(^%ZOSF("$ZE")) X="VA Lab Merge: Incorrect Version",@^("$ZE")
. D MERGE^XDRMRG1 ; Causes merge to abort if lab merge cannot occur
. Q
;
I '$D(^TMP("XDRMRGFR",$J,XDRMRG("FR"),"LR")) Q ;from entry not in Lab so nothing to merge
;
; Set up needed vars
S BLRFM=XDRMRG("FR")
S BLRTO=XDRMRG("TO")
S BLROLD=^TMP("XDRMRGFR",$J,BLRFM,"LR")
S BLRNEW=$G(^TMP("XDRMRGTO",$J,BLRTO,"LR"))
I 'BLRNEW S BLRNEW=$G(^DPT(BLRTO,"LR"))
;
; If 'from' patient in Lab system but 'to' patient is not, then
; repoint 'from' patient's LR entry to 'to' patient, then quit.
I '$D(^TMP("XDRMRGTO",$J,BLRTO,"LR")),'$D(^DPT(BLRTO,"LR")) D Q
. S DIE="^LR(",DA=BLROLD,DR=".03////"_BLRTO
. D DIE^BLRMERGU
. Q
;
S BLRQ=0
Q
;
MERGE ; Begin merge process
D REP6869 ; repoint files 68,69 & 9009022
D ^BLRMERG2 ; move file 63 data
Q
;
REP6869 ; REPOINT FILE 68, 69 & 9009022
K ^TMP("BLRMERG",$J,"ORD")
; first navigate via file 63 entries
F BLRSUB="CH","BB","MI","CY","SP","EM","AU" D LRINFO
D CHKXREFS ; chg any missed entries
K ^TMP("BLRMERG",$J,"ORD")
Q
;
LRINFO ; FIND 68, 69 & 9009022 ENTRIES VIA 63 ENTRIES
I BLRSUB="AU" D Q
. Q:'$D(^LR(BLROLD,BLRSUB))
. S BLRINVDT=$P($G(^LR(BLROLD,BLRSUB)),U)
. Q:'BLRINVDT
. D SETVARS^BLRMERGU ; setup needed variables
. I BLRAIEN,BLRDATE,BLRDTSUB,BLRNUM
. E Q ; quit if not all vars
. D LRINFO2
. Q
S BLRINVDT=0
F S BLRINVDT=$O(^LR(BLROLD,BLRSUB,BLRINVDT)) Q:'BLRINVDT D
. D SETVARS^BLRMERGU ; setup needed variables
. I BLRAIEN,BLRDATE,BLRDTSUB,BLRNUM
. E Q ; quit if not all vars
. D LRINFO2
. Q
Q
;
LRINFO2 ;
D BLRTXLOG ; repoint blr tx log
D 68 ; repoint file 68
Q
;
BLRTXLOG ; REPOINT BLRTXLOG
S BLRDTANM=0
F S BLRDTANM=$O(^LR(BLROLD,BLRSUB,BLRINVDT,BLRDTANM)) Q:'BLRDTANM D
. S BLRLTSUB=BLRSUB_";"_BLRDTANM_";1"
. S BLRLTIEN=$O(^LAB(60,"C",BLRLTSUB,0))
. S BLRTXIEN=0
. Q:'BLRLTIEN ; quit if no lab test ien
. F S BLRTXIEN=$O(^BLRTXLOG("AAT",BLRACC,BLRLTIEN,BLRTXIEN)) Q:'BLRTXIEN D
.. Q:'$D(^BLRTXLOG(BLRTXIEN,0)) ; quit if corrupt file
.. Q:$P(^BLRTXLOG(BLRTXIEN,0),U,2)'=2 ; quit if not patient file
.. S X=$G(^BLRTXLOG(BLRTXIEN,12))
.. I X]"",+X,$E(+X,2,3)'=$E(BLRDATE,2,3) Q ;quit if wrong year
.. S DIE="^BLRTXLOG(",DR=".03////"_BLRNEW_";.04////"_BLRTO,DA=BLRTXIEN
.. D DIE^BLRMERGU
.. Q
. Q
Q
;
68 ; REPOINT FILE 68
I $D(^LRO(68,BLRAIEN,1,BLRDTSUB,1,BLRNUM)) D
. D CHG68 ; modify file 68, accessions
. S BLRORDN=$G(^LRO(68,BLRAIEN,1,BLRDTSUB,1,BLRNUM,.1))
. Q:'BLRORDN ; quit if no order #
. Q:$D(^TMP("BLRMERG",$J,"ORD",BLRORDN))
. ; there may be several 68 entries for one 69 entry
. D 69 ; modify file 69, orders
. Q
Q
;
CHG68 ;MAKE CHANGE TO FILE 68
; Change LRDFN (68.02,.01) to point to TO patient LR entry
S BLRSTKL="K"
D XREF68 ; kill xrefs prior to value chg
S DIE="^LRO(68,BLRAIEN,1,BLRDTSUB,1,",DA(2)=BLRAIEN,DA(1)=BLRDTSUB,DA=BLRNUM,DR=".01///"_BLRNEW
D DIE^BLRMERGU
Q:$D(Y) ; quit if ^DIE error
S BLRSTKL="S"
D XREF68 ; set xrefs after value chg
Q
;
XREF68 ; KILL/SET X-REFS IN SUBFILE 68.02, FIELD 13
S DA=BLRNUM,DA(1)=BLRDTSUB,DA(2)=BLRAIEN,X=$P($G(^LRO(68,DA(2),1,DA(1),1,DA,3)),U,3)
Q:X="" ; quit if field 13 not valued
; this executes LRXREF1 that aborts if there is no 4 node
Q:'$O(^LRO(68,DA(2),1,DA(1),1,DA,4,0)) ; quit if no 4 node entries
D ^XBGXREFS(68.02,13,.BLRXREF)
S BLRN=0
F S BLRN=$O(BLRXREF(13,BLRN)) Q:'BLRN X BLRXREF(13,BLRN,BLRSTKL)
K BLRXREF
Q
;
69 ;MAKE CHANGE TO FILE 69
S BLRSPECN=0
F S BLRSPECN=$O(^LRO(69,"C",BLRORDN,BLRDTSUB,BLRSPECN)) Q:'BLRSPECN D CHG69
S ^TMP("BLRMERG",$J,"ORD",BLRORDN)=""
Q
;
CHG69 ; CHG LRDFN IN FILE 69
; warning - this label done from CHKXREFS also
; Change LRDFN (69.01,.01) to point to TO patient LR entry
S BLRSTKL="K"
D XREF69 ; kill xrefs prior to value chg
S DA=BLRSPECN,DA(1)=BLRDTSUB,DIE="^LRO(69,BLRDTSUB,1,",DR=".01///"_BLRNEW
D DIE^BLRMERGU
Q:$D(Y) ; quit if ^DIE error
S BLRSTKL="S"
D XREF69 ; set xrefs after value chg
D FIXAN1 ; fix low level AN xref
D FIXAN2 ; fix top level AN xref
Q
;
FIXAN1 ; FIX LOW LEVEL AN XREF
; fix odd ball "AN" xrefs generated by who knows what
; get field 21 DATE/TIME RESULTS AVAILABLE
S BLRRDT=$P($P($G(^LRO(69,BLRDTSUB,1,BLRSPECN,3)),U,2),".")
Q:BLRRDT="" ; quit if results not available
S BLRLOC=$E($P($G(^LRO(69,BLRDTSUB,1,BLRSPECN,0)),U,7),1,15)
Q:BLRLOC="" ; quit if no location
Q:'$D(^LRO(69,BLRRDT,1,"AN",BLRLOC,BLROLD)) ; quit if no old LRDFN
S Y=0
F S Y=$O(^LRO(69,BLRRDT,1,"AN",BLRLOC,BLROLD,Y)) Q:'Y D
. S ^LRO(69,BLRRDT,1,"AN",BLRLOC,BLRNEW,Y)=""
. K ^LRO(69,BLRRDT,1,"AN",BLRLOC,BLROLD,Y)
. Q
Q
;
FIXAN2 ; FIX TOP LEVEL AN XREF
S BLRLOC=""
F S BLRLOC=$O(^LRO(69,"AN",BLRLOC)) Q:BLRLOC="" D
. S Y=0
. F S Y=$O(^LRO(69,"AN",BLRLOC,BLROLD,Y)) Q:'Y D
.. S ^LRO(69,"AN",BLRLOC,BLRNEW,Y)=""
.. K ^LRO(69,"AN",BLRLOC,BLROLD,Y)
.. Q
. Q
Q
;
XREF69 ; KILL/SET X-REFS IN SUBFILE 69.01, FIELD 21 & 69.03, FIELD .01
D FLD21
D FLD01
Q
;
FLD21 ; KILL/SET X-REFS IN SUBFILE 69.01, FIELD 21
S DA=BLRSPECN,DA(1)=BLRDTSUB,X=$P($G(^LRO(69,DA(1),1,DA,3)),U,2)
Q:X="" ; quit if field 21 not valued
D ^XBGXREFS(69.01,21,.BLRXREF)
S BLRN=0
F S BLRN=$O(BLRXREF(21,BLRN)) Q:'BLRN X BLRXREF(21,BLRN,BLRSTKL)
K BLRXREF
Q
;
FLD01 ; KILL/SET X-REFS IN SUBFILE 69.03, FIELD .01
S DA(1)=BLRSPECN,DA(2)=BLRDTSUB
F DA=0:0 S DA=$O(^LRO(69,DA(2),1,DA(1),2,DA)) Q:'DA D
. S X=$P($G(^LRO(69,DA(2),1,DA(1),2,DA,0)),U)
. Q:X="" ; should never happen
. D ^XBGXREFS(69.03,.01,.BLRXREF)
. X BLRXREF(.01,2,BLRSTKL) ; "AT" xref only
. K BLRXREF
. Q
Q
;
CHKXREFS ; CHECK FILE 68 & 69 XREFS
; now check xrefs to see if any file 68 or 69 entries left
; "AC" in file 68
S BLRDTSUB=0
F S BLRDTSUB=$O(^LRO(68,"AC",BLROLD,BLRDTSUB)) Q:BLRDTSUB="" D
. S Y=0
. F S Y=$O(^LRO(68,"AC",BLROLD,BLRDTSUB,Y)) Q:'Y D
.. S ^LRO(68,"AC",BLRNEW,BLRDTSUB,Y)=""
.. K ^LRO(68,"AC",BLROLD,BLRDTSUB,Y)
.. Q
. Q
; "MI" in file 68
S BLRDTSUB=0
F S BLRDTSUB=$O(^LRO(68,"MI",BLROLD,BLRDTSUB)) Q:BLRDTSUB="" D
. S Y=0
. F S Y=$O(^LRO(68,"MI",BLROLD,BLRDTSUB,Y)) Q:'Y D
.. S ^LRO(68,"MI",BLRNEW,BLRDTSUB,Y)=""
.. K ^LRO(68,"MI",BLROLD,BLRDTSUB,Y)
.. Q
. Q
; "D" in file 69
S BLRDTSUB=0
F S BLRDTSUB=$O(^LRO(69,"D",BLROLD,BLRDTSUB)) Q:BLRDTSUB="" D
. S BLRDATE=BLRDTSUB
. S BLRSPECN=""
. F S BLRSPECN=$O(^LRO(69,"D",BLROLD,BLRDTSUB,BLRSPECN)) Q:'BLRSPECN D
.. D CHG69
.. Q
. Q
Q
;
EOJ ;
K ^TMP("BLRMERG",$J)
D EN^XBVK("BLR")
D EN^XBVK("LR")
D ^XBFMK ; kill off fileman variables
Q
BLRMERG ; IHS/TUCSON/DG/ANMC/CLS/ISD/EDE - LAB PATIENT MERGE [ 01/13/1999 4:29 PM ]
+1 ;;5.2;BLR;**1005**;DEC 14, 1998
+2 ;
+3 ; Modified ALRMERG by EDE
+4 ;
+5 ; Repoint entries in ^LR
+6 ; Change LRDFN & XREFs in ^LRO(68, ^LRO(69,
+7 ;
+8 ; *** MERGE ROUTINE FOR VA LAB V5.2 ***
+9 ;
+10 ; When VA LAB PACKAGE versions change, so must the version number
+11 ; that is checked. Confirm lab merge works in new package.
+12 ;
+13 ;Variables:
+14 ; XDRMRG("FR")=from patient's ien
+15 ; XDRMRG("TO")=to patient's ien
+16 ;
+17 ; BLRFM=from patient's ien
+18 ; BLRTO=to patient's ien
+19 ;
+20 ; BLROLD=from patient's LR ien
+21 ; BLRNEW=to patient's LR ien
+22 ; BLRQ=quit flag
+23 ; BLRSUB=accession area subscript
+24 ; BLRDINVDT=subfile entry ien within BLRSUB in ^LR(BLROLD,
+25 ; BLRAIEN=accession area ien in file 68 ^LRO(68,
+26 ; BLRDTSUB=date subscript in ^LRO(68, within accession area, ^LRO(69,
+27 ; BLRNUM=subfile entry ien in file 68 ^LRO(68, within accession area
+28 ; BLRDATE=date of lab test order
+29 ; BLRSPECN=specimen ien in ^LRO(69,
+30 ; BLRLBPK=lab package ien in ^DIC(9.4,
+31 ;
EN ; Entry point for lab merge
+1 DO INIT
+2 IF BLRQ
DO EOJ
QUIT
+3 DO MERGE
+4 DO EOJ
+5 QUIT
+6 ;
INIT ;
+1 SET BLRQ=1
+2 KILL ^TMP("BLRMERG",$JOB)
+3 ; insure correct version of Lab
+4 ; get Lab package ien
SET BLRLBPK=$ORDER(^DIC(9.4,"C","LR",""))
+5 IF 'BLRLBPK
Begin DoDot:1
+6 IF '$DATA(XDRM("NOTALK"))&'$DATA(ZTQUEUED)
Begin DoDot:2
+7 WRITE !!,*7,"Cannot determine what version of Lab you are running!"
+8 QUIT
End DoDot:2
+9 IF $DATA(^%ZOSF("$ZE"))
SET X="VA Lab Merge: Cannot determine version"
SET @^("$ZE")
+10 ; Causes merge to abort if lab merge cannot occur
DO MERGE^XDRMRG1
+11 QUIT
End DoDot:1
QUIT
+12 IF $GET(^DIC(9.4,BLRLBPK,"VERSION"))'=5.2
Begin DoDot:1
+13 IF '$DATA(XDRM("NOTALK"))&'$DATA(ZTQUEUED)
Begin DoDot:2
+14 WRITE !!,*7,"The version of lab you are running is not compatible with this version of",!,"lab merge!"
+15 QUIT
End DoDot:2
+16 IF $DATA(^%ZOSF("$ZE"))
SET X="VA Lab Merge: Incorrect Version"
SET @^("$ZE")
+17 ; Causes merge to abort if lab merge cannot occur
DO MERGE^XDRMRG1
+18 QUIT
End DoDot:1
QUIT
+19 ;
+20 ;from entry not in Lab so nothing to merge
IF '$DATA(^TMP("XDRMRGFR",$JOB,XDRMRG("FR"),"LR"))
QUIT
+21 ;
+22 ; Set up needed vars
+23 SET BLRFM=XDRMRG("FR")
+24 SET BLRTO=XDRMRG("TO")
+25 SET BLROLD=^TMP("XDRMRGFR",$JOB,BLRFM,"LR")
+26 SET BLRNEW=$GET(^TMP("XDRMRGTO",$JOB,BLRTO,"LR"))
+27 IF 'BLRNEW
SET BLRNEW=$GET(^DPT(BLRTO,"LR"))
+28 ;
+29 ; If 'from' patient in Lab system but 'to' patient is not, then
+30 ; repoint 'from' patient's LR entry to 'to' patient, then quit.
+31 IF '$DATA(^TMP("XDRMRGTO",$JOB,BLRTO,"LR"))
IF '$DATA(^DPT(BLRTO,"LR"))
Begin DoDot:1
+32 SET DIE="^LR("
SET DA=BLROLD
SET DR=".03////"_BLRTO
+33 DO DIE^BLRMERGU
+34 QUIT
End DoDot:1
QUIT
+35 ;
+36 SET BLRQ=0
+37 QUIT
+38 ;
MERGE ; Begin merge process
+1 ; repoint files 68,69 & 9009022
DO REP6869
+2 ; move file 63 data
DO ^BLRMERG2
+3 QUIT
+4 ;
REP6869 ; REPOINT FILE 68, 69 & 9009022
+1 KILL ^TMP("BLRMERG",$JOB,"ORD")
+2 ; first navigate via file 63 entries
+3 FOR BLRSUB="CH","BB","MI","CY","SP","EM","AU"
DO LRINFO
+4 ; chg any missed entries
DO CHKXREFS
+5 KILL ^TMP("BLRMERG",$JOB,"ORD")
+6 QUIT
+7 ;
LRINFO ; FIND 68, 69 & 9009022 ENTRIES VIA 63 ENTRIES
+1 IF BLRSUB="AU"
Begin DoDot:1
+2 IF '$DATA(^LR(BLROLD,BLRSUB))
QUIT
+3 SET BLRINVDT=$PIECE($GET(^LR(BLROLD,BLRSUB)),U)
+4 IF 'BLRINVDT
QUIT
+5 ; setup needed variables
DO SETVARS^BLRMERGU
+6 IF BLRAIEN
IF BLRDATE
IF BLRDTSUB
IF BLRNUM
+7 ; quit if not all vars
IF '$TEST
QUIT
+8 DO LRINFO2
+9 QUIT
End DoDot:1
QUIT
+10 SET BLRINVDT=0
+11 FOR
SET BLRINVDT=$ORDER(^LR(BLROLD,BLRSUB,BLRINVDT))
IF 'BLRINVDT
QUIT
Begin DoDot:1
+12 ; setup needed variables
DO SETVARS^BLRMERGU
+13 IF BLRAIEN
IF BLRDATE
IF BLRDTSUB
IF BLRNUM
+14 ; quit if not all vars
IF '$TEST
QUIT
+15 DO LRINFO2
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
LRINFO2 ;
+1 ; repoint blr tx log
DO BLRTXLOG
+2 ; repoint file 68
DO 68
+3 QUIT
+4 ;
BLRTXLOG ; REPOINT BLRTXLOG
+1 SET BLRDTANM=0
+2 FOR
SET BLRDTANM=$ORDER(^LR(BLROLD,BLRSUB,BLRINVDT,BLRDTANM))
IF 'BLRDTANM
QUIT
Begin DoDot:1
+3 SET BLRLTSUB=BLRSUB_";"_BLRDTANM_";1"
+4 SET BLRLTIEN=$ORDER(^LAB(60,"C",BLRLTSUB,0))
+5 SET BLRTXIEN=0
+6 ; quit if no lab test ien
IF 'BLRLTIEN
QUIT
+7 FOR
SET BLRTXIEN=$ORDER(^BLRTXLOG("AAT",BLRACC,BLRLTIEN,BLRTXIEN))
IF 'BLRTXIEN
QUIT
Begin DoDot:2
+8 ; quit if corrupt file
IF '$DATA(^BLRTXLOG(BLRTXIEN,0))
QUIT
+9 ; quit if not patient file
IF $PIECE(^BLRTXLOG(BLRTXIEN,0),U,2)'=2
QUIT
+10 SET X=$GET(^BLRTXLOG(BLRTXIEN,12))
+11 ;quit if wrong year
IF X]""
IF +X
IF $EXTRACT(+X,2,3)'=$EXTRACT(BLRDATE,2,3)
QUIT
+12 SET DIE="^BLRTXLOG("
SET DR=".03////"_BLRNEW_";.04////"_BLRTO
SET DA=BLRTXIEN
+13 DO DIE^BLRMERGU
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
68 ; REPOINT FILE 68
+1 IF $DATA(^LRO(68,BLRAIEN,1,BLRDTSUB,1,BLRNUM))
Begin DoDot:1
+2 ; modify file 68, accessions
DO CHG68
+3 SET BLRORDN=$GET(^LRO(68,BLRAIEN,1,BLRDTSUB,1,BLRNUM,.1))
+4 ; quit if no order #
IF 'BLRORDN
QUIT
+5 IF $DATA(^TMP("BLRMERG",$JOB,"ORD",BLRORDN))
QUIT
+6 ; there may be several 68 entries for one 69 entry
+7 ; modify file 69, orders
DO 69
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
CHG68 ;MAKE CHANGE TO FILE 68
+1 ; Change LRDFN (68.02,.01) to point to TO patient LR entry
+2 SET BLRSTKL="K"
+3 ; kill xrefs prior to value chg
DO XREF68
+4 SET DIE="^LRO(68,BLRAIEN,1,BLRDTSUB,1,"
SET DA(2)=BLRAIEN
SET DA(1)=BLRDTSUB
SET DA=BLRNUM
SET DR=".01///"_BLRNEW
+5 DO DIE^BLRMERGU
+6 ; quit if ^DIE error
IF $DATA(Y)
QUIT
+7 SET BLRSTKL="S"
+8 ; set xrefs after value chg
DO XREF68
+9 QUIT
+10 ;
XREF68 ; KILL/SET X-REFS IN SUBFILE 68.02, FIELD 13
+1 SET DA=BLRNUM
SET DA(1)=BLRDTSUB
SET DA(2)=BLRAIEN
SET X=$PIECE($GET(^LRO(68,DA(2),1,DA(1),1,DA,3)),U,3)
+2 ; quit if field 13 not valued
IF X=""
QUIT
+3 ; this executes LRXREF1 that aborts if there is no 4 node
+4 ; quit if no 4 node entries
IF '$ORDER(^LRO(68,DA(2),1,DA(1),1,DA,4,0))
QUIT
+5 DO ^XBGXREFS(68.02,13,.BLRXREF)
+6 SET BLRN=0
+7 FOR
SET BLRN=$ORDER(BLRXREF(13,BLRN))
IF 'BLRN
QUIT
XECUTE BLRXREF(13,BLRN,BLRSTKL)
+8 KILL BLRXREF
+9 QUIT
+10 ;
69 ;MAKE CHANGE TO FILE 69
+1 SET BLRSPECN=0
+2 FOR
SET BLRSPECN=$ORDER(^LRO(69,"C",BLRORDN,BLRDTSUB,BLRSPECN))
IF 'BLRSPECN
QUIT
DO CHG69
+3 SET ^TMP("BLRMERG",$JOB,"ORD",BLRORDN)=""
+4 QUIT
+5 ;
CHG69 ; CHG LRDFN IN FILE 69
+1 ; warning - this label done from CHKXREFS also
+2 ; Change LRDFN (69.01,.01) to point to TO patient LR entry
+3 SET BLRSTKL="K"
+4 ; kill xrefs prior to value chg
DO XREF69
+5 SET DA=BLRSPECN
SET DA(1)=BLRDTSUB
SET DIE="^LRO(69,BLRDTSUB,1,"
SET DR=".01///"_BLRNEW
+6 DO DIE^BLRMERGU
+7 ; quit if ^DIE error
IF $DATA(Y)
QUIT
+8 SET BLRSTKL="S"
+9 ; set xrefs after value chg
DO XREF69
+10 ; fix low level AN xref
DO FIXAN1
+11 ; fix top level AN xref
DO FIXAN2
+12 QUIT
+13 ;
FIXAN1 ; FIX LOW LEVEL AN XREF
+1 ; fix odd ball "AN" xrefs generated by who knows what
+2 ; get field 21 DATE/TIME RESULTS AVAILABLE
+3 SET BLRRDT=$PIECE($PIECE($GET(^LRO(69,BLRDTSUB,1,BLRSPECN,3)),U,2),".")
+4 ; quit if results not available
IF BLRRDT=""
QUIT
+5 SET BLRLOC=$EXTRACT($PIECE($GET(^LRO(69,BLRDTSUB,1,BLRSPECN,0)),U,7),1,15)
+6 ; quit if no location
IF BLRLOC=""
QUIT
+7 ; quit if no old LRDFN
IF '$DATA(^LRO(69,BLRRDT,1,"AN",BLRLOC,BLROLD))
QUIT
+8 SET Y=0
+9 FOR
SET Y=$ORDER(^LRO(69,BLRRDT,1,"AN",BLRLOC,BLROLD,Y))
IF 'Y
QUIT
Begin DoDot:1
+10 SET ^LRO(69,BLRRDT,1,"AN",BLRLOC,BLRNEW,Y)=""
+11 KILL ^LRO(69,BLRRDT,1,"AN",BLRLOC,BLROLD,Y)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
FIXAN2 ; FIX TOP LEVEL AN XREF
+1 SET BLRLOC=""
+2 FOR
SET BLRLOC=$ORDER(^LRO(69,"AN",BLRLOC))
IF BLRLOC=""
QUIT
Begin DoDot:1
+3 SET Y=0
+4 FOR
SET Y=$ORDER(^LRO(69,"AN",BLRLOC,BLROLD,Y))
IF 'Y
QUIT
Begin DoDot:2
+5 SET ^LRO(69,"AN",BLRLOC,BLRNEW,Y)=""
+6 KILL ^LRO(69,"AN",BLRLOC,BLROLD,Y)
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
XREF69 ; KILL/SET X-REFS IN SUBFILE 69.01, FIELD 21 & 69.03, FIELD .01
+1 DO FLD21
+2 DO FLD01
+3 QUIT
+4 ;
FLD21 ; KILL/SET X-REFS IN SUBFILE 69.01, FIELD 21
+1 SET DA=BLRSPECN
SET DA(1)=BLRDTSUB
SET X=$PIECE($GET(^LRO(69,DA(1),1,DA,3)),U,2)
+2 ; quit if field 21 not valued
IF X=""
QUIT
+3 DO ^XBGXREFS(69.01,21,.BLRXREF)
+4 SET BLRN=0
+5 FOR
SET BLRN=$ORDER(BLRXREF(21,BLRN))
IF 'BLRN
QUIT
XECUTE BLRXREF(21,BLRN,BLRSTKL)
+6 KILL BLRXREF
+7 QUIT
+8 ;
FLD01 ; KILL/SET X-REFS IN SUBFILE 69.03, FIELD .01
+1 SET DA(1)=BLRSPECN
SET DA(2)=BLRDTSUB
+2 FOR DA=0:0
SET DA=$ORDER(^LRO(69,DA(2),1,DA(1),2,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 SET X=$PIECE($GET(^LRO(69,DA(2),1,DA(1),2,DA,0)),U)
+4 ; should never happen
IF X=""
QUIT
+5 DO ^XBGXREFS(69.03,.01,.BLRXREF)
+6 ; "AT" xref only
XECUTE BLRXREF(.01,2,BLRSTKL)
+7 KILL BLRXREF
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
CHKXREFS ; CHECK FILE 68 & 69 XREFS
+1 ; now check xrefs to see if any file 68 or 69 entries left
+2 ; "AC" in file 68
+3 SET BLRDTSUB=0
+4 FOR
SET BLRDTSUB=$ORDER(^LRO(68,"AC",BLROLD,BLRDTSUB))
IF BLRDTSUB=""
QUIT
Begin DoDot:1
+5 SET Y=0
+6 FOR
SET Y=$ORDER(^LRO(68,"AC",BLROLD,BLRDTSUB,Y))
IF 'Y
QUIT
Begin DoDot:2
+7 SET ^LRO(68,"AC",BLRNEW,BLRDTSUB,Y)=""
+8 KILL ^LRO(68,"AC",BLROLD,BLRDTSUB,Y)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 ; "MI" in file 68
+12 SET BLRDTSUB=0
+13 FOR
SET BLRDTSUB=$ORDER(^LRO(68,"MI",BLROLD,BLRDTSUB))
IF BLRDTSUB=""
QUIT
Begin DoDot:1
+14 SET Y=0
+15 FOR
SET Y=$ORDER(^LRO(68,"MI",BLROLD,BLRDTSUB,Y))
IF 'Y
QUIT
Begin DoDot:2
+16 SET ^LRO(68,"MI",BLRNEW,BLRDTSUB,Y)=""
+17 KILL ^LRO(68,"MI",BLROLD,BLRDTSUB,Y)
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 ; "D" in file 69
+21 SET BLRDTSUB=0
+22 FOR
SET BLRDTSUB=$ORDER(^LRO(69,"D",BLROLD,BLRDTSUB))
IF BLRDTSUB=""
QUIT
Begin DoDot:1
+23 SET BLRDATE=BLRDTSUB
+24 SET BLRSPECN=""
+25 FOR
SET BLRSPECN=$ORDER(^LRO(69,"D",BLROLD,BLRDTSUB,BLRSPECN))
IF 'BLRSPECN
QUIT
Begin DoDot:2
+26 DO CHG69
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
EOJ ;
+1 KILL ^TMP("BLRMERG",$JOB)
+2 DO EN^XBVK("BLR")
+3 DO EN^XBVK("LR")
+4 ; kill off fileman variables
DO ^XBFMK
+5 QUIT
