BPMX3PB ;IHS/PHXAO/AEF - REPOINT 3P CLAIM AND BILL PATIENTS - 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
;IHS/OIT/NKD 6/13/2012 Removed unnecessary modifications to HRNs
; Corrected re-pointing of Patient entry in
; 3P Claim file
; Added re-index of "ADR" x-ref on 3P BILL file
;;
DESC ;----- ROUTINE DESCRIPTION
;;BPMX3PB:
;;THIS ROUTINE LOOPS THROUGH EACH ENTRY IN THE 3P CLAIM DATA #9002274.3
;;AND REPOINTS THE PATIENT NAME IN FIELD .01. IT ALSO LOOPS THROUGH
;;THE 3P BILL #9002274.4 FILE AND REPOINTS THE PATIENT NAME IN FIELD
;;.05. THESE NAME FIELDS ARE REPOINTED TO THE SPECIFIED VA/IHS PATIENT
;;FILE ENTRY.
;;
;;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" W !,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(""XDFROM"",$J)"
;
N BPM41,BPMFR,BPMTO
;
S BPMFR=$O(@BPMRY@(0))
Q:'BPMFR
S BPMTO=$O(@BPMRY@(BPMFR,0))
Q:'BPMTO
;
;D ACT1(BPMTO,.BPM41) ;IHS/OIT/NKD BPM*1.0*2 REMOVED UNNECESSARY HRN EDITS
D CLAIM(BPMFR,BPMTO)
D BILL(BPMFR,BPMTO)
;D ACT2(BPMTO,.BPM41) ;IHS/OIT/NKD BPM*1.0*2 REMOVED UNNECESSARY HRN EDITS
;
Q
CLAIM(BPMFR,BPMTO) ;
;----- REPOINT 3P CLAIM DATA PATIENTS
;
N BPMD0,BPMDUZ2
;
S BPMDUZ2=0
F S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:'BPMDUZ2 D
. S BPMD0=0
. F S BPMD0=$O(^ABMDCLM(BPMDUZ2,"B",BPMFR,BPMD0)) Q:'BPMD0 D
. . Q:$P($G(^ABMDCLM(BPMDUZ2,BPMD0,0)),U)'=BPMFR
. . D ONECLAIM(BPMDUZ2,BPMD0,BPMTO)
Q
ONECLAIM(BPMDUZ2,BPMD0,BPMTO) ;
;----- REPOINT ONE CLAIM
;
N BPMDUZ,FDA
N DIC,XDRMRG,DIE,DA,DR
;
S BPMDUZ(2)=DUZ(2)
S DUZ(2)=BPMDUZ2 ;sets DUZ(2) because xref on .01 field requires it
;IHS/OIT/NKD BPM*1.0*2 USING DBS CALLS TO ENSURE PROPER EDIT - START OLD CODE
;I '$D(AUPNPAT(BPMTO,41,DUZ(2))) D
;. S ^AUPNPAT(BPMTO,41,DUZ(2),0)=DUZ(2)
;S DIC(0)=$G(DIC(0))_"I"
;S XDRMRG=1
;S DIE="^ABMDCLM("_DUZ(2)_","
;S DA=BPMD0
;S DR=".01///^S X=BPMTO"
;K DD,DO
;D ^DIE
;IHS/OIT/NKD BPM*1.0*2 END OLD CODE
S FDA(9002274.3,BPMD0_",",.01)=BPMTO
D UPDATE^DIE(,"FDA",)
;
S DUZ(2)=BPMDUZ(2) ;resetting DUZ(2) back to original value
;
Q
BILL(BPMFR,BPMTO) ;
;----- REPOINT 3P BILL PATIENTS
;
N BPMD0,BPMDUZ2
;
S BPMDUZ2=0
F S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:'BPMDUZ2 D
. S BPMD0=0
. F S BPMD0=$O(^ABMDBILL(BPMDUZ2,"D",BPMFR,BPMD0)) Q:'BPMD0 D
. . Q:$P($G(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMFR
. . D ONEBILL(BPMDUZ2,BPMD0,BPMTO)
Q
ONEBILL(BPMDUZ2,BPMD0,BPMTO) ;
;----- REPOINT ONE BILL
;
N BPMDUZ,DA,DIE,DR,X,Y
;
S BPMDUZ(2)=DUZ(2)
S DUZ(2)=BPMDUZ2 ;sets DUZ(2) because xref on .05 field requires it
S DIE="^ABMDBILL("_DUZ(2)_","
S DA=BPMD0
S DR=".05////"_BPMTO
D ^DIE
;
;IHS/OIT/NKD BPM*1.0*2 RE-INDEX "ADR" X-REF
S DA=BPMD0
S X=$$GET1^DIQ(9002274.4,DA,.71,"I")
X ^DD(9002274.4,.71,1,2,2)
X ^DD(9002274.4,.71,1,2,1)
;
S DUZ(2)=BPMDUZ(2) ;resetting DUZ(2) back to original value
Q
ACT1(D0,BPM41) ;
;----- MAKE SURE ALL HRNS IN IHS PATIENT FILE ARE ACTIVE FOR MERGE TO
; OCCUR
;
N D1,X
;
S D1=0
F S D1=$O(^AUPNPAT(D0,41,D1)) Q:'D1 D
. S X=$G(^AUPNPAT(D0,41,D1,0))
. S BPM41(D0,41,D1,0)=X
. S ^AUPNPAT(D0,41,D1,0)=$P(X,U,1,2)
Q
ACT2(D0,BPM41) ;
;----- PUT ALL HRNS BACK THE WAY THEY WERE BEFORE THE MERGE
;
N D1
;
Q:'$D(BPM41(D0))
S D1=0
F S D1=$O(BPM41(D0,41,D1)) Q:'D1 D
. S ^AUPNPAT(D0,41,D1,0)=BPM41(D0,41,D1,0)
Q
BPMX3PB ;IHS/PHXAO/AEF - REPOINT 3P CLAIM AND BILL PATIENTS - 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 ;IHS/OIT/NKD 6/13/2012 Removed unnecessary modifications to HRNs
+5 ; Corrected re-pointing of Patient entry in
+6 ; 3P Claim file
+7 ; Added re-index of "ADR" x-ref on 3P BILL file
+8 ;;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;BPMX3PB:
+2 ;;THIS ROUTINE LOOPS THROUGH EACH ENTRY IN THE 3P CLAIM DATA #9002274.3
+3 ;;AND REPOINTS THE PATIENT NAME IN FIELD .01. IT ALSO LOOPS THROUGH
+4 ;;THE 3P BILL #9002274.4 FILE AND REPOINTS THE PATIENT NAME IN FIELD
+5 ;;.05. THESE NAME FIELDS ARE REPOINTED TO THE SPECIFIED VA/IHS PATIENT
+6 ;;FILE ENTRY.
+7 ;;
+8 ;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
+9 ;;
+10 ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
+11 ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
+12 ;;SOFTWARE:
+13 ;;^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+14 ;;EXAMPLE:
+15 ;;^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+16 ;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE).
+17 ;;
+18 ;;$$END
+19 ;
+20 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
WRITE !,X
+21 QUIT
+22 ;
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(""XDFROM"",$J)"
+5 ;
+6 NEW BPM41,BPMFR,BPMTO
+7 ;
+8 SET BPMFR=$ORDER(@BPMRY@(0))
+9 IF 'BPMFR
QUIT
+10 SET BPMTO=$ORDER(@BPMRY@(BPMFR,0))
+11 IF 'BPMTO
QUIT
+12 ;
+13 ;D ACT1(BPMTO,.BPM41) ;IHS/OIT/NKD BPM*1.0*2 REMOVED UNNECESSARY HRN EDITS
+14 DO CLAIM(BPMFR,BPMTO)
+15 DO BILL(BPMFR,BPMTO)
+16 ;D ACT2(BPMTO,.BPM41) ;IHS/OIT/NKD BPM*1.0*2 REMOVED UNNECESSARY HRN EDITS
+17 ;
+18 QUIT
CLAIM(BPMFR,BPMTO) ;
+1 ;----- REPOINT 3P CLAIM DATA PATIENTS
+2 ;
+3 NEW BPMD0,BPMDUZ2
+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,"B",BPMFR,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+9 IF $PIECE($GET(^ABMDCLM(BPMDUZ2,BPMD0,0)),U)'=BPMFR
QUIT
+10 DO ONECLAIM(BPMDUZ2,BPMD0,BPMTO)
End DoDot:2
End DoDot:1
+11 QUIT
ONECLAIM(BPMDUZ2,BPMD0,BPMTO) ;
+1 ;----- REPOINT ONE CLAIM
+2 ;
+3 NEW BPMDUZ,FDA
+4 NEW DIC,XDRMRG,DIE,DA,DR
+5 ;
+6 SET BPMDUZ(2)=DUZ(2)
+7 ;sets DUZ(2) because xref on .01 field requires it
SET DUZ(2)=BPMDUZ2
+8 ;IHS/OIT/NKD BPM*1.0*2 USING DBS CALLS TO ENSURE PROPER EDIT - START OLD CODE
+9 ;I '$D(AUPNPAT(BPMTO,41,DUZ(2))) D
+10 ;. S ^AUPNPAT(BPMTO,41,DUZ(2),0)=DUZ(2)
+11 ;S DIC(0)=$G(DIC(0))_"I"
+12 ;S XDRMRG=1
+13 ;S DIE="^ABMDCLM("_DUZ(2)_","
+14 ;S DA=BPMD0
+15 ;S DR=".01///^S X=BPMTO"
+16 ;K DD,DO
+17 ;D ^DIE
+18 ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE
+19 SET FDA(9002274.3,BPMD0_",",.01)=BPMTO
+20 DO UPDATE^DIE(,"FDA",)
+21 ;
+22 ;resetting DUZ(2) back to original value
SET DUZ(2)=BPMDUZ(2)
+23 ;
+24 QUIT
BILL(BPMFR,BPMTO) ;
+1 ;----- REPOINT 3P BILL PATIENTS
+2 ;
+3 NEW BPMD0,BPMDUZ2
+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,"D",BPMFR,BPMD0))
IF 'BPMD0
QUIT
Begin DoDot:2
+9 IF $PIECE($GET(^ABMDBILL(BPMDUZ2,BPMD0,0)),U,5)'=BPMFR
QUIT
+10 DO ONEBILL(BPMDUZ2,BPMD0,BPMTO)
End DoDot:2
End DoDot:1
+11 QUIT
ONEBILL(BPMDUZ2,BPMD0,BPMTO) ;
+1 ;----- REPOINT ONE BILL
+2 ;
+3 NEW BPMDUZ,DA,DIE,DR,X,Y
+4 ;
+5 SET BPMDUZ(2)=DUZ(2)
+6 ;sets DUZ(2) because xref on .05 field requires it
SET DUZ(2)=BPMDUZ2
+7 SET DIE="^ABMDBILL("_DUZ(2)_","
+8 SET DA=BPMD0
+9 SET DR=".05////"_BPMTO
+10 DO ^DIE
+11 ;
+12 ;IHS/OIT/NKD BPM*1.0*2 RE-INDEX "ADR" X-REF
+13 SET DA=BPMD0
+14 SET X=$$GET1^DIQ(9002274.4,DA,.71,"I")
+15 XECUTE ^DD(9002274.4,.71,1,2,2)
+16 XECUTE ^DD(9002274.4,.71,1,2,1)
+17 ;
+18 ;resetting DUZ(2) back to original value
SET DUZ(2)=BPMDUZ(2)
+19 QUIT
ACT1(D0,BPM41) ;
+1 ;----- MAKE SURE ALL HRNS IN IHS PATIENT FILE ARE ACTIVE FOR MERGE TO
+2 ; OCCUR
+3 ;
+4 NEW D1,X
+5 ;
+6 SET D1=0
+7 FOR
SET D1=$ORDER(^AUPNPAT(D0,41,D1))
IF 'D1
QUIT
Begin DoDot:1
+8 SET X=$GET(^AUPNPAT(D0,41,D1,0))
+9 SET BPM41(D0,41,D1,0)=X
+10 SET ^AUPNPAT(D0,41,D1,0)=$PIECE(X,U,1,2)
End DoDot:1
+11 QUIT
ACT2(D0,BPM41) ;
+1 ;----- PUT ALL HRNS BACK THE WAY THEY WERE BEFORE THE MERGE
+2 ;
+3 NEW D1
+4 ;
+5 IF '$DATA(BPM41(D0))
QUIT
+6 SET D1=0
+7 FOR
SET D1=$ORDER(BPM41(D0,41,D1))
IF 'D1
QUIT
Begin DoDot:1
+8 SET ^AUPNPAT(D0,41,D1,0)=BPM41(D0,41,D1,0)
End DoDot:1
+9 QUIT
