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

BPMXVP.m

Go to the documentation of this file. 
  1. BPMXVP ;IHS/PHXAO/AEF - REPOINT VARIABLE POINTER FIELDS - 6/26/12 ;
  1.  ;;1.0;IHS PATIENT MERGE;**2**;MAR 01, 2010;Build 1
  1.  ;IHS/OIT/LJF 10/26/2006 routine originated from Phoenix Area Office
  1.  ;                       changed namespace from BZXM to BPM
  1.  ;            11/30/2006 removed files that don't really store data (like parameter files)
  1.  ;IHS/OIT/NKD  6/13/2012 Re-index all x-refs for merged entries in the Order file
  1.  ;                       NEW local variable X in I1 loop
  1.  ;;
  1. DESC ;----- ROUTINE DESCRIPTION
  1.  ;;BPMXVP:
  1.  ;;THIS ROUTINE CONTAINS SUBROUTINES TO REPOINT VARIABLE POINTER FIELDS
  1.  ;;
  1.  ;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
  1.  ;;
  1.  ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL.  IT IS EXPECTED
  1.  ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
  1.  ;;SOFTWARE:
  1.  ;;  ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
  1.  ;;EXAMPLE:
  1.  ;;  ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
  1.  ;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE).
  1.  ;;
  1.  ;;$$END
  1.  ;
  1.  N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END"  D EN^DDIOL(X)
  1.  Q
  1. EN(BPMRY) ;EP
  1.  ;-----  MAIN ENTRY POINT FROM DUPLICATE PATIENT MERGE SOFTWARE
  1.  ;
  1.  ;       BPMRY  =  TEMP GLOBAL SET UP BY THE PATIENT MERGE SOFTWARE,
  1.  ;                  I.E., "^TMP(""XDRFROM"",$J)"
  1.  ;
  1.  N BPMFR,BPMTO
  1.  S BPMFR=$O(@BPMRY@(0))
  1.  Q:'BPMFR
  1.  S BPMTO=$O(@BPMRY@(BPMFR,0))
  1.  Q:'BPMTO
  1.  ;
  1.  D PROC(BPMFR,BPMTO)
  1.  Q
  1. PROC(BPMFR,BPMTO) ;
  1.  ;----- PROCESS VARIABLE POINTER FIELDS
  1.  ;
  1.  D I1(BPMFR,BPMTO)   ;A/R ACCOUNTS
  1.  D I2(BPMFR,BPMTO)   ;GUARANTOR
  1.  D I3(BPMFR,BPMTO)   ;3P CLAIM DATA
  1.  D I4(BPMFR,BPMTO)   ;3P BILL
  1.  ;
  1.  D V1(BPMFR,BPMTO)   ;WKLD LOG FILE
  1.  D V2(BPMFR,BPMTO)   ;WKLD DATA FILE
  1.  D V3(BPMFR,BPMTO)   ;ORDER
  1.  D V4(BPMFR,BPMTO)   ;OE/RR LIST
  1.  D V5(BPMFR,BPMTO)   ;PATIENT RELATION
  1.  Q
  1. I1(BPMFR,BPMTO) ;
  1.  ;----- REPOINT 'ACCOUNT' FIELD #.01 OF THE 'A/R ACCOUNTS/IHS' 
  1.  ;      FILE #90050.02
  1.  ;
  1.  N BPMD0,BPMDUZ2,BPMPTR,DA,X
  1.  ;
  1.  S BPMDUZ2=$G(DUZ(2))
  1.  S DUZ(2)=0     ; Sets DUZ(2) because cross-reference requires it
  1.  F  S DUZ(2)=$O(^BARAC(DUZ(2))) Q:'DUZ(2)  D
  1.  . S X=BPMFR_";AUPNPAT("
  1.  . S BPMD0=0
  1.  . F  S BPMD0=$O(^BARAC(DUZ(2),"B",X,BPMD0)) Q:'BPMD0  D
  1.  . . N X  ;IHS/OIT/NKD BPM*1.0*2 NEW X LOCAL VARIABLE
  1.  . . S BPMPTR=$P($G(^BARAC(DUZ(2),BPMD0,0)),U)
  1.  . . Q:+BPMPTR'=BPMFR
  1.  . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . S $P(^BARAC(DUZ(2),BPMD0,0),U)=BPMTO_";AUPNPAT("
  1.  . . S DA=BPMD0
  1.  . . S X=BPMFR_";AUPNPAT("
  1.  . . X ^DD(90050.02,.01,1,1,2)
  1.  . . X ^DD(90050.02,.01,1,2,2)
  1.  . . S X=BPMTO_";AUPNPAT("
  1.  . . X ^DD(90050.02,.01,1,1,1)
  1.  . . X ^DD(90050.02,.01,1,2,1)
  1.  I BPMDUZ2 S DUZ(2)=BPMDUZ2    ;resetting DUZ(2) back to original value
  1.  Q
  1.  ;
  1. I2(BPMFR,BPMTO) ;
  1.  ; ----- REPOINT "GUARANTOR" FIELD (#.01) UNDER GUARANTOR SUBFIELD (#101)
  1.  ;         IN GUARANTOR FILE (#9000043)
  1.  ;
  1.  NEW BPMD0,BPMD1,VP,X,DA
  1.  S BPMD0=0 F  S BPMD0=$O(^AUPNGUAR(BPMD0)) Q:'BPMD0  D
  1.  . S BPMD1=0 F  S BPMD1=$O(^AUPNGUAR(BPMD0,1,BPMD1)) Q:'BPMD1  D
  1.  . . S VP=$P($G(^AUPNGUAR(BPMD0,1,BPMD1,0)),U)
  1.  . . Q:+VP'=BPMFR
  1.  . . Q:$P(VP,";",2)'="AUPNPAT("
  1.  . . S $P(^AUPNGUAR(BPMD0,1,BPMD1,0),U)=BPMTO_";AUPNPAT("
  1.  . . S DA(1)=BPMD0,DA=BPMD1
  1.  . . S X=VP
  1.  . . X ^DD(9000043.0101,.01,1,1,2)
  1.  . . X ^DD(9000043.0101,.01,1,2,2)
  1.  . . S X=BPMTO_";AUPNPAT("
  1.  . . X ^DD(9000043.0101,.01,1,1,1)
  1.  . . X ^DD(9000043.0101,.01,1,2,1)
  1.  Q
  1.  ;
  1. I3(BPMFR,BPMTO) ;
  1.  ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P CLAIM DATA FILE
  1.  ;
  1.  NEW BPMD0,BPMDUZ2,BPMPTR
  1.  ;
  1.  S BPMDUZ2=0
  1.  F  S BPMDUZ2=$O(^ABMDCLM(BPMDUZ2)) Q:'BPMDUZ2  D
  1.  . S BPMD0=0
  1.  . F  S BPMD0=$O(^ABMDCLM(BPMDUZ2,BPMD0)) Q:'BPMD0  D
  1.  . . S BPMPTR=$P($G(^ABMDCLM(BPMDUZ2,BPMD0,12)),U,7)
  1.  . . Q:+BPMPTR'=BPMFR
  1.  . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . S $P(^ABMDCLM(BPMDUZ2,BPMD0,12),U,7)=BPMTO_";AUPNPAT("
  1.  ;
  1.  ; no cross references on field to fix
  1.  Q
  1.  ;
  1. I4(BPMFR,BPMTO) ;
  1.  ; ----- REPOINT DESTINATION FIELD (#.127) IN 3P BILL FILE
  1.  ;
  1.  NEW BPMD0,BPMDUZ2,BPMPTR
  1.  ;
  1.  S BPMDUZ2=0
  1.  F  S BPMDUZ2=$O(^ABMDBILL(BPMDUZ2)) Q:'BPMDUZ2  D
  1.  . S BPMD0=0
  1.  . F  S BPMD0=$O(^ABMDBILL(BPMDUZ2,BPMD0)) Q:'BPMD0  D
  1.  . . S BPMPTR=$P($G(^ABMDBILL(BPMDUZ2,BPMD0,12)),U,7)
  1.  . . Q:+BPMPTR'=BPMFR
  1.  . . Q:$P(BPMPTR,";",2)'="AUPNPAT("
  1.  . . S $P(^ABMDBILL(BPMDUZ2,BPMD0,12),U,7)=BPMTO_";AUPNPAT("
  1.  ;
  1.  ; no cross references on field to fix
  1.  Q
  1.  ;
  1. V1(BPMFR,BPMTO) ;
  1.  ;----- REPOINT 'PATIENT NAME' FIELD #2 OF THE 'WKLD LOG FILE' #64.03
  1.  ;      Part of Lab but Lab Merge doesn't handle it
  1.  ;
  1.  N BPMD0,BPMPTR
  1.  ;
  1.  S BPMD0=0
  1.  F  S BPMD0=$O(^LRO(64.03,BPMD0))  Q:'BPMD0  D
  1.  . S BPMPTR=$P($G(^LRO(64.03,BPMD0,0)),U,3)
  1.  . Q:+BPMPTR'=BPMFR
  1.  . Q:$P(BPMPTR,";",2)'="DPT("
  1.  . S $P(^LRO(64.03,BPMD0,0),U,3)=BPMTO_";DPT("
  1.  Q
  1.  ;
  1. V2(BPMFR,BPMTO) ;
  1.  ;----- REPOINT 'PATIENT' FIELD #9 OF THE 'ACCESSION WKLD
  1.  ;      CODE TIME' SUBFIELD #1 OF THE 'WKLD CODE' SUBFIELD
  1.  ;      #1 OF THE 'DATE' SUBFIELD #.03 OF THE 'WKLD DATA'
  1.  ;      FILE #64.1
  1.  ;      Part of Lab but Lab Merge doesn't handle it
  1.  ;
  1.  N BPMD0,BPMD1,BPMD2,BPMD3,BPMPTR
  1.  ;
  1.  S BPMD0=0
  1.  F  S BPMD0=$O(^LRO(64.1,BPMD0)) Q:'BPMD0  D
  1.  . S BPMD1=0
  1.  . F  S BPMD1=$O(^LRO(64.1,BPMD0,1,BPMD1)) Q:'BPMD1  D
  1.  . . S BPMD2=0
  1.  . . F  S BPMD2=$O(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2)) Q:'BPMD2  D
  1.  . . . S BPMD3=0
  1.  . . . F  S BPMD3=$O(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3)) Q:'BPMD3  D
  1.  . . . . S BPMPTR=$P($G(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3,0)),U,10)
  1.  . . . . Q:+BPMPTR'=BPMFR
  1.  . . . . Q:$P(BPMPTR,";",2)'="DPT("
  1.  . . . . S $P(^LRO(64.1,BPMD0,1,BPMD1,1,BPMD2,1,BPMD3,0),U,10)=BPMTO_";DPT("
  1.  Q
  1.  ;
  1. V3(BPMFR,BPMTO) ;
  1.  ;----- REPOINT 'OBJECT OF ORDER' FIELD #.02 OF THE 'ORDER' FILE #100
  1.  ;   Waiting for VA to release patch that handles variable pointers correctly
  1.  ;
  1.  N BPM0,BPMD0,BPMPTR,DA,X,DIK
  1.  ;
  1.  S BPMD0=0
  1.  F  S BPMD0=$O(^OR(100,BPMD0)) Q:'BPMD0  D
  1.  . S BPMPTR=$P($G(^OR(100,BPMD0,0)),U,2)
  1.  . Q:+BPMPTR'=BPMFR
  1.  . Q:$P(BPMPTR,";",2)'="DPT("
  1.  . S BPM0=$G(^OR(100,BPMD0,0))
  1.  . ;
  1.  . ;----- XECUTE KILL LOGIC FOR XREFS
  1.  .;IHS/OIT/NKD BPM*1.0*2 RE-INDEXING ALL X-REFS
  1.  .; ;"AC" XREF #2:
  1.  .; I +$P(BPM0,U,2),$P(BPM0,U,7) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMPTR
  1.  .; . X ^DD(100,.02,1,2,2) ;KILL
  1.  .; ;"AS" XREF #5:
  1.  .; S DA=BPMD0
  1.  .; S X=BPMPTR
  1.  .; X ^DD(100,.02,1,5,2)
  1.  .; ;"AR" XREF #7:
  1.  .; S DA=BPMD0
  1.  .; S X=BPMPTR
  1.  .; X ^DD(100,.02,1,7,2)
  1.  .; ;"AW" XREF #9:
  1.  .; I +$P(BPM0,U,2),$P(BPM0,U,11) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMPTR
  1.  .; . X ^DD(100,.02,1,9,2)
  1.  .; ;"AOI1" XREF #10:
  1.  .; I +$P(BPM0,U,2) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMPTR
  1.  .; . X ^DD(100,.02,1,10,2)
  1.  .; ;"ACT1" XREF #11:
  1.  .; I $P(BPM0,U,11) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMPTR
  1.  .; . X ^DD(100,.02,1,11,2)
  1.  . S DIK="^OR(100,",DA=BPMD0
  1.  . D IX2^DIK
  1.  . ;
  1.  . ;----- RESET VARIABLE POINTER
  1.  . S $P(^OR(100,BPMD0,0),U,2)=BPMTO_";DPT("
  1.  . S BPM0=$G(^OR(100,BPMD0,0))
  1.  . ;
  1.  . ;----- XECUTE SET LOGIC FOR XREFS
  1.  .;IHS/OIT/NKD BPM*1.0*2 RE-INDEXING ALL X-REFS
  1.  .; ;"AC" XREF #2:
  1.  .; I +$P(BPM0,U,2),$P(BPM0,U,7) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMTO_";DPT("
  1.  .; . X ^DD(100,.02,1,2,1) ;SET
  1.  .; ;"AS" XREF #5:
  1.  .; S DA=BPMD0
  1.  .; S X=BPMTO_";DPT("
  1.  .; X ^DD(100,.02,1,5,1)
  1.  .; ;"AR" XREF #7:
  1.  .; S DA=BPMD0
  1.  .; S X=BPMTO_";DPT("
  1.  .; X ^DD(100,.02,1,7,1)
  1.  .; ;"AW" XREF #9:
  1.  .; I +$P(BPM0,U,2),$P(BPM0,U,11) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMTO_";DPT("
  1.  .; . X ^DD(100,.02,1,9,1)
  1.  .; ;"AOI1" XREF #10:
  1.  .; I +$P(BPM0,U,2) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMTO_";DPT("
  1.  .; . X ^DD(100,.02,1,10,1)
  1.  .; ;"ACT1" XREF #11:
  1.  .; I $P(BPM0,U,11) D
  1.  .; . S DA=BPMD0
  1.  .; . S X=BPMTO_";DPT("
  1.  .; . X ^DD(100,.02,1,11,1)
  1.  . S DIK="^OR(100,",DA=BPMD0
  1.  . D IX1^DIK
  1.  Q
  1.  ;
  1. V4(BPMFR,BPMTO) ;
  1.  ;----- REPOINT 'MEMBER' FIELD #.01 OF THE 'MEMBER' SUBFIELD #10
  1.  ;      OF THE 'OE/RR LIST' FILE #100.21
  1.  ;
  1.  N BPMD0,BPMD1,BPMPTR,DA,X
  1.  ;
  1.  S BPMD0=0
  1.  F  S BPMD0=$O(^OR(100.21,BPMD0)) Q:'BPMD0  D
  1.  . S BPMD1=0
  1.  . F  S BPMD1=$O(^OR(100.21,BPMD0,10,BPMD1)) Q:'BPMD1  D
  1.  . . S BPMPTR=$P($G(^OR(100.21,BPMD0,10,BPMD1,0)),U)
  1.  . . Q:+BPMPTR'=BPMFR
  1.  . . Q:$P(BPMPTR,";",2)'="DPT("
  1.  . . S $P(^OR(100.21,BPMD0,10,BPMD1,0),U)=BPMTO_";DPT("
  1.  . . S DA=BPMD1
  1.  . . S DA(1)=BPMD0
  1.  . . S X=BPMPTR
  1.  . . X ^DD(100.2101,.01,1,1,2)
  1.  . . X ^DD(100.2101,.01,1,2,2)
  1.  . . S X=BPMTO_";DPT("
  1.  . . X ^DD(100.2101,.01,1,1,1)
  1.  . . X ^DD(100.2101,.01,1,2,1)
  1.  Q
  1.  ;
  1. V5(BPMFR,BPMTO) ;
  1.  ;----- REPOINT 'PERSON' FIELD #.03 OF THE 'PATIENT RELATION'
  1.  ;      FILE #408.12
  1.  ;
  1.  N BPMD0,BPMPTR,DA,X
  1.  ;
  1.  S BPMD0=0
  1.  F  S BPMD0=$O(^DGPR(408.12,BPMD0)) Q:'BPMD0  D
  1.  . S BPMPTR=$P($G(^DGPR(408.12,BPMD0,0)),U,3)
  1.  . Q:+BPMPTR'=BPMFR
  1.  . Q:$P(BPMPTR,";",2)'="DPT("
  1.  . S $P(^DGPR(408.12,BPMD0,0),U,3)=BPMTO_";DPT("
  1.  . S DA=BPMD0
  1.  . S X=BPMPTR
  1.  . X ^DD(408.12,.03,1,1,2)
  1.  . S X=BPMTO_";DPT("
  1.  . X ^DD(408.12,.03,1,1,1)
  1.  Q