BPMXFX1 ;IHS/OIT/NKD - CLEANUP UTILITY - SPLIT INTO MULTIPLE ROUTINES - 7/23/12 ;
;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
;
Q
TPB ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX 3PB ENTRIES
;
N XIEN,BPMFR,BPMTO,BPMCNT,BPMCNT2,BPMHDR,BPMTMP
;
D RSLT^BPMXFIX("Merging remaining 3PB Claims and Bills...")
S (XIEN,BPMCNT,BPMCNT2)=0
F S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN D
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$$LAST^BPMXFIX(BPMFR),BPMHDR=1
. ; PROCESS CLAIMS
. N BPMDUZ2,BPMD0
. S BPMDUZ2=0 F S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2 D
. . N BPMTMP
. . S BPMD0=0 F S BPMD0=$O(^ABMDCLM(BPMDUZ2,"B",BPMFR,BPMD0)) Q:BPMD0'=+BPMD0 D
. . . Q:$P($G(^ABMDCLM(BPMDUZ2,BPMD0,0)),U)'=BPMFR
. . . S BPMTMP(BPMD0)=""
. . . D ONECLAIM^BPMX3PB(BPMDUZ2,BPMD0,BPMTO)
. . . S BPMCNT=BPMCNT+1
. . I $D(BPMTMP) D
. . . I $O(BPMTMP($O(BPMTMP(0))))="" D HDR^BPMXFIX(BPMTO,BPMDUZ2,$O(BPMTMP(0)),,"Claim") Q
. . . D RSLT^BPMXFIX(""),HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Claim"),ENTRIES^BPMXFIX(.BPMTMP)
. ; PROCESS BILLS
. N BPMDUZ2,BPMD0
. S BPMDUZ2=0 F S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2 D
. . N BPMTMP
. . S BPMD0=0 F S BPMD0=$O(^ABMDBILL(BPMDUZ2,"D",BPMFR,BPMD0)) Q:BPMD0'=+BPMD0 D
. . . Q:$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMFR
. . . N BPMB S BPMB=$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,1)
. . . S BPMTMP(BPMB)=""
. . . D ONEBILL^BPMX3PB(BPMDUZ2,BPMD0,BPMTO)
. . . S BPMCNT2=BPMCNT2+1
. . I $D(BPMTMP) D
. . . I $O(BPMTMP($O(BPMTMP(0))))="" D HDR^BPMXFIX(BPMTO,BPMDUZ2,$O(BPMTMP(0)),,"Bill") Q
. . . D RSLT^BPMXFIX(""),HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Bill"),ENTRIES^BPMXFIX(.BPMTMP)
D RSLT^BPMXFIX(" *** Total Claims Found: "_BPMCNT_" ***")
D RSLT^BPMXFIX(" *** Total Bills Found: "_BPMCNT2_" ***")
; RE-INDEX "ADR" X-REF ON ALL MERGED TO BILLS
; CORRECT CLAIM PATIENT IF DIFFERENT
N BPMCNT,BPMD0,BPMDUZ2,BPMDUZ,BPMTO,DA,X,BPMCI,BPMCP
D RSLT^BPMXFIX("Correcting improperly merged Claims...")
S (BPMDUZ2,BPMCNT)=0
F S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2 D
. S BPMTO=0 F S BPMTO=$O(^TMP("BPM",$J,"TO",BPMTO)) Q:BPMTO'=+BPMTO D
. . N BPMTMP
. . S BPMHDR=1
. . S BPMD0=0 F S BPMD0=$O(^ABMDBILL(BPMDUZ2,"D",BPMTO,BPMD0)) Q:BPMD0'=+BPMD0 D
. . . Q:$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMTO
. . . S BPMDUZ(2)=DUZ(2),DUZ(2)=BPMDUZ2
. . . S DA=BPMD0
. . . S X=$$GET1^DIQ(9002274.4,BPMD0,.71,"I")
. . . X ^DD(9002274.4,.71,1,2,2)
. . . X ^DD(9002274.4,.71,1,2,1)
. . . S DUZ(2)=BPMDUZ(2)
. . . S BPMCI=+$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,1)
. . . Q:'BPMCI
. . . S BPMCP=$P($G(^ABMDCLM(BPMDUZ2,BPMCI,0)),"^",1)
. . . Q:BPMCP'=+BPMCP
. . . I BPMCP'=BPMTO D
. . . . S BPMTMP(BPMCI)=""
. . . . D ONECLAIM^BPMX3PB(BPMDUZ2,BPMCI,BPMTO)
. . . . S BPMCNT=BPMCNT+1
. . I $D(BPMTMP) D
. . . I $O(BPMTMP($O(BPMTMP(0))))="" D HDR^BPMXFIX(BPMTO,BPMDUZ2,$O(BPMTMP(0)),,"Claim") Q
. . . D RSLT^BPMXFIX(""),HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Claim"),ENTRIES^BPMXFIX(.BPMTMP)
D RSLT^BPMXFIX(" *** Total Claim Corrections Found: "_BPMCNT_" ***")
N BPMDUZ2,BPMCP,BPMCH,BPMCI,BPMB,BPMBP,BPMBI,BPMV,BPMVP,BPMVI
S BPMDUZ2=0 F S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:BPMDUZ2'=+BPMDUZ2 D
. S BPMCP=0 F S BPMCP=$O(^ABMDCLM(BPMDUZ2,"B",BPMCP)) Q:BPMCP'=+BPMCP D
. . S BPMCH=$$HRN^BPMXFIX(BPMDUZ2,BPMCP)
. . Q:'$$MRG^BPMXFIX(BPMCP,"TO")&'$$MRG^BPMXFIX(BPMCH,"TO")
. . S BPMCI=0 F S BPMCI=$O(^ABMDCLM(BPMDUZ2,"B",BPMCP,BPMCI)) Q:BPMCI'=+BPMCI D
. . . Q:$P($G(^ABMDCLM(BPMDUZ2,BPMCI,0)),U)'=BPMCP
. . . ;
. . . S BPMB=$$BILL^BPMXFIX(BPMDUZ2,BPMCI),BPMBP=$P(BPMB,"^",1),BPMBI=$P(BPMB,"^",2)
. . . Q:BPMCP=BPMBP
. . . Q:'$$MRG^BPMXFIX(BPMBP,"TO")
. . . ;
. . . S BPMV=$$VSIT^BPMXFIX(BPMDUZ2,BPMCI),BPMVP=$P(BPMV,"^",1),BPMVI=$P(BPMV,"^",2)
. . . Q:(BPMCP=BPMVP)!(BPMCP=$$LAST^BPMXFIX(BPMVP))
. . . Q:'$$MRG^BPMXFIX(BPMVP,"TO")&'$$MRG^BPMXFIX(BPMVP,"FROM")
. . . I ($L(BPMBP_BPMVP)>0) D Q
. . . . N BPMTO
. . . . S BPMTO=$$LAST^BPMXFIX($S($L(BPMBP)>0:BPMBP,$L(BPMVP)>0:BPMVP,1:0))
. . . . D HDR^BPMXFIX(BPMTO,BPMDUZ2,BPMCI)
. . . . D ONECLAIM^BPMX3PB(BPMDUZ2,BPMCI,BPMTO)
. . . D RSLT^BPMXFIX("The following Claim does not have Bill/Visit data for Patient comparisons")
. . . D HDR^BPMXFIX(BPMCP,BPMDUZ2,BPMCI)
. . . I ($L(BPMCH)>0)&$$MRG^BPMXFIX(BPMCH,"TO") D HDR^BPMXFIX($$LAST^BPMXFIX(BPMCH),BPMDUZ2,,,,"Possible owner")
Q
;
ATX ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX PT TAXONOMY ENTRIES
;
N BPMCNT,BPMD0,BPMD1
;
S (BPMCNT,BPMD0)=0
F S BPMD0=$O(^ATXPAT(BPMD0)) Q:'BPMD0 D
. S BPMD1=0
. F S BPMD1=$O(^ATXPAT(BPMD0,11,BPMD1)) Q:'BPMD1 D
. . Q:'$D(^TMP("BPM",$J,"FROM",BPMD1))
. . D HDR^BPMXFIX($$LAST^BPMXFIX(BPMD1),DUZ(2),BPMD0_","_BPMD1)
. . D ONE^BPMXTAX(BPMD0,BPMD1,BPMD1,$$LAST^BPMXFIX(BPMD1))
. . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
;
Q
;
BQI ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX ICARE ENTRIES
;
; REMOVE "AC" X-REF ON THE FROM PATIENT
N BPMCNT,I,BPMFR
S (BPMCNT,I)=0
F S I=$O(^BQIPAT("AC",I)) Q:$L(I)<1 D
. S BPMFR=0
. F S BPMFR=$O(^TMP("BPM",$J,"FROM",BPMFR)) Q:+BPMFR'=BPMFR D
. . Q:'$D(^BQIPAT("AC",I,BPMFR))
. . K ^BQIPAT("AC",I,BPMFR)
. . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** iCare Patient AC Index Total Found: "_BPMCNT_" ***")
;
; REPOINT ANY PANELS THE FROM PATIENT STILL EXISTS ON
N OWNR,PLIEN,UID,BPMD1,BPMCNT
S UID=$J,(OWNR,BPMCNT)=0
F S OWNR=$O(^BQICARE(OWNR)) Q:+OWNR'=OWNR D
. S PLIEN=0
. F S PLIEN=$O(^BQICARE(OWNR,1,PLIEN)) Q:+PLIEN'=PLIEN D
. . S BPMD1=0
. . F S BPMD1=$O(^BQICARE(OWNR,1,PLIEN,40,BPMD1)) Q:+BPMD1'=BPMD1 D
. . . Q:'$D(^TMP("BPM",$J,"FROM",BPMD1))
. . . N DIC,DIE,DA,IENS,X,DATA,DINUM,DLAYGO,DIK,DO,DD
. . . S DATA=$G(^BQICARE(OWNR,1,PLIEN,40,BPMD1,0))
. . . ;
. . . S DA(2)=OWNR,DA(1)=PLIEN,DA=BPMD1
. . . ; Delete old record
. . . S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",40," D ^DIK
. . . ; Add new record
. . . S DA(2)=OWNR,DA(1)=PLIEN,(X,DINUM)=$$LAST^BPMXFIX(BPMD1)
. . . S DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",40,",DIE=DIC
. . . S DLAYGO=90505.04,DIC(0)="L",DIC("P")=DLAYGO
. . . I '$D(^BQICARE(DA(2),1,DA(1),40,0)) S ^BQICARE(DA(2),1,DA(1),40,0)="^90505.04P^^"
. . . K DO,DD D FILE^DICN
. . . S $P(^BQICARE(OWNR,1,PLIEN,40,$$LAST^BPMXFIX(BPMD1),0),U,2,99)=$P(DATA,U,2,99)
. . . D STA^BQIPLRF(OWNR,PLIEN)
. . . D ULK^BQIPLRF(OWNR,PLIEN)
. . . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** iCare User Total Found: "_BPMCNT_" ***")
;
Q
;
EDR ;EP
;----- IHS/OIT/NKD BPM*1.0*2 RESEND A40 MESSAGES FOR BADE
;
Q:'$$PATCH^XPDUTL("BPM*1.0*1")!'$$PATCH^XPDUTL("BADE*1.0*1")
N XIEN
;
S XIEN=0
F S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN D
. N BPMFR,BPMTO,ERR
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,""))
. D A40^BADEMRG(BPMFR,BPMTO)
. I '$D(ERR) D HDR^BPMXFIX(BPMTO,DUZ(2),BPMFR,,"From Patient IEN")
. E D RSLT^BPMXFIX($J("",2)_"EDR A40 MESSAGE FAILED: "_BPMFR_" -> "_BPMTO)
;
Q
;
LAB ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX LAB ENTRIES
;
N XIEN,BPMCNT1,BPMCNT2
;
S (XIEN,BPMCNT1,BPMCNT2)=0
F S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN D
. N BPMFR,BPMTO,XIENS,BLRFM,BLRNEW,BLROLD,BLRTO,XDRMRG,DA,DIE,DR,X,Y,I,J
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,"")),XIENS=$G(^TMP("BPM",$J,XIEN,BPMFR,BPMTO))
. D GETXLR
. ; QUIT IF FROM PATIENT DID NOT HAVE LAB DATA
. Q:'$D(BLROLD)
. S BPMTO=$$LAST^BPMXFIX(BPMFR)
. S (BLRFM,XDRMRG("FR"))=BPMFR,(BLRTO,XDRMRG("TO"))=BPMTO
. S BLRNEW=+$G(^DPT(BLRTO,"LR"))
. Q:'BLROLD&'BLRNEW
. ; CORRECT FIELD IF TO PATIENT DID NOT HAVE LAB DATA
. I BLROLD=BLRNEW D Q
. . Q:$P(^LR(BLROLD,0),"^",3)=BLRTO
. . D HDR^BPMXFIX(BLRTO,DUZ(2),BLROLD,,"Lab Node")
. . S DIE="^LR("
. . S DA=BLROLD
. . S DR=".03////"_BLRTO
. . D ^DIE
. . S BPMCNT1=BPMCNT1+1
. Q:'$D(^LR(BLROLD,0))
. ;IHS/OIT/NKD BPM*1.0*2 STORE VALUES OF "AC" X-REF
. I $D(^LRO(68,"AC",BLROLD)) K ^TMP("BPM-LR",$J) M ^TMP("BPM-LR",$J,68,"AC",BLROLD)=^LRO(68,"AC",BLROLD)
. ;
. D HDR^BPMXFIX(BLRTO,DUZ(2),BLROLD,,"Lab Node")
. D MERGE^BLRMERG
. ;IHS/OIT/NKD BPM*1.0*2 RESTORE VALUES OF "AC" X-REF
. I $D(^TMP("BPM-LR",$J)) D
. . S I=0
. . F S I=$O(^LRO(68,"AC",BLRNEW,I)) Q:+I'=I D
. . . S J=0
. . . F S J=$O(^LRO(68,"AC",BLRNEW,I,J)) Q:+J'=J D
. . . . ; QUIT IF X-REF HAS A VALUE
. . . . Q:$L(^LRO(68,"AC",BLRNEW,I,J))>0
. . . . ; QUIT IF X-REF DID NOT COME FROM BLROLD
. . . . Q:'$D(^TMP("BPM-LR",$J,68,"AC",BLROLD,I,J))
. . . . S ^LRO(68,"AC",BLRNEW,I,J)=$G(^TMP("BPM-LR",$J,68,"AC",BLROLD,I,J))
. . K ^TMP("BPM-LR",$J)
. ;Repoint ^LR("BLRA") ESIG xref in Lab Data file #63
. D EN^BPMXLR2(BLRFM,BLRTO)
. S BPMCNT2=BPMCNT2+1
D RSLT^BPMXFIX(" *** Repoint Total Found: "_BPMCNT1_" ***")
D RSLT^BPMXFIX(" *** Merge Total Found: "_BPMCNT2_" ***")
;
Q
;
MPI ;EP
;----- IHS/OIT/NKD BPM*1.0*2 RESEND A40 MESSAGES FOR MPI
;
N X
S X="AGMPIHLO" X ^%ZOSF("TEST") Q:'$T
N XIEN
;
S XIEN=0
F S XIEN=$O(^TMP("BPM",$J,XIEN)) Q:+XIEN'=XIEN D
. N BPMFR,BPMTO,SUCCESS
. S BPMFR=$O(^TMP("BPM",$J,XIEN,"")),BPMTO=$O(^TMP("BPM",$J,XIEN,BPMFR,""))
. D CREATMSG^AGMPIHLO(BPMTO,"A40",BPMFR,.SUCCESS)
. I SUCCESS D HDR^BPMXFIX(BPMTO,DUZ(2),BPMFR,,"From Patient IEN")
. E D RSLT^BPMXFIX($J("",2)_"MPI A40 MESSAGE FAILED: "_BPMFR_" -> "_BPMTO)
Q
;
PRB ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX PROBLEM LIST ENTRIES
;
N BPMTO,BPMFR,BPMF,BPMS,BPMI,BPMN,BPMNS,BPMCNT,BPMHDR
S (BPMTO,BPMCNT)=0
F S BPMTO=$O(^TMP("BPM",$J,"TO",BPMTO)) Q:+BPMTO'=BPMTO D
. Q:BPMTO'=$$LAST^BPMXFIX(BPMTO)
. Q:'$D(^AUPNPROB("AA",BPMTO))
. S BPMF=0
. F S BPMF=$O(^AUPNPROB("AA",BPMTO,BPMF)) Q:+BPMF'=BPMF D
. . S BPMS="",BPMHDR=1
. . F S BPMS=$O(^AUPNPROB("AA",BPMTO,BPMF,BPMS)) Q:$L(BPMS)<1 D
. . . S BPMI=$O(^AUPNPROB("AA",BPMTO,BPMF,BPMS,""))
. . . F S BPMN=$O(^AUPNPROB("AA",BPMTO,BPMF,BPMS,BPMI)) Q:$L(BPMN)<1 D
. . . . N BPMOS
. . . . S BPMNS=$$NEXT^BPMXPRB(BPMTO,$$GET1^DIQ(9000011,BPMN,.06,"I")),BPMOS=$$GET1^DIQ(9000011,BPMN,.07,"I")
. . . . I BPMHDR D HDR^BPMXFIX(BPMTO,BPMF) S BPMHDR=0
. . . . D RSLT^BPMXFIX($J("",4)_"Duplicate Sequence: "_BPMOS_$J("",6-$L(BPMOS))_" New Sequence: "_BPMNS)
. . . . N FDA
. . . . S FDA(9000011,BPMN_",",.07)=BPMNS ; NMBR (.07)
. . . . D UPDATE^DIE(,"FDA",)
. . . . ; UPDATE MODIFIED X-REF
. . . . K ^AUPNPROB("MODIFIED",BPMTO)
. . . . S ^AUPNPROB("MODIFIED",BPMTO,$$NOW^XLFDT())=""
. . . . S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
; REMOVE MODIFIED X-REF ON ALL FROM PATIENTS
S BPMFR=0
F S BPMFR=$O(^TMP("BPM",$J,"FROM",BPMFR)) Q:+BPMFR'=BPMFR D
. K ^AUPNPROB("MODIFIED",BPMFR)
Q
;
VST ;EP
;----- IHS/OIT/NKD BPM*1.0*2 FIX DELETED VISIT ENTRIES
;
Q:$$GET1^DIQ(15.1,2,99999.01)'="YES"
;
N BPMD0,BPMCNT
S (BPMCNT,BPMD0)=0
F S BPMD0=$O(^AUPNVSIT(BPMD0)) Q:'BPMD0 D
. Q:$P(^AUPNVSIT(BPMD0,0),U,11)'=1 ;skip if not a deleted visit
. Q:+$P($G(^AUPNVSIT(BPMD0,0)),U,5)'=$P($G(^AUPNVSIT(BPMD0,0)),U,5)
. Q:'$D(^TMP("BPM",$J,"FROM",$P($G(^AUPNVSIT(BPMD0,0)),U,5)))
. S $P(^AUPNVSIT(BPMD0,0),U,5)=$$LAST^BPMXFIX($P($G(^AUPNVSIT(BPMD0,0)),U,5))
. S BPMCNT=BPMCNT+1
D RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
;
Q
;
GETXLR ;
N XCNT,XDIEN,I,J,X,XFIL,XNOD
F XCNT=1:1:$L(XIENS,"^") D
. S XDIEN=$P(XIENS,"^",XCNT)
. S XFIL=0
. ; FIND THE MERGE IMAGE FILE
. F S XFIL=$O(^XDRM(XDIEN,1,XFIL)) Q:+XFIL'=XFIL D
. . Q:$P(^XDRM(XDIEN,1,XFIL,0),"^",1)'="VA PATIENT"
. . S XNOD=0
. . ; ITERATE THROUGH MERGE IMAGE NODES
. . F S XNOD=$O(^XDRM(XDIEN,1,XFIL,1,XNOD)) Q:+XNOD'=XNOD D
. . . Q:$G(^XDRM(XDIEN,1,XFIL,1,XNOD,0))'=("DPT("_BPMFR_",""LR"")")
. . . ; SET BLROLD
. . . S BLROLD=+$G(^XDRM(XDIEN,1,XFIL,1,XNOD,1))
Q
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
+2 ;
+3 QUIT
TPB ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX 3PB ENTRIES
+2 ;
+3 NEW XIEN,BPMFR,BPMTO,BPMCNT,BPMCNT2,BPMHDR,BPMTMP
+4 ;
+5 DO RSLT^BPMXFIX("Merging remaining 3PB Claims and Bills...")
+6 SET (XIEN,BPMCNT,BPMCNT2)=0
+7 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN))
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+8 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET BPMTO=$$LAST^BPMXFIX(BPMFR)
SET BPMHDR=1
+9 ; PROCESS CLAIMS
+10 NEW BPMDUZ2,BPMD0
+11 SET BPMDUZ2=0
FOR
SET BPMDUZ2=$ORDER(^ABMDCLM(BPMDUZ2))
IF BPMDUZ2'=+BPMDUZ2
QUIT
Begin DoDot:2
+12 NEW BPMTMP
+13 SET BPMD0=0
FOR
SET BPMD0=$ORDER(^ABMDCLM(BPMDUZ2,"B",BPMFR,BPMD0))
IF BPMD0'=+BPMD0
QUIT
Begin DoDot:3
+14 IF $PIECE($GET(^ABMDCLM(BPMDUZ2,BPMD0,0)),U)'=BPMFR
QUIT
+15 SET BPMTMP(BPMD0)=""
+16 DO ONECLAIM^BPMX3PB(BPMDUZ2,BPMD0,BPMTO)
+17 SET BPMCNT=BPMCNT+1
End DoDot:3
+18 IF $DATA(BPMTMP)
Begin DoDot:3
+19 IF $ORDER(BPMTMP($ORDER(BPMTMP(0))))=""
DO HDR^BPMXFIX(BPMTO,BPMDUZ2,$ORDER(BPMTMP(0)),,"Claim")
QUIT
+20 DO RSLT^BPMXFIX("")
DO HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Claim")
DO ENTRIES^BPMXFIX(.BPMTMP)
End DoDot:3
End DoDot:2
+21 ; PROCESS BILLS
+22 NEW BPMDUZ2,BPMD0
+23 SET BPMDUZ2=0
FOR
SET BPMDUZ2=$ORDER(^ABMDBILL(BPMDUZ2))
IF BPMDUZ2'=+BPMDUZ2
QUIT
Begin DoDot:2
+24 NEW BPMTMP
+25 SET BPMD0=0
FOR
SET BPMD0=$ORDER(^ABMDBILL(BPMDUZ2,"D",BPMFR,BPMD0))
IF BPMD0'=+BPMD0
QUIT
Begin DoDot:3
+26 IF $PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMFR
QUIT
+27 NEW BPMB
SET BPMB=$PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,1)
+28 SET BPMTMP(BPMB)=""
+29 DO ONEBILL^BPMX3PB(BPMDUZ2,BPMD0,BPMTO)
+30 SET BPMCNT2=BPMCNT2+1
End DoDot:3
+31 IF $DATA(BPMTMP)
Begin DoDot:3
+32 IF $ORDER(BPMTMP($ORDER(BPMTMP(0))))=""
DO HDR^BPMXFIX(BPMTO,BPMDUZ2,$ORDER(BPMTMP(0)),,"Bill")
QUIT
+33 DO RSLT^BPMXFIX("")
DO HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Bill")
DO ENTRIES^BPMXFIX(.BPMTMP)
End DoDot:3
End DoDot:2
End DoDot:1
+34 DO RSLT^BPMXFIX(" *** Total Claims Found: "_BPMCNT_" ***")
+35 DO RSLT^BPMXFIX(" *** Total Bills Found: "_BPMCNT2_" ***")
+36 ; RE-INDEX "ADR" X-REF ON ALL MERGED TO BILLS
+37 ; CORRECT CLAIM PATIENT IF DIFFERENT
+38 NEW BPMCNT,BPMD0,BPMDUZ2,BPMDUZ,BPMTO,DA,X,BPMCI,BPMCP
+39 DO RSLT^BPMXFIX("Correcting improperly merged Claims...")
+40 SET (BPMDUZ2,BPMCNT)=0
+41 FOR
SET BPMDUZ2=$ORDER(^ABMDBILL(BPMDUZ2))
IF BPMDUZ2'=+BPMDUZ2
QUIT
Begin DoDot:1
+42 SET BPMTO=0
FOR
SET BPMTO=$ORDER(^TMP("BPM",$JOB,"TO",BPMTO))
IF BPMTO'=+BPMTO
QUIT
Begin DoDot:2
+43 NEW BPMTMP
+44 SET BPMHDR=1
+45 SET BPMD0=0
FOR
SET BPMD0=$ORDER(^ABMDBILL(BPMDUZ2,"D",BPMTO,BPMD0))
IF BPMD0'=+BPMD0
QUIT
Begin DoDot:3
+46 IF $PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMTO
QUIT
+47 SET BPMDUZ(2)=DUZ(2)
SET DUZ(2)=BPMDUZ2
+48 SET DA=BPMD0
+49 SET X=$$GET1^DIQ(9002274.4,BPMD0,.71,"I")
+50 XECUTE ^DD(9002274.4,.71,1,2,2)
+51 XECUTE ^DD(9002274.4,.71,1,2,1)
+52 SET DUZ(2)=BPMDUZ(2)
+53 SET BPMCI=+$PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,1)
+54 IF 'BPMCI
QUIT
+55 SET BPMCP=$PIECE($GET(^ABMDCLM(BPMDUZ2,BPMCI,0)),"^",1)
+56 IF BPMCP'=+BPMCP
QUIT
+57 IF BPMCP'=BPMTO
Begin DoDot:4
+58 SET BPMTMP(BPMCI)=""
+59 DO ONECLAIM^BPMX3PB(BPMDUZ2,BPMCI,BPMTO)
+60 SET BPMCNT=BPMCNT+1
End DoDot:4
End DoDot:3
+61 IF $DATA(BPMTMP)
Begin DoDot:3
+62 IF $ORDER(BPMTMP($ORDER(BPMTMP(0))))=""
DO HDR^BPMXFIX(BPMTO,BPMDUZ2,$ORDER(BPMTMP(0)),,"Claim")
QUIT
+63 DO RSLT^BPMXFIX("")
DO HDR^BPMXFIX(BPMTO,BPMDUZ2,,,"Claim")
DO ENTRIES^BPMXFIX(.BPMTMP)
End DoDot:3
End DoDot:2
End DoDot:1
+64 DO RSLT^BPMXFIX(" *** Total Claim Corrections Found: "_BPMCNT_" ***")
+65 NEW BPMDUZ2,BPMCP,BPMCH,BPMCI,BPMB,BPMBP,BPMBI,BPMV,BPMVP,BPMVI
+66 SET BPMDUZ2=0
FOR
SET BPMDUZ2=$ORDER(^ABMDCLM(BPMDUZ2))
IF BPMDUZ2'=+BPMDUZ2
QUIT
Begin DoDot:1
+67 SET BPMCP=0
FOR
SET BPMCP=$ORDER(^ABMDCLM(BPMDUZ2,"B",BPMCP))
IF BPMCP'=+BPMCP
QUIT
Begin DoDot:2
+68 SET BPMCH=$$HRN^BPMXFIX(BPMDUZ2,BPMCP)
+69 IF '$$MRG^BPMXFIX(BPMCP,"TO")&'$$MRG^BPMXFIX(BPMCH,"TO")
QUIT
+70 SET BPMCI=0
FOR
SET BPMCI=$ORDER(^ABMDCLM(BPMDUZ2,"B",BPMCP,BPMCI))
IF BPMCI'=+BPMCI
QUIT
Begin DoDot:3
+71 IF $PIECE($GET(^ABMDCLM(BPMDUZ2,BPMCI,0)),U)'=BPMCP
QUIT
+72 ;
+73 SET BPMB=$$BILL^BPMXFIX(BPMDUZ2,BPMCI)
SET BPMBP=$PIECE(BPMB,"^",1)
SET BPMBI=$PIECE(BPMB,"^",2)
+74 IF BPMCP=BPMBP
QUIT
+75 IF '$$MRG^BPMXFIX(BPMBP,"TO")
QUIT
+76 ;
+77 SET BPMV=$$VSIT^BPMXFIX(BPMDUZ2,BPMCI)
SET BPMVP=$PIECE(BPMV,"^",1)
SET BPMVI=$PIECE(BPMV,"^",2)
+78 IF (BPMCP=BPMVP)!(BPMCP=$$LAST^BPMXFIX(BPMVP))
QUIT
+79 IF '$$MRG^BPMXFIX(BPMVP,"TO")&'$$MRG^BPMXFIX(BPMVP,"FROM")
QUIT
+80 IF ($LENGTH(BPMBP_BPMVP)>0)
Begin DoDot:4
+81 NEW BPMTO
+82 SET BPMTO=$$LAST^BPMXFIX($SELECT($LENGTH(BPMBP)>0:BPMBP,$LENGTH(BPMVP)>0:BPMVP,1:0))
+83 DO HDR^BPMXFIX(BPMTO,BPMDUZ2,BPMCI)
+84 DO ONECLAIM^BPMX3PB(BPMDUZ2,BPMCI,BPMTO)
End DoDot:4
QUIT
+85 DO RSLT^BPMXFIX("The following Claim does not have Bill/Visit data for Patient comparisons")
+86 DO HDR^BPMXFIX(BPMCP,BPMDUZ2,BPMCI)
+87 IF ($LENGTH(BPMCH)>0)&$$MRG^BPMXFIX(BPMCH,"TO")
DO HDR^BPMXFIX($$LAST^BPMXFIX(BPMCH),BPMDUZ2,,,,"Possible owner")
End DoDot:3
End DoDot:2
End DoDot:1
+88 QUIT
+89 ;
ATX ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX PT TAXONOMY ENTRIES
+2 ;
+3 NEW BPMCNT,BPMD0,BPMD1
+4 ;
+5 SET (BPMCNT,BPMD0)=0
+6 FOR
SET BPMD0=$ORDER(^ATXPAT(BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+7 SET BPMD1=0
+8 FOR
SET BPMD1=$ORDER(^ATXPAT(BPMD0,11,BPMD1))
IF 'BPMD1
QUIT
Begin DoDot:2
+9 IF '$DATA(^TMP("BPM",$JOB,"FROM",BPMD1))
QUIT
+10 DO HDR^BPMXFIX($$LAST^BPMXFIX(BPMD1),DUZ(2),BPMD0_","_BPMD1)
+11 DO ONE^BPMXTAX(BPMD0,BPMD1,BPMD1,$$LAST^BPMXFIX(BPMD1))
+12 SET BPMCNT=BPMCNT+1
End DoDot:2
End DoDot:1
+13 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+14 ;
+15 QUIT
+16 ;
BQI ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX ICARE ENTRIES
+2 ;
+3 ; REMOVE "AC" X-REF ON THE FROM PATIENT
+4 NEW BPMCNT,I,BPMFR
+5 SET (BPMCNT,I)=0
+6 FOR
SET I=$ORDER(^BQIPAT("AC",I))
IF $LENGTH(I)<1
QUIT
Begin DoDot:1
+7 SET BPMFR=0
+8 FOR
SET BPMFR=$ORDER(^TMP("BPM",$JOB,"FROM",BPMFR))
IF +BPMFR'=BPMFR
QUIT
Begin DoDot:2
+9 IF '$DATA(^BQIPAT("AC",I,BPMFR))
QUIT
+10 KILL ^BQIPAT("AC",I,BPMFR)
+11 SET BPMCNT=BPMCNT+1
End DoDot:2
End DoDot:1
+12 DO RSLT^BPMXFIX(" *** iCare Patient AC Index Total Found: "_BPMCNT_" ***")
+13 ;
+14 ; REPOINT ANY PANELS THE FROM PATIENT STILL EXISTS ON
+15 NEW OWNR,PLIEN,UID,BPMD1,BPMCNT
+16 SET UID=$JOB
SET (OWNR,BPMCNT)=0
+17 FOR
SET OWNR=$ORDER(^BQICARE(OWNR))
IF +OWNR'=OWNR
QUIT
Begin DoDot:1
+18 SET PLIEN=0
+19 FOR
SET PLIEN=$ORDER(^BQICARE(OWNR,1,PLIEN))
IF +PLIEN'=PLIEN
QUIT
Begin DoDot:2
+20 SET BPMD1=0
+21 FOR
SET BPMD1=$ORDER(^BQICARE(OWNR,1,PLIEN,40,BPMD1))
IF +BPMD1'=BPMD1
QUIT
Begin DoDot:3
+22 IF '$DATA(^TMP("BPM",$JOB,"FROM",BPMD1))
QUIT
+23 NEW DIC,DIE,DA,IENS,X,DATA,DINUM,DLAYGO,DIK,DO,DD
+24 SET DATA=$GET(^BQICARE(OWNR,1,PLIEN,40,BPMD1,0))
+25 ;
+26 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=BPMD1
+27 ; Delete old record
+28 SET DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",40,"
DO ^DIK
+29 ; Add new record
+30 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET (X,DINUM)=$$LAST^BPMXFIX(BPMD1)
+31 SET DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",40,"
SET DIE=DIC
+32 SET DLAYGO=90505.04
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+33 IF '$DATA(^BQICARE(DA(2),1,DA(1),40,0))
SET ^BQICARE(DA(2),1,DA(1),40,0)="^90505.04P^^"
+34 KILL DO,DD
DO FILE^DICN
+35 SET $PIECE(^BQICARE(OWNR,1,PLIEN,40,$$LAST^BPMXFIX(BPMD1),0),U,2,99)=$PIECE(DATA,U,2,99)
+36 DO STA^BQIPLRF(OWNR,PLIEN)
+37 DO ULK^BQIPLRF(OWNR,PLIEN)
+38 SET BPMCNT=BPMCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+39 DO RSLT^BPMXFIX(" *** iCare User Total Found: "_BPMCNT_" ***")
+40 ;
+41 QUIT
+42 ;
EDR ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 RESEND A40 MESSAGES FOR BADE
+2 ;
+3 IF '$$PATCH^XPDUTL("BPM*1.0*1")!'$$PATCH^XPDUTL("BADE*1.0*1")
QUIT
+4 NEW XIEN
+5 ;
+6 SET XIEN=0
+7 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN))
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+8 NEW BPMFR,BPMTO,ERR
+9 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET BPMTO=$ORDER(^TMP("BPM",$JOB,XIEN,BPMFR,""))
+10 DO A40^BADEMRG(BPMFR,BPMTO)
+11 IF '$DATA(ERR)
DO HDR^BPMXFIX(BPMTO,DUZ(2),BPMFR,,"From Patient IEN")
+12 IF '$TEST
DO RSLT^BPMXFIX($JUSTIFY("",2)_"EDR A40 MESSAGE FAILED: "_BPMFR_" -> "_BPMTO)
End DoDot:1
+13 ;
+14 QUIT
+15 ;
LAB ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX LAB ENTRIES
+2 ;
+3 NEW XIEN,BPMCNT1,BPMCNT2
+4 ;
+5 SET (XIEN,BPMCNT1,BPMCNT2)=0
+6 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN))
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+7 NEW BPMFR,BPMTO,XIENS,BLRFM,BLRNEW,BLROLD,BLRTO,XDRMRG,DA,DIE,DR,X,Y,I,J
+8 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET BPMTO=$ORDER(^TMP("BPM",$JOB,XIEN,BPMFR,""))
SET XIENS=$GET(^TMP("BPM",$JOB,XIEN,BPMFR,BPMTO))
+9 DO GETXLR
+10 ; QUIT IF FROM PATIENT DID NOT HAVE LAB DATA
+11 IF '$DATA(BLROLD)
QUIT
+12 SET BPMTO=$$LAST^BPMXFIX(BPMFR)
+13 SET (BLRFM,XDRMRG("FR"))=BPMFR
SET (BLRTO,XDRMRG("TO"))=BPMTO
+14 SET BLRNEW=+$GET(^DPT(BLRTO,"LR"))
+15 IF 'BLROLD&'BLRNEW
QUIT
+16 ; CORRECT FIELD IF TO PATIENT DID NOT HAVE LAB DATA
+17 IF BLROLD=BLRNEW
Begin DoDot:2
+18 IF $PIECE(^LR(BLROLD,0),"^",3)=BLRTO
QUIT
+19 DO HDR^BPMXFIX(BLRTO,DUZ(2),BLROLD,,"Lab Node")
+20 SET DIE="^LR("
+21 SET DA=BLROLD
+22 SET DR=".03////"_BLRTO
+23 DO ^DIE
+24 SET BPMCNT1=BPMCNT1+1
End DoDot:2
QUIT
+25 IF '$DATA(^LR(BLROLD,0))
QUIT
+26 ;IHS/OIT/NKD BPM*1.0*2 STORE VALUES OF "AC" X-REF
+27 IF $DATA(^LRO(68,"AC",BLROLD))
KILL ^TMP("BPM-LR",$JOB)
MERGE ^TMP("BPM-LR",$JOB,68,"AC",BLROLD)=^LRO(68,"AC",BLROLD)
+28 ;
+29 DO HDR^BPMXFIX(BLRTO,DUZ(2),BLROLD,,"Lab Node")
+30 DO MERGE^BLRMERG
+31 ;IHS/OIT/NKD BPM*1.0*2 RESTORE VALUES OF "AC" X-REF
+32 IF $DATA(^TMP("BPM-LR",$JOB))
Begin DoDot:2
+33 SET I=0
+34 FOR
SET I=$ORDER(^LRO(68,"AC",BLRNEW,I))
IF +I'=I
QUIT
Begin DoDot:3
+35 SET J=0
+36 FOR
SET J=$ORDER(^LRO(68,"AC",BLRNEW,I,J))
IF +J'=J
QUIT
Begin DoDot:4
+37 ; QUIT IF X-REF HAS A VALUE
+38 IF $LENGTH(^LRO(68,"AC",BLRNEW,I,J))>0
QUIT
+39 ; QUIT IF X-REF DID NOT COME FROM BLROLD
+40 IF '$DATA(^TMP("BPM-LR",$JOB,68,"AC",BLROLD,I,J))
QUIT
+41 SET ^LRO(68,"AC",BLRNEW,I,J)=$GET(^TMP("BPM-LR",$JOB,68,"AC",BLROLD,I,J))
End DoDot:4
End DoDot:3
+42 KILL ^TMP("BPM-LR",$JOB)
End DoDot:2
+43 ;Repoint ^LR("BLRA") ESIG xref in Lab Data file #63
+44 DO EN^BPMXLR2(BLRFM,BLRTO)
+45 SET BPMCNT2=BPMCNT2+1
End DoDot:1
+46 DO RSLT^BPMXFIX(" *** Repoint Total Found: "_BPMCNT1_" ***")
+47 DO RSLT^BPMXFIX(" *** Merge Total Found: "_BPMCNT2_" ***")
+48 ;
+49 QUIT
+50 ;
MPI ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 RESEND A40 MESSAGES FOR MPI
+2 ;
+3 NEW X
+4 SET X="AGMPIHLO"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+5 NEW XIEN
+6 ;
+7 SET XIEN=0
+8 FOR
SET XIEN=$ORDER(^TMP("BPM",$JOB,XIEN))
IF +XIEN'=XIEN
QUIT
Begin DoDot:1
+9 NEW BPMFR,BPMTO,SUCCESS
+10 SET BPMFR=$ORDER(^TMP("BPM",$JOB,XIEN,""))
SET BPMTO=$ORDER(^TMP("BPM",$JOB,XIEN,BPMFR,""))
+11 DO CREATMSG^AGMPIHLO(BPMTO,"A40",BPMFR,.SUCCESS)
+12 IF SUCCESS
DO HDR^BPMXFIX(BPMTO,DUZ(2),BPMFR,,"From Patient IEN")
+13 IF '$TEST
DO RSLT^BPMXFIX($JUSTIFY("",2)_"MPI A40 MESSAGE FAILED: "_BPMFR_" -> "_BPMTO)
End DoDot:1
+14 QUIT
+15 ;
PRB ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX PROBLEM LIST ENTRIES
+2 ;
+3 NEW BPMTO,BPMFR,BPMF,BPMS,BPMI,BPMN,BPMNS,BPMCNT,BPMHDR
+4 SET (BPMTO,BPMCNT)=0
+5 FOR
SET BPMTO=$ORDER(^TMP("BPM",$JOB,"TO",BPMTO))
IF +BPMTO'=BPMTO
QUIT
Begin DoDot:1
+6 IF BPMTO'=$$LAST^BPMXFIX(BPMTO)
QUIT
+7 IF '$DATA(^AUPNPROB("AA",BPMTO))
QUIT
+8 SET BPMF=0
+9 FOR
SET BPMF=$ORDER(^AUPNPROB("AA",BPMTO,BPMF))
IF +BPMF'=BPMF
QUIT
Begin DoDot:2
+10 SET BPMS=""
SET BPMHDR=1
+11 FOR
SET BPMS=$ORDER(^AUPNPROB("AA",BPMTO,BPMF,BPMS))
IF $LENGTH(BPMS)<1
QUIT
Begin DoDot:3
+12 SET BPMI=$ORDER(^AUPNPROB("AA",BPMTO,BPMF,BPMS,""))
+13 FOR
SET BPMN=$ORDER(^AUPNPROB("AA",BPMTO,BPMF,BPMS,BPMI))
IF $LENGTH(BPMN)<1
QUIT
Begin DoDot:4
+14 NEW BPMOS
+15 SET BPMNS=$$NEXT^BPMXPRB(BPMTO,$$GET1^DIQ(9000011,BPMN,.06,"I"))
SET BPMOS=$$GET1^DIQ(9000011,BPMN,.07,"I")
+16 IF BPMHDR
DO HDR^BPMXFIX(BPMTO,BPMF)
SET BPMHDR=0
+17 DO RSLT^BPMXFIX($JUSTIFY("",4)_"Duplicate Sequence: "_BPMOS_$JUSTIFY("",6-$LENGTH(BPMOS))_" New Sequence: "_BPMNS)
+18 NEW FDA
+19 ; NMBR (.07)
SET FDA(9000011,BPMN_",",.07)=BPMNS
+20 DO UPDATE^DIE(,"FDA",)
+21 ; UPDATE MODIFIED X-REF
+22 KILL ^AUPNPROB("MODIFIED",BPMTO)
+23 SET ^AUPNPROB("MODIFIED",BPMTO,$$NOW^XLFDT())=""
+24 SET BPMCNT=BPMCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+26 ; REMOVE MODIFIED X-REF ON ALL FROM PATIENTS
+27 SET BPMFR=0
+28 FOR
SET BPMFR=$ORDER(^TMP("BPM",$JOB,"FROM",BPMFR))
IF +BPMFR'=BPMFR
QUIT
Begin DoDot:1
+29 KILL ^AUPNPROB("MODIFIED",BPMFR)
End DoDot:1
+30 QUIT
+31 ;
VST ;EP
+1 ;----- IHS/OIT/NKD BPM*1.0*2 FIX DELETED VISIT ENTRIES
+2 ;
+3 IF $$GET1^DIQ(15.1,2,99999.01)'="YES"
QUIT
+4 ;
+5 NEW BPMD0,BPMCNT
+6 SET (BPMCNT,BPMD0)=0
+7 FOR
SET BPMD0=$ORDER(^AUPNVSIT(BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+8 ;skip if not a deleted visit
IF $PIECE(^AUPNVSIT(BPMD0,0),U,11)'=1
QUIT
+9 IF +$PIECE($GET(^AUPNVSIT(BPMD0,0)),U,5)'=$PIECE($GET(^AUPNVSIT(BPMD0,0)),U,5)
QUIT
+10 IF '$DATA(^TMP("BPM",$JOB,"FROM",$PIECE($GET(^AUPNVSIT(BPMD0,0)),U,5)))
QUIT
+11 SET $PIECE(^AUPNVSIT(BPMD0,0),U,5)=$$LAST^BPMXFIX($PIECE($GET(^AUPNVSIT(BPMD0,0)),U,5))
+12 SET BPMCNT=BPMCNT+1
End DoDot:1
+13 DO RSLT^BPMXFIX(" *** Total Found: "_BPMCNT_" ***")
+14 ;
+15 QUIT
+16 ;
GETXLR ;
+1 NEW XCNT,XDIEN,I,J,X,XFIL,XNOD
+2 FOR XCNT=1:1:$LENGTH(XIENS,"^")
Begin DoDot:1
+3 SET XDIEN=$PIECE(XIENS,"^",XCNT)
+4 SET XFIL=0
+5 ; FIND THE MERGE IMAGE FILE
+6 FOR
SET XFIL=$ORDER(^XDRM(XDIEN,1,XFIL))
IF +XFIL'=XFIL
QUIT
Begin DoDot:2
+7 IF $PIECE(^XDRM(XDIEN,1,XFIL,0),"^",1)'="VA PATIENT"
QUIT
+8 SET XNOD=0
+9 ; ITERATE THROUGH MERGE IMAGE NODES
+10 FOR
SET XNOD=$ORDER(^XDRM(XDIEN,1,XFIL,1,XNOD))
IF +XNOD'=XNOD
QUIT
Begin DoDot:3
+11 IF $GET(^XDRM(XDIEN,1,XFIL,1,XNOD,0))'=("DPT("_BPMFR_",""LR"")")
QUIT
+12 ; SET BLROLD
+13 SET BLROLD=+$GET(^XDRM(XDIEN,1,XFIL,1,XNOD,1))
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
