Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRMERG

BLRMERG.m

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