- 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