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

BPMXFX1.m

Go to the documentation of this file. 
  1. BPMXFX1 ;IHS/OIT/NKD - CLEANUP UTILITY - SPLIT INTO MULTIPLE ROUTINES - 7/23/12 ;
  1.  ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
  1.  ;
  1.  Q
  1. TPB ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX 3PB ENTRIES
  1.  ;
  1.  N XIEN,BPMFR,BPMTO,BPMCNT,BPMCNT2,BPMHDR,BPMTMP
  1.  ;
  1.  D RSLT^BPMXFIX("Merging remaining 3PB Claims and Bills...")
  1.  S (XIEN,BPMCNT,BPMCNT2)=0
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN  D
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$$LAST^BPMXFIX(BPMFR),BPMHDR=1
  1.  . ; PROCESS CLAIMS
  1.  . N BPMDUZ2,BPMD0
  1.  . S BPMDUZ2=0 F  S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2  D
  1.  . . N BPMTMP
  1.  . . S BPMD0=0 F  S BPMD0=$O(^ABMDCLM(BPMDUZ2,"B",BPMFR,BPMD0)) Q:BPMD0'=+BPMD0  D
  1.  . . . Q:$P($G(^ABMDCLM(BPMDUZ2,BPMD0,0)),U)'=BPMFR
  1.  . . . S BPMTMP(BPMD0)=""
  1.  . . . D ONECLAIM^BPMX3PB(BPMDUZ2,BPMD0,BPMTO)
  1.  . . . S BPMCNT=BPMCNT+1
  1.  . . I $D(BPMTMP) D
  1.  . . . I $O(BPMTMP($O(BPMTMP(0))))="" D HDR^BPMXFIX(BPMTO,BPMDUZ2,$O(BPMTMP(0)),,"Claim") Q
  1.  . . . D RSLT^BPMXFIX(""),HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Claim"),ENTRIES^BPMXFIX(.BPMTMP)
  1.  . ; PROCESS BILLS
  1.  . N BPMDUZ2,BPMD0
  1.  . S BPMDUZ2=0 F  S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2  D
  1.  . . N BPMTMP
  1.  . . S BPMD0=0 F  S BPMD0=$O(^ABMDBILL(BPMDUZ2,"D",BPMFR,BPMD0)) Q:BPMD0'=+BPMD0  D
  1.  . . . Q:$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMFR
  1.  . . . N BPMB S BPMB=$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,1)
  1.  . . . S BPMTMP(BPMB)=""
  1.  . . . D ONEBILL^BPMX3PB(BPMDUZ2,BPMD0,BPMTO)
  1.  . . . S BPMCNT2=BPMCNT2+1
  1.  . . I $D(BPMTMP) D
  1.  . . . I $O(BPMTMP($O(BPMTMP(0))))="" D HDR^BPMXFIX(BPMTO,BPMDUZ2,$O(BPMTMP(0)),,"Bill") Q
  1.  . . . D RSLT^BPMXFIX(""),HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Bill"),ENTRIES^BPMXFIX(.BPMTMP)
  1.  D RSLT^BPMXFIX("  *** Total Claims Found: "_BPMCNT_" ***")
  1.  D RSLT^BPMXFIX("  *** Total Bills  Found: "_BPMCNT2_" ***")
  1.  ; RE-INDEX "ADR" X-REF ON ALL MERGED TO BILLS
  1.  ; CORRECT CLAIM PATIENT IF DIFFERENT
  1.  N BPMCNT,BPMD0,BPMDUZ2,BPMDUZ,BPMTO,DA,X,BPMCI,BPMCP
  1.  D RSLT^BPMXFIX("Correcting improperly merged Claims...")
  1.  S (BPMDUZ2,BPMCNT)=0
  1.  F  S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2  D
  1.  . S BPMTO=0 F  S BPMTO=$O(^TMP("BPM",$J,"TO",BPMTO)) Q:BPMTO'=+BPMTO  D
  1.  . . N BPMTMP
  1.  . . S BPMHDR=1
  1.  . . S BPMD0=0 F  S BPMD0=$O(^ABMDBILL(BPMDUZ2,"D",BPMTO,BPMD0)) Q:BPMD0'=+BPMD0  D
  1.  . . . Q:$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMTO
  1.  . . . S BPMDUZ(2)=DUZ(2),DUZ(2)=BPMDUZ2
  1.  . . . S DA=BPMD0
  1.  . . . S X=$$GET1^DIQ(9002274.4,BPMD0,.71,"I")
  1.  . . . X ^DD(9002274.4,.71,1,2,2)
  1.  . . . X ^DD(9002274.4,.71,1,2,1)
  1.  . . . S DUZ(2)=BPMDUZ(2)
  1.  . . . S BPMCI=+$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,1)
  1.  . . . Q:'BPMCI
  1.  . . . S BPMCP=$P($G(^ABMDCLM(BPMDUZ2,BPMCI,0)),"^",1)
  1.  . . . Q:BPMCP'=+BPMCP
  1.  . . . I BPMCP'=BPMTO D
  1.  . . . . S BPMTMP(BPMCI)=""
  1.  . . . . D ONECLAIM^BPMX3PB(BPMDUZ2,BPMCI,BPMTO)
  1.  . . . . S BPMCNT=BPMCNT+1
  1.  . . I $D(BPMTMP) D
  1.  . . . I $O(BPMTMP($O(BPMTMP(0))))="" D HDR^BPMXFIX(BPMTO,BPMDUZ2,$O(BPMTMP(0)),,"Claim") Q
  1.  . . . D RSLT^BPMXFIX(""),HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Claim"),ENTRIES^BPMXFIX(.BPMTMP)
  1.  D RSLT^BPMXFIX("  *** Total Claim Corrections Found: "_BPMCNT_" ***")
  1.  N BPMDUZ2,BPMCP,BPMCH,BPMCI,BPMB,BPMBP,BPMBI,BPMV,BPMVP,BPMVI
  1.  S BPMDUZ2=0 F  S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2  D
  1.  . S BPMCP=0 F  S BPMCP=$O(^ABMDCLM(BPMDUZ2,"B",BPMCP)) Q:BPMCP'=+BPMCP  D
  1.  . . S BPMCH=$$HRN^BPMXFIX(BPMDUZ2,BPMCP)
  1.  . . Q:'$$MRG^BPMXFIX(BPMCP,"TO")&'$$MRG^BPMXFIX(BPMCH,"TO")
  1.  . . S BPMCI=0 F  S BPMCI=$O(^ABMDCLM(BPMDUZ2,"B",BPMCP,BPMCI)) Q:BPMCI'=+BPMCI  D
  1.  . . . Q:$P($G(^ABMDCLM(BPMDUZ2,BPMCI,0)),U)'=BPMCP
  1.  . . . ;
  1.  . . . S BPMB=$$BILL^BPMXFIX(BPMDUZ2,BPMCI),BPMBP=$P(BPMB,"^",1),BPMBI=$P(BPMB,"^",2)
  1.  . . . Q:BPMCP=BPMBP
  1.  . . . Q:'$$MRG^BPMXFIX(BPMBP,"TO")
  1.  . . . ;
  1.  . . . S BPMV=$$VSIT^BPMXFIX(BPMDUZ2,BPMCI),BPMVP=$P(BPMV,"^",1),BPMVI=$P(BPMV,"^",2)
  1.  . . . Q:(BPMCP=BPMVP)!(BPMCP=$$LAST^BPMXFIX(BPMVP))
  1.  . . . Q:'$$MRG^BPMXFIX(BPMVP,"TO")&'$$MRG^BPMXFIX(BPMVP,"FROM")
  1.  . . . I ($L(BPMBP_BPMVP)>0) D  Q
  1.  . . . . N BPMTO
  1.  . . . . S BPMTO=$$LAST^BPMXFIX($S($L(BPMBP)>0:BPMBP,$L(BPMVP)>0:BPMVP,1:0))
  1.  . . . . D HDR^BPMXFIX(BPMTO,BPMDUZ2,BPMCI)
  1.  . . . . D ONECLAIM^BPMX3PB(BPMDUZ2,BPMCI,BPMTO)
  1.  . . . D RSLT^BPMXFIX("The following Claim does not have Bill/Visit data for Patient comparisons")
  1.  . . . D HDR^BPMXFIX(BPMCP,BPMDUZ2,BPMCI)
  1.  . . . I ($L(BPMCH)>0)&$$MRG^BPMXFIX(BPMCH,"TO") D HDR^BPMXFIX($$LAST^BPMXFIX(BPMCH),BPMDUZ2,,,,"Possible owner")
  1.  Q
  1.  ;
  1. ATX ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX PT TAXONOMY ENTRIES
  1.  ;
  1.  N BPMCNT,BPMD0,BPMD1
  1.  ;
  1.  S (BPMCNT,BPMD0)=0
  1.  F  S BPMD0=$O(^ATXPAT(BPMD0)) Q:'BPMD0  D
  1.  . S BPMD1=0
  1.  . F  S BPMD1=$O(^ATXPAT(BPMD0,11,BPMD1)) Q:'BPMD1  D
  1.  . . Q:'$D(^TMP("BPM",$J,"FROM",BPMD1))
  1.  . . D HDR^BPMXFIX($$LAST^BPMXFIX(BPMD1),DUZ(2),BPMD0_","_BPMD1)
  1.  . . D ONE^BPMXTAX(BPMD0,BPMD1,BPMD1,$$LAST^BPMXFIX(BPMD1))
  1.  . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  ;
  1.  Q
  1.  ;
  1. BQI ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX ICARE ENTRIES
  1.  ;
  1.  ; REMOVE "AC" X-REF ON THE FROM PATIENT
  1.  N BPMCNT,I,BPMFR
  1.  S (BPMCNT,I)=0
  1.  F  S I=$O(^BQIPAT("AC",I)) Q:$L(I)<1  D
  1.  . S BPMFR=0
  1.  . F  S BPMFR=$O(^TMP("BPM",$J,"FROM",BPMFR)) Q:+BPMFR'=BPMFR  D
  1.  . . Q:'$D(^BQIPAT("AC",I,BPMFR))
  1.  . . K ^BQIPAT("AC",I,BPMFR)
  1.  . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** iCare Patient AC Index Total Found: "_BPMCNT_" ***")
  1.  ;
  1.  ; REPOINT ANY PANELS THE FROM PATIENT STILL EXISTS ON
  1.  N OWNR,PLIEN,UID,BPMD1,BPMCNT
  1.  S UID=$J,(OWNR,BPMCNT)=0
  1.  F  S OWNR=$O(^BQICARE(OWNR)) Q:+OWNR'=OWNR  D
  1.  . S PLIEN=0
  1.  . F  S PLIEN=$O(^BQICARE(OWNR,1,PLIEN)) Q:+PLIEN'=PLIEN  D
  1.  . . S BPMD1=0
  1.  . . F  S BPMD1=$O(^BQICARE(OWNR,1,PLIEN,40,BPMD1)) Q:+BPMD1'=BPMD1  D
  1.  . . . Q:'$D(^TMP("BPM",$J,"FROM",BPMD1))
  1.  . . . N DIC,DIE,DA,IENS,X,DATA,DINUM,DLAYGO,DIK,DO,DD
  1.  . . . S DATA=$G(^BQICARE(OWNR,1,PLIEN,40,BPMD1,0))
  1.  . . . ;
  1.  . . . S DA(2)=OWNR,DA(1)=PLIEN,DA=BPMD1
  1.  . . . ; Delete old record
  1.  . . . S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",40," D ^DIK
  1.  . . . ; Add new record
  1.  . . . S DA(2)=OWNR,DA(1)=PLIEN,(X,DINUM)=$$LAST^BPMXFIX(BPMD1)
  1.  . . . S DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",40,",DIE=DIC
  1.  . . . S DLAYGO=90505.04,DIC(0)="L",DIC("P")=DLAYGO
  1.  . . . I '$D(^BQICARE(DA(2),1,DA(1),40,0)) S ^BQICARE(DA(2),1,DA(1),40,0)="^90505.04P^^"
  1.  . . . K DO,DD D FILE^DICN
  1.  . . . S $P(^BQICARE(OWNR,1,PLIEN,40,$$LAST^BPMXFIX(BPMD1),0),U,2,99)=$P(DATA,U,2,99)
  1.  . . . D STA^BQIPLRF(OWNR,PLIEN)
  1.  . . . D ULK^BQIPLRF(OWNR,PLIEN)
  1.  . . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** iCare User Total Found: "_BPMCNT_" ***")
  1.  ;
  1.  Q
  1.  ;
  1. EDR ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 RESEND A40 MESSAGES FOR BADE
  1.  ;
  1.  Q:'$$PATCH^XPDUTL("BPM*1.0*1")!'$$PATCH^XPDUTL("BADE*1.0*1")
  1.  N XIEN
  1.  ;
  1.  S XIEN=0
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN  D
  1.  . N BPMFR,BPMTO,ERR
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,""))
  1.  . D A40^BADEMRG(BPMFR,BPMTO)
  1.  . I '$D(ERR) D HDR^BPMXFIX(BPMTO,DUZ(2),BPMFR,,"From Patient IEN")
  1.  . E  D RSLT^BPMXFIX($J("",2)_"EDR A40 MESSAGE FAILED: "_BPMFR_" -> "_BPMTO)
  1.  ;
  1.  Q
  1.  ;
  1. LAB ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX LAB ENTRIES
  1.  ;
  1.  N XIEN,BPMCNT1,BPMCNT2
  1.  ;
  1.  S (XIEN,BPMCNT1,BPMCNT2)=0
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN  D
  1.  . N BPMFR,BPMTO,XIENS,BLRFM,BLRNEW,BLROLD,BLRTO,XDRMRG,DA,DIE,DR,X,Y,I,J
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,"")),XIENS=$G(^TMP("BPM",$J,XIEN,BPMFR,BPMTO))
  1.  . D GETXLR
  1.  . ; QUIT IF FROM PATIENT DID NOT HAVE LAB DATA
  1.  . Q:'$D(BLROLD)
  1.  . S BPMTO=$$LAST^BPMXFIX(BPMFR)
  1.  . S (BLRFM,XDRMRG("FR"))=BPMFR,(BLRTO,XDRMRG("TO"))=BPMTO
  1.  . S BLRNEW=+$G(^DPT(BLRTO,"LR"))
  1.  . Q:'BLROLD&'BLRNEW
  1.  . ; CORRECT FIELD IF TO PATIENT DID NOT HAVE LAB DATA
  1.  . I BLROLD=BLRNEW D  Q
  1.  . . Q:$P(^LR(BLROLD,0),"^",3)=BLRTO
  1.  . . D HDR^BPMXFIX(BLRTO,DUZ(2),BLROLD,,"Lab Node")
  1.  . . S DIE="^LR("
  1.  . . S DA=BLROLD
  1.  . . S DR=".03////"_BLRTO
  1.  . . D ^DIE
  1.  . . S BPMCNT1=BPMCNT1+1
  1.  . Q:'$D(^LR(BLROLD,0))
  1.  . ;IHS/OIT/NKD BPM*1.0*2 STORE VALUES OF "AC" X-REF
  1.  . I $D(^LRO(68,"AC",BLROLD)) K ^TMP("BPM-LR",$J) M ^TMP("BPM-LR",$J,68,"AC",BLROLD)=^LRO(68,"AC",BLROLD)
  1.  . ;
  1.  . D HDR^BPMXFIX(BLRTO,DUZ(2),BLROLD,,"Lab Node")
  1.  . D MERGE^BLRMERG
  1.  . ;IHS/OIT/NKD BPM*1.0*2 RESTORE VALUES OF "AC" X-REF
  1.  . I $D(^TMP("BPM-LR",$J))  D
  1.  . . S I=0
  1.  . . F  S I=$O(^LRO(68,"AC",BLRNEW,I)) Q:+I'=I  D
  1.  . . . S J=0
  1.  . . . F  S J=$O(^LRO(68,"AC",BLRNEW,I,J)) Q:+J'=J  D
  1.  . . . . ; QUIT IF X-REF HAS A VALUE
  1.  . . . . Q:$L(^LRO(68,"AC",BLRNEW,I,J))>0
  1.  . . . . ; QUIT IF X-REF DID NOT COME FROM BLROLD
  1.  . . . . Q:'$D(^TMP("BPM-LR",$J,68,"AC",BLROLD,I,J))
  1.  . . . . S ^LRO(68,"AC",BLRNEW,I,J)=$G(^TMP("BPM-LR",$J,68,"AC",BLROLD,I,J))
  1.  . . K ^TMP("BPM-LR",$J)
  1.  . ;Repoint ^LR("BLRA") ESIG xref in Lab Data file #63
  1.  . D EN^BPMXLR2(BLRFM,BLRTO)
  1.  . S BPMCNT2=BPMCNT2+1
  1.  D RSLT^BPMXFIX("  *** Repoint Total Found: "_BPMCNT1_" ***")
  1.  D RSLT^BPMXFIX("  *** Merge Total Found: "_BPMCNT2_" ***")
  1.  ;
  1.  Q
  1.  ;
  1. MPI ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 RESEND A40 MESSAGES FOR MPI
  1.  ;
  1.  N X
  1.  S X="AGMPIHLO" X ^%ZOSF("TEST") Q:'$T
  1.  N XIEN
  1.  ;
  1.  S XIEN=0
  1.  F  S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN  D
  1.  . N BPMFR,BPMTO,SUCCESS
  1.  . S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,""))
  1.  . D CREATMSG^AGMPIHLO(BPMTO,"A40",BPMFR,.SUCCESS)
  1.  . I SUCCESS D HDR^BPMXFIX(BPMTO,DUZ(2),BPMFR,,"From Patient IEN")
  1.  . E  D RSLT^BPMXFIX($J("",2)_"MPI A40 MESSAGE FAILED: "_BPMFR_" -> "_BPMTO)
  1.  Q
  1.  ;
  1. PRB ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX PROBLEM LIST ENTRIES
  1.  ;
  1.  N BPMTO,BPMFR,BPMF,BPMS,BPMI,BPMN,BPMNS,BPMCNT,BPMHDR
  1.  S (BPMTO,BPMCNT)=0
  1.  F  S BPMTO=$O(^TMP("BPM",$J,"TO",BPMTO)) Q:+BPMTO'=BPMTO  D
  1.  . Q:BPMTO'=$$LAST^BPMXFIX(BPMTO)
  1.  . Q:'$D(^AUPNPROB("AA",BPMTO))
  1.  . S BPMF=0
  1.  . F  S BPMF=$O(^AUPNPROB("AA",BPMTO,BPMF)) Q:+BPMF'=BPMF  D
  1.  . . S BPMS="",BPMHDR=1
  1.  . . F  S BPMS=$O(^AUPNPROB("AA",BPMTO,BPMF,BPMS)) Q:$L(BPMS)<1  D
  1.  . . . S BPMI=$O(^AUPNPROB("AA",BPMTO,BPMF,BPMS,""))
  1.  . . . F  S BPMN=$O(^AUPNPROB("AA",BPMTO,BPMF,BPMS,BPMI)) Q:$L(BPMN)<1  D
  1.  . . . . N BPMOS
  1.  . . . . S BPMNS=$$NEXT^BPMXPRB(BPMTO,$$GET1^DIQ(9000011,BPMN,.06,"I")),BPMOS=$$GET1^DIQ(9000011,BPMN,.07,"I")
  1.  . . . . I BPMHDR D HDR^BPMXFIX(BPMTO,BPMF) S BPMHDR=0
  1.  . . . . D RSLT^BPMXFIX($J("",4)_"Duplicate Sequence: "_BPMOS_$J("",6-$L(BPMOS))_" New Sequence: "_BPMNS)
  1.  . . . . N FDA
  1.  . . . . S FDA(9000011,BPMN_",",.07)=BPMNS ; NMBR (.07)
  1.  . . . . D UPDATE^DIE(,"FDA",)
  1.  . . . . ; UPDATE MODIFIED X-REF
  1.  . . . . K ^AUPNPROB("MODIFIED",BPMTO)
  1.  . . . . S ^AUPNPROB("MODIFIED",BPMTO,$$NOW^XLFDT())=""
  1.  . . . . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  ; REMOVE MODIFIED X-REF ON ALL FROM PATIENTS
  1.  S BPMFR=0
  1.  F  S BPMFR=$O(^TMP("BPM",$J,"FROM",BPMFR)) Q:+BPMFR'=BPMFR  D
  1.  . K ^AUPNPROB("MODIFIED",BPMFR)
  1.  Q
  1.  ;
  1. VST ;EP
  1.  ;----- IHS/OIT/NKD BPM*1.0*2 FIX DELETED VISIT ENTRIES
  1.  ;
  1.  Q:$$GET1^DIQ(15.1,2,99999.01)'="YES"
  1.  ;
  1.  N BPMD0,BPMCNT
  1.  S (BPMCNT,BPMD0)=0
  1.  F  S BPMD0=$O(^AUPNVSIT(BPMD0)) Q:'BPMD0  D
  1.  . Q:$P(^AUPNVSIT(BPMD0,0),U,11)'=1            ;skip if not a deleted visit
  1.  . Q:+$P($G(^AUPNVSIT(BPMD0,0)),U,5)'=$P($G(^AUPNVSIT(BPMD0,0)),U,5)
  1.  . Q:'$D(^TMP("BPM",$J,"FROM",$P($G(^AUPNVSIT(BPMD0,0)),U,5)))
  1.  . S $P(^AUPNVSIT(BPMD0,0),U,5)=$$LAST^BPMXFIX($P($G(^AUPNVSIT(BPMD0,0)),U,5))
  1.  . S BPMCNT=BPMCNT+1
  1.  D RSLT^BPMXFIX("  *** Total Found: "_BPMCNT_" ***")
  1.  ;
  1.  Q
  1.  ;
  1. GETXLR ;
  1.  N XCNT,XDIEN,I,J,X,XFIL,XNOD
  1.  F XCNT=1:1:$L(XIENS,"^") D
  1.  . S XDIEN=$P(XIENS,"^",XCNT)
  1.  . S XFIL=0
  1.  . ; FIND THE MERGE IMAGE FILE
  1.  . F  S XFIL=$O(^XDRM(XDIEN,1,XFIL)) Q:+XFIL'=XFIL  D
  1.  . . Q:$P(^XDRM(XDIEN,1,XFIL,0),"^",1)'="VA PATIENT"
  1.  . . S XNOD=0
  1.  . . ; ITERATE THROUGH MERGE IMAGE NODES
  1.  . . F  S XNOD=$O(^XDRM(XDIEN,1,XFIL,1,XNOD)) Q:+XNOD'=XNOD  D
  1.  . . . Q:$G(^XDRM(XDIEN,1,XFIL,1,XNOD,0))'=("DPT("_BPMFR_",""LR"")")
  1.  . . . ; SET BLROLD
  1.  . . . S BLROLD=+$G(^XDRM(XDIEN,1,XFIL,1,XNOD,1))
  1.  Q