BPMXVP ;IHS/PHXAO/AEF - REPOINT VARIABLE POINTER FIELDS - 6/26/12 ;
;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
; changed namespace from BZXM to BPM
; 11/30/2006 removed files that don't really store data (like parameter files)
;IHS/OIT/NKD 6/13/2012 Re-index all x-refs for merged entries in the Order file
; NEW local variable X in I1 loop
;;
DESC ;----- ROUTINE DESCRIPTION
;;BPMXVP:
;;THIS ROUTINE CONTAINS SUBROUTINES TO REPOINT VARIABLE POINTER FIELDS
;;
;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
;;
;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
;;SOFTWARE:
;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
;;EXAMPLE:
;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE).
;;
;;$$END
;
N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END" D EN^DDIOL(X)
Q
EN(BPMRY) ;EP
;----- MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
;
; BPMRY = TEMP GLOBAL SET UP BY THE PATIENT MERGE SOFTWARE,
; I.E., "^TMP(""XDRFROM"",$J)"
;
N BPMFR,BPMTO
S BPMFR=$O(@BPMRY@(0))
Q:'BPMFR
S BPMTO=$O(@BPMRY@(BPMFR,0))
Q:'BPMTO
;
D PROC(BPMFR,BPMTO)
Q
PROC(BPMFR,BPMTO) ;
;----- PROCESS VARIABLE POINTER FIELDS
;
D I1(BPMFR,BPMTO) ;A/R ACCOUNTS
D I2(BPMFR,BPMTO) ;GUARANTOR
D I3(BPMFR,BPMTO) ;3P CLAIM DATA
D I4(BPMFR,BPMTO) ;3P BILL
;
D V1(BPMFR,BPMTO) ;WKLD LOG FILE
D V2(BPMFR,BPMTO) ;WKLD DATA FILE
D V3(BPMFR,BPMTO) ;ORDER
D V4(BPMFR,BPMTO) ;OE/RR LIST
D V5(BPMFR,BPMTO) ;PATIENT RELATION
Q
I1(BPMFR,BPMTO) ;
;----- REPOINT 'ACCOUNT' FIELD #.01 OF THE 'A/R ACCOUNTS/IHS'
; FILE #90050.02
;
N BPMD0,BPMDUZ2,BPMPTR,DA,X
;
S BPMDUZ2=$G(DUZ(2))
S DUZ(2)=0 ; Sets DUZ(2) because cross-reference requires it
F S DUZ(2)=$O(^BARAC(DUZ(2))) Q:'DUZ(2) D
. S X=BPMFR_";AUPNPAT("
. S BPMD0=0
. F S BPMD0=$O(^BARAC(DUZ(2),"B",X,BPMD0)) Q:'BPMD0 D
. . N X ;IHS/OIT/NKD BPM*1.0*2 NEW X LOCAL VARIABLE
. . S BPMPTR=$P($G(^BARAC(DUZ(2),BPMD0,0)),U)
. . Q:+BPMPTR'=BPMFR
. . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . S $P(^BARAC(DUZ(2),BPMD0,0),U)=BPMTO_";AUPNPAT("
. . S DA=BPMD0
. . S X=BPMFR_";AUPNPAT("
. . X ^DD(90050.02,.01,1,1,2)
. . X ^DD(90050.02,.01,1,2,2)
. . S X=BPMTO_";AUPNPAT("
. . X ^DD(90050.02,.01,1,1,1)
. . X ^DD(90050.02,.01,1,2,1)
I BPMDUZ2 S DUZ(2)=BPMDUZ2 ;resetting DUZ(2) back to original value
Q
;
I2(BPMFR,BPMTO) ;
; ----- REPOINT "GUARANTOR" FIELD (#.01) UNDER GUARANTOR SUBFIELD (#101)
; IN GUARANTOR FILE (#9000043)
;
NEW BPMD0,BPMD1,VP,X,DA
S BPMD0=0 F S BPMD0=$O(^AUPNGUAR(BPMD0)) Q:'BPMD0 D
. S BPMD1=0 F S BPMD1=$O(^AUPNGUAR(BPMD0,1,BPMD1)) Q:'BPMD1 D
. . S VP=$P($G(^AUPNGUAR(BPMD0,1,BPMD1,0)),U)
. . Q:+VP'=BPMFR
. . Q:$P(VP,";",2)'="AUPNPAT("
. . S $P(^AUPNGUAR(BPMD0,1,BPMD1,0),U)=BPMTO_";AUPNPAT("
. . S DA(1)=BPMD0,DA=BPMD1
. . S X=VP
. . X ^DD(9000043.0101,.01,1,1,2)
. . X ^DD(9000043.0101,.01,1,2,2)
. . S X=BPMTO_";AUPNPAT("
. . X ^DD(9000043.0101,.01,1,1,1)
. . X ^DD(9000043.0101,.01,1,2,1)
Q
;
I3(BPMFR,BPMTO) ;
; ----- REPOINT DESTINATION FIELD (#.127) IN 3P CLAIM DATA FILE
;
NEW BPMD0,BPMDUZ2,BPMPTR
;
S BPMDUZ2=0
F S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:'BPMDUZ2 D
. S BPMD0=0
. F S BPMD0=$O(^ABMDCLM(BPMDUZ2,BPMD0)) Q:'BPMD0 D
. . S BPMPTR=$P($G(^ABMDCLM(BPMDUZ2,BPMD0,12)),U,7)
. . Q:+BPMPTR'=BPMFR
. . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . S $P(^ABMDCLM(BPMDUZ2,BPMD0,12),U,7)=BPMTO_";AUPNPAT("
;
; no cross references on field to fix
Q
;
I4(BPMFR,BPMTO) ;
; ----- REPOINT DESTINATION FIELD (#.127) IN 3P BILL FILE
;
NEW BPMD0,BPMDUZ2,BPMPTR
;
S BPMDUZ2=0
F S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:'BPMDUZ2 D
. S BPMD0=0
. F S BPMD0=$O(^ABMDBILL(BPMDUZ2,BPMD0)) Q:'BPMD0 D
. . S BPMPTR=$P($G(^ABMDBILL(BPMDUZ2,BPMD0,12)),U,7)
. . Q:+BPMPTR'=BPMFR
. . Q:$P(BPMPTR,";",2)'="AUPNPAT("
. . S $P(^ABMDBILL(BPMDUZ2,BPMD0,12),U,7)=BPMTO_";AUPNPAT("
;
; no cross references on field to fix
Q
;
V1(BPMFR,BPMTO) ;
;----- REPOINT 'PATIENT NAME' FIELD #2 OF THE 'WKLD LOG FILE' #64.03
; Part of Lab but Lab Merge doesn't handle it
;
N BPMD0,BPMPTR
;
S BPMD0=0
F S BPMD0=$O(^LRO(64.03,BPMD0)) Q:'BPMD0 D
. S BPMPTR=$P($G(^LRO(64.03,BPMD0,0)),U,3)
. Q:+BPMPTR'=BPMFR
. Q:$P(BPMPTR,";",2)'="DPT("
. S $P(^LRO(64.03,BPMD0,0),U,3)=BPMTO_";DPT("
Q
;
V2(BPMFR,BPMTO) ;
;----- REPOINT 'PATIENT' FIELD #9 OF THE 'ACCESSION WKLD
; CODE TIME' SUBFIELD #1 OF THE 'WKLD CODE' SUBFIELD
; #1 OF THE 'DATE' SUBFIELD #.03 OF THE 'WKLD DATA'
; FILE #64.1
; Part of Lab but Lab Merge doesn't handle it
;
N BPMD0,BPMD1,BPMD2,BPMD3,BPMPTR
;
S BPMD0=0
F S BPMD0=$O(^LRO(64.1,BPMD0)) Q:'BPMD0 D
. S BPMD1=0
. F S BPMD1=$O(^LRO(64.1,BPMD0,1,BPMD1)) Q:'BPMD1 D
. . S BPMD2=0
. . F S BPMD2=$O(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2)) Q:'BPMD2 D
. . . S BPMD3=0
. . . F S BPMD3=$O(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3)) Q:'BPMD3 D
. . . . S BPMPTR=$P($G(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3,0)),U,10)
. . . . Q:+BPMPTR'=BPMFR
. . . . Q:$P(BPMPTR,";",2)'="DPT("
. . . . S $P(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3,0),U,10)=BPMTO_";DPT("
Q
;
V3(BPMFR,BPMTO) ;
;----- REPOINT 'OBJECT OF ORDER' FIELD #.02 OF THE 'ORDER' FILE #100
; Waiting for VA to release patch that handles variable pointers correctly
;
N BPM0,BPMD0,BPMPTR,DA,X,DIK
;
S BPMD0=0
F S BPMD0=$O(^OR(100,BPMD0)) Q:'BPMD0 D
. S BPMPTR=$P($G(^OR(100,BPMD0,0)),U,2)
. Q:+BPMPTR'=BPMFR
. Q:$P(BPMPTR,";",2)'="DPT("
. S BPM0=$G(^OR(100,BPMD0,0))
. ;
. ;----- XECUTE KILL LOGIC FOR XREFS
.;IHS/OIT/NKD BPM*1.0*2 RE-INDEXING ALL X-REFS
.; ;"AC" XREF #2:
.; I +$P(BPM0,U,2),$P(BPM0,U,7) D
.; . S DA=BPMD0
.; . S X=BPMPTR
.; . X ^DD(100,.02,1,2,2) ;KILL
.; ;"AS" XREF #5:
.; S DA=BPMD0
.; S X=BPMPTR
.; X ^DD(100,.02,1,5,2)
.; ;"AR" XREF #7:
.; S DA=BPMD0
.; S X=BPMPTR
.; X ^DD(100,.02,1,7,2)
.; ;"AW" XREF #9:
.; I +$P(BPM0,U,2),$P(BPM0,U,11) D
.; . S DA=BPMD0
.; . S X=BPMPTR
.; . X ^DD(100,.02,1,9,2)
.; ;"AOI1" XREF #10:
.; I +$P(BPM0,U,2) D
.; . S DA=BPMD0
.; . S X=BPMPTR
.; . X ^DD(100,.02,1,10,2)
.; ;"ACT1" XREF #11:
.; I $P(BPM0,U,11) D
.; . S DA=BPMD0
.; . S X=BPMPTR
.; . X ^DD(100,.02,1,11,2)
. S DIK="^OR(100,",DA=BPMD0
. D IX2^DIK
. ;
. ;----- RESET VARIABLE POINTER
. S $P(^OR(100,BPMD0,0),U,2)=BPMTO_";DPT("
. S BPM0=$G(^OR(100,BPMD0,0))
. ;
. ;----- XECUTE SET LOGIC FOR XREFS
.;IHS/OIT/NKD BPM*1.0*2 RE-INDEXING ALL X-REFS
.; ;"AC" XREF #2:
.; I +$P(BPM0,U,2),$P(BPM0,U,7) D
.; . S DA=BPMD0
.; . S X=BPMTO_";DPT("
.; . X ^DD(100,.02,1,2,1) ;SET
.; ;"AS" XREF #5:
.; S DA=BPMD0
.; S X=BPMTO_";DPT("
.; X ^DD(100,.02,1,5,1)
.; ;"AR" XREF #7:
.; S DA=BPMD0
.; S X=BPMTO_";DPT("
.; X ^DD(100,.02,1,7,1)
.; ;"AW" XREF #9:
.; I +$P(BPM0,U,2),$P(BPM0,U,11) D
.; . S DA=BPMD0
.; . S X=BPMTO_";DPT("
.; . X ^DD(100,.02,1,9,1)
.; ;"AOI1" XREF #10:
.; I +$P(BPM0,U,2) D
.; . S DA=BPMD0
.; . S X=BPMTO_";DPT("
.; . X ^DD(100,.02,1,10,1)
.; ;"ACT1" XREF #11:
.; I $P(BPM0,U,11) D
.; . S DA=BPMD0
.; . S X=BPMTO_";DPT("
.; . X ^DD(100,.02,1,11,1)
. S DIK="^OR(100,",DA=BPMD0
. D IX1^DIK
Q
;
V4(BPMFR,BPMTO) ;
;----- REPOINT 'MEMBER' FIELD #.01 OF THE 'MEMBER' SUBFIELD #10
; OF THE 'OE/RR LIST' FILE #100.21
;
N BPMD0,BPMD1,BPMPTR,DA,X
;
S BPMD0=0
F S BPMD0=$O(^OR(100.21,BPMD0)) Q:'BPMD0 D
. S BPMD1=0
. F S BPMD1=$O(^OR(100.21,BPMD0,10,BPMD1)) Q:'BPMD1 D
. . S BPMPTR=$P($G(^OR(100.21,BPMD0,10,BPMD1,0)),U)
. . Q:+BPMPTR'=BPMFR
. . Q:$P(BPMPTR,";",2)'="DPT("
. . S $P(^OR(100.21,BPMD0,10,BPMD1,0),U)=BPMTO_";DPT("
. . S DA=BPMD1
. . S DA(1)=BPMD0
. . S X=BPMPTR
. . X ^DD(100.2101,.01,1,1,2)
. . X ^DD(100.2101,.01,1,2,2)
. . S X=BPMTO_";DPT("
. . X ^DD(100.2101,.01,1,1,1)
. . X ^DD(100.2101,.01,1,2,1)
Q
;
V5(BPMFR,BPMTO) ;
;----- REPOINT 'PERSON' FIELD #.03 OF THE 'PATIENT RELATION'
; FILE #408.12
;
N BPMD0,BPMPTR,DA,X
;
S BPMD0=0
F S BPMD0=$O(^DGPR(408.12,BPMD0)) Q:'BPMD0 D
. S BPMPTR=$P($G(^DGPR(408.12,BPMD0,0)),U,3)
. Q:+BPMPTR'=BPMFR
. Q:$P(BPMPTR,";",2)'="DPT("
. S $P(^DGPR(408.12,BPMD0,0),U,3)=BPMTO_";DPT("
. S DA=BPMD0
. S X=BPMPTR
. X ^DD(408.12,.03,1,1,2)
. S X=BPMTO_";DPT("
. X ^DD(408.12,.03,1,1,1)
Q
BPMXVP ;IHS/PHXAO/AEF - REPOINT VARIABLE POINTER FIELDS - 6/26/12 ;
+1 ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
+2 ;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
+3 ; changed namespace from BZXM to BPM
+4 ; 11/30/2006 removed files that don't really store data (like parameter files)
+5 ;IHS/OIT/NKD 6/13/2012 Re-index all x-refs for merged entries in the Order file
+6 ; NEW local variable X in I1 loop
+7 ;;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;BPMXVP:
+2 ;;THIS ROUTINE CONTAINS SUBROUTINES TO REPOINT VARIABLE POINTER FIELDS
+3 ;;
+4 ;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
+5 ;;
+6 ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
+7 ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
+8 ;;SOFTWARE:
+9 ;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+10 ;;EXAMPLE:
+11 ;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+12 ;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE).
+13 ;;
+14 ;;$$END
+15 ;
+16 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
DO EN^DDIOL(X)
+17 QUIT
EN(BPMRY) ;EP
+1 ;----- MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
+2 ;
+3 ; BPMRY = TEMP GLOBAL SET UP BY THE PATIENT MERGE SOFTWARE,
+4 ; I.E., "^TMP(""XDRFROM"",$J)"
+5 ;
+6 NEW BPMFR,BPMTO
+7 SET BPMFR=$ORDER(@BPMRY@(0))
+8 IF 'BPMFR
QUIT
+9 SET BPMTO=$ORDER(@BPMRY@(BPMFR,0))
+10 IF 'BPMTO
QUIT
+11 ;
+12 DO PROC(BPMFR,BPMTO)
+13 QUIT
PROC(BPMFR,BPMTO) ;
+1 ;----- PROCESS VARIABLE POINTER FIELDS
+2 ;
+3 ;A/R ACCOUNTS
DO I1(BPMFR,BPMTO)
+4 ;GUARANTOR
DO I2(BPMFR,BPMTO)
+5 ;3P CLAIM DATA
DO I3(BPMFR,BPMTO)
+6 ;3P BILL
DO I4(BPMFR,BPMTO)
+7 ;
+8 ;WKLD LOG FILE
DO V1(BPMFR,BPMTO)
+9 ;WKLD DATA FILE
DO V2(BPMFR,BPMTO)
+10 ;ORDER
DO V3(BPMFR,BPMTO)
+11 ;OE/RR LIST
DO V4(BPMFR,BPMTO)
+12 ;PATIENT RELATION
DO V5(BPMFR,BPMTO)
+13 QUIT
I1(BPMFR,BPMTO) ;
+1 ;----- REPOINT 'ACCOUNT' FIELD #.01 OF THE 'A/R ACCOUNTS/IHS'
+2 ; FILE #90050.02
+3 ;
+4 NEW BPMD0,BPMDUZ2,BPMPTR,DA,X
+5 ;
+6 SET BPMDUZ2=$GET(DUZ(2))
+7 ; Sets DUZ(2) because cross-reference requires it
SET DUZ(2)=0
+8 FOR
SET DUZ(2)=$ORDER(^BARAC(DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+9 SET X=BPMFR_";AUPNPAT("
+10 SET BPMD0=0
+11 FOR
SET BPMD0=$ORDER(^BARAC(DUZ(2),"B",X,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+12 ;IHS/OIT/NKD BPM*1.0*2 NEW X LOCAL VARIABLE
NEW X
+13 SET BPMPTR=$PIECE($GET(^BARAC(DUZ(2),BPMD0,0)),U)
+14 IF +BPMPTR'=BPMFR
QUIT
+15 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+16 SET $PIECE(^BARAC(DUZ(2),BPMD0,0),U)=BPMTO_";AUPNPAT("
+17 SET DA=BPMD0
+18 SET X=BPMFR_";AUPNPAT("
+19 XECUTE ^DD(90050.02,.01,1,1,2)
+20 XECUTE ^DD(90050.02,.01,1,2,2)
+21 SET X=BPMTO_";AUPNPAT("
+22 XECUTE ^DD(90050.02,.01,1,1,1)
+23 XECUTE ^DD(90050.02,.01,1,2,1)
End DoDot:2
End DoDot:1
+24 ;resetting DUZ(2) back to original value
IF BPMDUZ2
SET DUZ(2)=BPMDUZ2
+25 QUIT
+26 ;
I2(BPMFR,BPMTO) ;
+1 ; ----- REPOINT "GUARANTOR" FIELD (#.01) UNDER GUARANTOR SUBFIELD (#101)
+2 ; IN GUARANTOR FILE (#9000043)
+3 ;
+4 NEW BPMD0,BPMD1,VP,X,DA
+5 SET BPMD0=0
FOR
SET BPMD0=$ORDER(^AUPNGUAR(BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+6 SET BPMD1=0
FOR
SET BPMD1=$ORDER(^AUPNGUAR(BPMD0,1,BPMD1))
IF 'BPMD1
QUIT
Begin DoDot:2
+7 SET VP=$PIECE($GET(^AUPNGUAR(BPMD0,1,BPMD1,0)),U)
+8 IF +VP'=BPMFR
QUIT
+9 IF $PIECE(VP,";",2)'="AUPNPAT("
QUIT
+10 SET $PIECE(^AUPNGUAR(BPMD0,1,BPMD1,0),U)=BPMTO_";AUPNPAT("
+11 SET DA(1)=BPMD0
SET DA=BPMD1
+12 SET X=VP
+13 XECUTE ^DD(9000043.0101,.01,1,1,2)
+14 XECUTE ^DD(9000043.0101,.01,1,2,2)
+15 SET X=BPMTO_";AUPNPAT("
+16 XECUTE ^DD(9000043.0101,.01,1,1,1)
+17 XECUTE ^DD(9000043.0101,.01,1,2,1)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
I3(BPMFR,BPMTO) ;
+1 ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P CLAIM DATA FILE
+2 ;
+3 NEW BPMD0,BPMDUZ2,BPMPTR
+4 ;
+5 SET BPMDUZ2=0
+6 FOR
SET BPMDUZ2=$ORDER(^ABMDCLM(BPMDUZ2))
IF 'BPMDUZ2
QUIT
Begin DoDot:1
+7 SET BPMD0=0
+8 FOR
SET BPMD0=$ORDER(^ABMDCLM(BPMDUZ2,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+9 SET BPMPTR=$PIECE($GET(^ABMDCLM(BPMDUZ2,BPMD0,12)),U,7)
+10 IF +BPMPTR'=BPMFR
QUIT
+11 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+12 SET $PIECE(^ABMDCLM(BPMDUZ2,BPMD0,12),U,7)=BPMTO_";AUPNPAT("
End DoDot:2
End DoDot:1
+13 ;
+14 ; no cross references on field to fix
+15 QUIT
+16 ;
I4(BPMFR,BPMTO) ;
+1 ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P BILL FILE
+2 ;
+3 NEW BPMD0,BPMDUZ2,BPMPTR
+4 ;
+5 SET BPMDUZ2=0
+6 FOR
SET BPMDUZ2=$ORDER(^ABMDBILL(BPMDUZ2))
IF 'BPMDUZ2
QUIT
Begin DoDot:1
+7 SET BPMD0=0
+8 FOR
SET BPMD0=$ORDER(^ABMDBILL(BPMDUZ2,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+9 SET BPMPTR=$PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,12)),U,7)
+10 IF +BPMPTR'=BPMFR
QUIT
+11 IF $PIECE(BPMPTR,";",2)'="AUPNPAT("
QUIT
+12 SET $PIECE(^ABMDBILL(BPMDUZ2,BPMD0,12),U,7)=BPMTO_";AUPNPAT("
End DoDot:2
End DoDot:1
+13 ;
+14 ; no cross references on field to fix
+15 QUIT
+16 ;
V1(BPMFR,BPMTO) ;
+1 ;----- REPOINT 'PATIENT NAME' FIELD #2 OF THE 'WKLD LOG FILE' #64.03
+2 ; Part of Lab but Lab Merge doesn't handle it
+3 ;
+4 NEW BPMD0,BPMPTR
+5 ;
+6 SET BPMD0=0
+7 FOR
SET BPMD0=$ORDER(^LRO(64.03,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+8 SET BPMPTR=$PIECE($GET(^LRO(64.03,BPMD0,0)),U,3)
+9 IF +BPMPTR'=BPMFR
QUIT
+10 IF $PIECE(BPMPTR,";",2)'="DPT("
QUIT
+11 SET $PIECE(^LRO(64.03,BPMD0,0),U,3)=BPMTO_";DPT("
End DoDot:1
+12 QUIT
+13 ;
V2(BPMFR,BPMTO) ;
+1 ;----- REPOINT 'PATIENT' FIELD #9 OF THE 'ACCESSION WKLD
+2 ; CODE TIME' SUBFIELD #1 OF THE 'WKLD CODE' SUBFIELD
+3 ; #1 OF THE 'DATE' SUBFIELD #.03 OF THE 'WKLD DATA'
+4 ; FILE #64.1
+5 ; Part of Lab but Lab Merge doesn't handle it
+6 ;
+7 NEW BPMD0,BPMD1,BPMD2,BPMD3,BPMPTR
+8 ;
+9 SET BPMD0=0
+10 FOR
SET BPMD0=$ORDER(^LRO(64.1,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+11 SET BPMD1=0
+12 FOR
SET BPMD1=$ORDER(^LRO(64.1,BPMD0,1,BPMD1))
IF 'BPMD1
QUIT
Begin DoDot:2
+13 SET BPMD2=0
+14 FOR
SET BPMD2=$ORDER(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2))
IF 'BPMD2
QUIT
Begin DoDot:3
+15 SET BPMD3=0
+16 FOR
SET BPMD3=$ORDER(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3))
IF 'BPMD3
QUIT
Begin DoDot:4
+17 SET BPMPTR=$PIECE($GET(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3,0)),U,10)
+18 IF +BPMPTR'=BPMFR
QUIT
+19 IF $PIECE(BPMPTR,";",2)'="DPT("
QUIT
+20 SET $PIECE(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3,0),U,10)=BPMTO_";DPT("
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
V3(BPMFR,BPMTO) ;
+1 ;----- REPOINT 'OBJECT OF ORDER' FIELD #.02 OF THE 'ORDER' FILE #100
+2 ; Waiting for VA to release patch that handles variable pointers correctly
+3 ;
+4 NEW BPM0,BPMD0,BPMPTR,DA,X,DIK
+5 ;
+6 SET BPMD0=0
+7 FOR
SET BPMD0=$ORDER(^OR(100,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+8 SET BPMPTR=$PIECE($GET(^OR(100,BPMD0,0)),U,2)
+9 IF +BPMPTR'=BPMFR
QUIT
+10 IF $PIECE(BPMPTR,";",2)'="DPT("
QUIT
+11 SET BPM0=$GET(^OR(100,BPMD0,0))
+12 ;
+13 ;----- XECUTE KILL LOGIC FOR XREFS
+14 ;IHS/OIT/NKD BPM*1.0*2 RE-INDEXING ALL X-REFS
+15 ; ;"AC" XREF #2:
+16 ; I +$P(BPM0,U,2),$P(BPM0,U,7) D
+17 ; . S DA=BPMD0
+18 ; . S X=BPMPTR
+19 ; . X ^DD(100,.02,1,2,2) ;KILL
+20 ; ;"AS" XREF #5:
+21 ; S DA=BPMD0
+22 ; S X=BPMPTR
+23 ; X ^DD(100,.02,1,5,2)
+24 ; ;"AR" XREF #7:
+25 ; S DA=BPMD0
+26 ; S X=BPMPTR
+27 ; X ^DD(100,.02,1,7,2)
+28 ; ;"AW" XREF #9:
+29 ; I +$P(BPM0,U,2),$P(BPM0,U,11) D
+30 ; . S DA=BPMD0
+31 ; . S X=BPMPTR
+32 ; . X ^DD(100,.02,1,9,2)
+33 ; ;"AOI1" XREF #10:
+34 ; I +$P(BPM0,U,2) D
+35 ; . S DA=BPMD0
+36 ; . S X=BPMPTR
+37 ; . X ^DD(100,.02,1,10,2)
+38 ; ;"ACT1" XREF #11:
+39 ; I $P(BPM0,U,11) D
+40 ; . S DA=BPMD0
+41 ; . S X=BPMPTR
+42 ; . X ^DD(100,.02,1,11,2)
+43 SET DIK="^OR(100,"
SET DA=BPMD0
+44 DO IX2^DIK
+45 ;
+46 ;----- RESET VARIABLE POINTER
+47 SET $PIECE(^OR(100,BPMD0,0),U,2)=BPMTO_";DPT("
+48 SET BPM0=$GET(^OR(100,BPMD0,0))
+49 ;
+50 ;----- XECUTE SET LOGIC FOR XREFS
+51 ;IHS/OIT/NKD BPM*1.0*2 RE-INDEXING ALL X-REFS
+52 ; ;"AC" XREF #2:
+53 ; I +$P(BPM0,U,2),$P(BPM0,U,7) D
+54 ; . S DA=BPMD0
+55 ; . S X=BPMTO_";DPT("
+56 ; . X ^DD(100,.02,1,2,1) ;SET
+57 ; ;"AS" XREF #5:
+58 ; S DA=BPMD0
+59 ; S X=BPMTO_";DPT("
+60 ; X ^DD(100,.02,1,5,1)
+61 ; ;"AR" XREF #7:
+62 ; S DA=BPMD0
+63 ; S X=BPMTO_";DPT("
+64 ; X ^DD(100,.02,1,7,1)
+65 ; ;"AW" XREF #9:
+66 ; I +$P(BPM0,U,2),$P(BPM0,U,11) D
+67 ; . S DA=BPMD0
+68 ; . S X=BPMTO_";DPT("
+69 ; . X ^DD(100,.02,1,9,1)
+70 ; ;"AOI1" XREF #10:
+71 ; I +$P(BPM0,U,2) D
+72 ; . S DA=BPMD0
+73 ; . S X=BPMTO_";DPT("
+74 ; . X ^DD(100,.02,1,10,1)
+75 ; ;"ACT1" XREF #11:
+76 ; I $P(BPM0,U,11) D
+77 ; . S DA=BPMD0
+78 ; . S X=BPMTO_";DPT("
+79 ; . X ^DD(100,.02,1,11,1)
+80 SET DIK="^OR(100,"
SET DA=BPMD0
+81 DO IX1^DIK
End DoDot:1
+82 QUIT
+83 ;
V4(BPMFR,BPMTO) ;
+1 ;----- REPOINT 'MEMBER' FIELD #.01 OF THE 'MEMBER' SUBFIELD #10
+2 ; OF THE 'OE/RR LIST' FILE #100.21
+3 ;
+4 NEW BPMD0,BPMD1,BPMPTR,DA,X
+5 ;
+6 SET BPMD0=0
+7 FOR
SET BPMD0=$ORDER(^OR(100.21,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+8 SET BPMD1=0
+9 FOR
SET BPMD1=$ORDER(^OR(100.21,BPMD0,10,BPMD1))
IF 'BPMD1
QUIT
Begin DoDot:2
+10 SET BPMPTR=$PIECE($GET(^OR(100.21,BPMD0,10,BPMD1,0)),U)
+11 IF +BPMPTR'=BPMFR
QUIT
+12 IF $PIECE(BPMPTR,";",2)'="DPT("
QUIT
+13 SET $PIECE(^OR(100.21,BPMD0,10,BPMD1,0),U)=BPMTO_";DPT("
+14 SET DA=BPMD1
+15 SET DA(1)=BPMD0
+16 SET X=BPMPTR
+17 XECUTE ^DD(100.2101,.01,1,1,2)
+18 XECUTE ^DD(100.2101,.01,1,2,2)
+19 SET X=BPMTO_";DPT("
+20 XECUTE ^DD(100.2101,.01,1,1,1)
+21 XECUTE ^DD(100.2101,.01,1,2,1)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
V5(BPMFR,BPMTO) ;
+1 ;----- REPOINT 'PERSON' FIELD #.03 OF THE 'PATIENT RELATION'
+2 ; FILE #408.12
+3 ;
+4 NEW BPMD0,BPMPTR,DA,X
+5 ;
+6 SET BPMD0=0
+7 FOR
SET BPMD0=$ORDER(^DGPR(408.12,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:1
+8 SET BPMPTR=$PIECE($GET(^DGPR(408.12,BPMD0,0)),U,3)
+9 IF +BPMPTR'=BPMFR
QUIT
+10 IF $PIECE(BPMPTR,";",2)'="DPT("
QUIT
+11 SET $PIECE(^DGPR(408.12,BPMD0,0),U,3)=BPMTO_";DPT("
+12 SET DA=BPMD0
+13 SET X=BPMPTR
+14 XECUTE ^DD(408.12,.03,1,1,2)
+15 SET X=BPMTO_";DPT("
+16 XECUTE ^DD(408.12,.03,1,1,1)
End DoDot:1
+17 QUIT
