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

BLRMERG2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;Variables:
  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.  ;
  1. START ;
  1.  D PREMERGE
  1.  D MERGE
  1.  D BULLT
  1.  Q
  1.  ;
  1. PREMERGE ; PREMERGE CHECK
  1.  ; Check to see if any "From" patient nodes have same collection
  1.  ; date/time as "To" patient nodes, if they do, then uptick by one
  1.  ; second until date/time unique for both "From" and "To" patients.
  1.  ;
  1.  F BLRSUB="CH","BB","MI","CY","SP","EM" D
  1.  .  S BLRINVDT=0
  1.  .  F  S BLRINVDT=$O(^LR(BLROLD,BLRSUB,BLRINVDT)) Q:BLRINVDT'=+BLRINVDT  I $D(^LR(BLRNEW,BLRSUB,BLRINVDT)) D SHIFT
  1.  .  Q
  1.  Q
  1.  ;
  1. SHIFT ; MAKE DATE/TIME UNIQUE FOR BOTH PATIENTS (SUBSCRIPT)
  1.  S (BLRODT,BLRNDT)=+^LR(BLROLD,BLRSUB,BLRINVDT,0)
  1.  D SHIFT2 ;                              find inverse date slot
  1.  D CHG68 ;                               chg accession file
  1.  D CHG69 ;                               chg order entry file
  1.  ; chg .01 field value
  1.  S $P(^LR(BLROLD,BLRSUB,BLRNINVD,0),U)=BLRNDT ; chg .01 field
  1.  S BLROGBL="^LR(BLROLD,BLRSUB,BLRINVDT)" ;set gbl root of old entry
  1.  ; copy old gbl entries to new gbl entries (by inverse date)
  1.  F  S BLROGBL=$Q(@BLROGBL) Q:+$P(BLROGBL,",",3)'=BLRINVDT  D
  1.  .  S BLRNGBL=$P(BLROGBL,BLRINVDT)_BLRNINVD_$P(BLROGBL,BLRINVDT,2)
  1.  .  S @BLRNGBL=@BLROGBL
  1.  .  Q
  1.  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
  1.  ; delete old ^LR entry
  1.  S DA(1)=BLROLD,DA=BLRINVDT,DIK="^LR("_BLROLD_","""_BLRSUB_"""," D DIK^BLRMERGU
  1.  ; set xrefs for new entry
  1.  S DA(1)=BLROLD,DA=BLRNINVD,DIK="^LR("_BLROLD_","""_BLRSUB_"""," D IX1^BLRMERGU
  1.  Q
  1.  ;
  1. SHIFT2 ; FIND INVERSE DATE/TIME SLOT
  1.  ; Up by .000001 old date/time variable, check if $D(BLRODT+.000001)
  1.  ; "From" patient, if it does exist, up by another .000001, check
  1.  ; again, if okay, check to see if the "To" patient has this date/time
  1.  ;
  1.  F  S BLRNDT=BLRNDT+.000001,BLRNINVD=9999999-BLRNDT I '$D(^LR(BLROLD,BLRSUB,BLRNINVD)),'$D(^LR(BLRNEW,BLRSUB,BLRNINVD)) Q
  1.  Q
  1.  ;
  1. CHG68 ; Changes INVERSE DATE field (^DD(68.01,13.5,0)) value
  1.  D SETVARS^BLRMERGU
  1.  Q:'BLRAIEN    ;PHXAO/AEF - NEW LINE TO PREVENT <SUBSCRIPT> ERROR
  1.  Q:'BLRDTSUB    ;PHXAO/AEF - NEW LINE TO PREVENT <SUBSCRIPT> ERROR
  1.  Q:'$D(^LRO(68,BLRAIEN,1,BLRDTSUB))
  1.  S DIE="^LRO(68,BLRAIEN,1,BLRDTSUB,1,",DA(2)=BLRAIEN,DA(1)=BLRDTSUB,DA=BLRNUM,DR="13.5////"_BLRNINVD
  1.  D DIE^BLRMERGU
  1.  Q
  1.  ;
  1. 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
  1.  ; a .1 node, which points to file 69 (Order).
  1.  I BLRSUB'="CH",BLRSUB'="BB",BLRSUB'="MI" Q
  1.  S BLRDATE=$P(+^LR(BLROLD,BLRSUB,BLRINVDT,0),"."),BLRACC=$P(^(0),U,6),BLRNUM=$P(BLRACC," ",3),BLRAIEN=$O(^LRO(68,"B",$P(BLRACC," "),""))
  1.  Q:'$G(BLRAIEN)   ;PHXAO/AEF - ADDED NEW LINE TO PREVENT <SUBSCRIPT>CHG69+5^BLRMERG2 ERROR
  1.  Q:'$D(^LRO(68,BLRAIEN,1,BLRDATE))
  1.  S BLRORDN=$G(^LRO(68,BLRAIEN,1,BLRDATE,1,BLRNUM,.1))  ;PHXAO/AEF - ADDED $G TO PREVENT <UNDEFINED> ERROR
  1.  Q:'BLRORDN  ;                                 quit if no order #
  1.  S BLRSPECN=0
  1.  F  S BLRSPECN=$O(^LRO(69,"C",BLRORDN,BLRDATE,BLRSPECN)) Q:'BLRSPECN  D
  1.  .  Q:+$G(^LRO(69,BLRDATE,1,BLRSPECN,1))'=BLRODT    ;PHXAO/AEF - ADDED $G TO PREVENT <UNDEFINED> ERROR
  1.  .  S DA(1)=BLRDATE,DA=BLRSPECN,DR="10////"_BLRNDT,DIE="^LRO(69,BLRDATE,1,"
  1.  .  D DIE^BLRMERGU
  1.  .  Q
  1.  Q
  1.  ;
  1. MERGE ;TRANSFER ^LR ENTRIES FROM OLD TO NEW
  1.  F BLRSUB="CH","BB","MI","CY","SP","EM" D
  1.  .  S BLROGBL="^LR(BLROLD,BLRSUB)" ;set gbl root of old entry
  1.  .  Q:'$D(^LR(BLROLD,BLRSUB))  ;    quit if no old nodes to copy
  1.  .  ; copy old gbl entries to new gbl entries (by accession area)
  1.  .  F  S BLROGBL=$Q(@BLROGBL) Q:$P($P(BLROGBL,",",2),"""",2)'=BLRSUB  D
  1.  ..  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
  1.  ..  S @BLRNGBL=@BLROGBL
  1.  ..  Q
  1.  .  ; set piece 3 & 4 of 0th node
  1.  .  NEW C,L,X,Y
  1.  .  S (C,L,Y)=0
  1.  .  F  S Y=$O(^LR(BLRNEW,BLRSUB,Y)) Q:'Y  S C=C+1,L=Y
  1.  .  S X=^LR(BLRNEW,BLRSUB,0)
  1.  .  S X=$P(X,U,1,2)_U_L_U_C
  1.  .  S ^LR(BLRNEW,BLRSUB,0)=X
  1.  .  ; set xrefs for new entries
  1.  .  S BLRINVD=0
  1.  .  F  S BLRINVDT=$O(^LR(BLRNEW,BLRSUB,BLRINVDT)) Q:'BLRINVDT  D
  1.  ..  S DA(1)=BLRNEW,DA=BLRINVDT,DIK="^LR("_BLRNEW_","""_BLRSUB_""","
  1.  ..  D IX1^BLRMERGU
  1.  ..  Q
  1.  .  Q
  1.  I $D(^LR(BLROLD,"AU")) D  ;    set autopsy xrefs
  1.  .  S BLRSTKL="S" D AUTXREF ;   set xrefs for new entry
  1.  .  S BLRSTKL="K" D AUTXREF ;   kill xrefs for old entry
  1.  .  Q
  1.  ; copy other old gbl entries to new gbl entries
  1.  S BLRSUB=0
  1.  F  S BLRSUB=$O(^LR(BLROLD,BLRSUB)) Q:BLRSUB=""  D
  1.  .  I BLRSUB'="CH",BLRSUB'="BB",BLRSUB'="MI",BLRSUB'="CY",BLRSUB'="SP",BLRSUB'="EM"
  1.  .  E  Q  ;                     quit if BLRSUB already moved
  1.  .  I ($D(^LR(BLROLD,BLRSUB))#10) S ^LR(BLRNEW,BLRSUB)=^LR(BLROLD,BLRSUB)
  1.  .  S BLROGBL="^LR(BLROLD,BLRSUB)" ;set gbl root of old entry
  1.  .  ; copy old gbl entries to new gbl entries (by accession area)
  1.  .  F  S BLROGBL=$Q(@BLROGBL) Q:$P($P(BLROGBL,",",2),"""",2)'=BLRSUB  D
  1.  ..  S BLRNGBL="^LR("_BLRNEW_","""_BLRSUB_$P(BLROGBL,BLRSUB,2)
  1.  ..  S @BLRNGBL=@BLROGBL
  1.  ..  Q
  1.  .  Q
  1.  ; delete old LR entry from ^LR(
  1.  S DIK="^LR(",DA=BLROLD D DIK^BLRMERGU ; removes old LRDFN entry in ^LR
  1.  I $D(^LAC("LRAC",BLROLD)) S DA=BLROLD,DIK="^LAC(""LRAC""," D DIK^BLRMERGU ; removes entry in cumulative file, 64.7 for old LRDFN
  1.  K ^DPT(BLRFM,"LR") ;           remove LR pointer from ^DPT on old pat
  1.  Q
  1.  ;
  1. AUTXREF ; KILL/SET AUTOPSY X-REFS IN FILE 63 FIELDS 11 AND 14
  1.  I BLRSTKL="S" S DA=BLRNEW I 1
  1.  E  S DA=BLROLD
  1.  D FLD11
  1.  D FLD14
  1.  Q
  1.  ;
  1. FLD11 ; KILL/SET "AAU" XREF FROM FILE 63 FIELD 11
  1.  S X=$P($G(^LR(DA,"AU")),U)
  1.  Q:X=""  ;                             quit if field 11 not valued
  1.  D ^XBGXREFS(63,11,.BLRXREF)
  1.  S BLRN=0
  1.  F  S BLRN=$O(BLRXREF(11,BLRN)) Q:'BLRN  X BLRXREF(11,BLRN,BLRSTKL)
  1.  K BLRXREF
  1.  Q
  1.  ;
  1. FLD14 ; KILL/SET "AAUA" XREF FROM FILE 63 FIELD 14
  1.  S X=$P($G(^LR(DA,"AU")),U,6)
  1.  Q:X=""  ;                             quit if field 14 not valued
  1.  D ^XBGXREFS(63,14,.BLRXREF)
  1.  S BLRN=0
  1.  F  S BLRN=$O(BLRXREF(14,BLRN)) Q:'BLRN  X BLRXREF(14,BLRN,BLRSTKL)
  1.  K BLRXREF
  1.  Q
  1.  ;
  1. BULLT ; Send bulletin re: reprinting of cumulative report
  1.  S BLRDUZ=DUZ,DUZ=.5
  1.  S XMB(1)=BLROLD
  1.  S XMB(2)=BLRNEW
  1.  S XMB(3)=$P(^DPT(BLRFM,0),U)
  1.  S XMB(4)=$P(^DPT(BLRTO,0),U)
  1.  I $G(DUZ(2)) S XMB(5)=$P($G(^AUPNPAT(BLRFM,41,DUZ(2),0)),U,2)
  1.  I $G(XMB(5))
  1.  E  S XMB(5)="NOT INDICATED"
  1.  I $G(DUZ(2)) S XMB(6)=$P($G(^AUPNPAT(BLRTO,41,DUZ(2),0)),U,2)
  1.  I $G(XMB(6))
  1.  E  S XMB(6)="NOT INDICATED"
  1.  S XMB="BLR LAB PATIENT MERGE"
  1.  D ^XMB
  1.  S DUZ=BLRDUZ
  1.  D EN^XBVK("XMB") ;                     kill off mail variables
  1.  K Y1,XMDT
  1.  Q