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

BPMXPRB.m

Go to the documentation of this file. 
  1. BPMXPRB ;IHS/PHXAO/AEF - REPOINT & RESEQUENCE PROBLEM FILE - 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.  ;IHS/OIT/NKD  6/13/2012 Changed re-sequencing process based on division
  1.  ;                        and sequence
  1.  ;                       Update "MODIFIED" x-ref
  1.  ;;
  1. DESC ;----- ROUTINE DESCRIPTION
  1.  ;;
  1.  ;;BPMXPRB:
  1.  ;;THIS ROUTINE MERGES THE ENTRIES IN THE PROBLEM FILE #9000011.
  1.  ;;SINCE BOTH FROM AND TO PATIENTS MAY HAVE PROBLEM #1, THEY NEED TO
  1.  ;;BE RESEQUENCED IN ADDITION TO HAVING THE PATIENT POINTERS UPDATED.
  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.  ;
  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 DATA
  1.  ; GET THE FROM PATIENT'S PROBLEM LIST, AND STORE IN A LOCAL VARIABLE
  1.  ; THEN MERGE ENTRIES INTO THE TO PATIENT, BY FACILITY THEN SEQUENCE NUMBER
  1.  ;
  1.  ;IHS/OIT/NKD BPM*1.0*2 START OLD CODE
  1.  ;N BPM
  1.  ;D BLD(BPMTO,.BPM)
  1.  ;D LOOP(BPMFR,BPMTO,.BPM)
  1.  ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
  1.  N BPMRES,BPMTMP,BPMCNT,I,BPMI,BPMF,BPMN
  1.  D FIND^DIC(9000011,,"@;.06I;.07","PQ",BPMFR,,"AC",,,"BPMRES")
  1.  S BPMCNT=$P(BPMRES("DILIST",0),"^",1)
  1.  Q:BPMCNT=0
  1.  F I=1:1:BPMCNT D
  1.  . S BPMI=$P(BPMRES("DILIST",I,0),"^",1),BPMF=$P(BPMRES("DILIST",I,0),"^",2),BPMN=$P(BPMRES("DILIST",I,0),"^",3)
  1.  . ; IF NO FACILITY, SET TO 0 (FOR THE PURPOSE OF SETTING LOCAL VARIABLE)
  1.  . S:BPMF="" BPMF=0
  1.  . S:BPMN="" BPMN=1
  1.  . S BPMTMP(BPMF,BPMN,BPMI)=""
  1.  S BPMF=""
  1.  F  S BPMF=$O(BPMTMP(BPMF)) Q:$L(BPMF)<1  D
  1.  . S BPMN=""
  1.  . F  S BPMN=$O(BPMTMP(BPMF,BPMN)) Q:$L(BPMN)<1  D
  1.  . . S BPMI=""
  1.  . . F  S BPMI=$O(BPMTMP(BPMF,BPMN,BPMI)) Q:$L(BPMI)<1  D
  1.  . . . D ONE(BPMFR,BPMTO,BPMI)
  1.  ;IHS/OIT/NKD BPM*1.0*2 UPDATE MODIFIED X-REF
  1.  K ^AUPNPROB("MODIFIED",BPMFR),^AUPNPROB("MODIFIED",BPMTO)
  1.  S ^AUPNPROB("MODIFIED",BPMTO,$$NOW^XLFDT())=""
  1.  Q
  1.  ;
  1.  ;IHS/OIT/NKD BPM*1.0*2 START OLD CODE
  1.  ;LOOP(BPMFR,BPMTO,BPM) ;
  1.  ;----- LOOP THROUGH AC XREF TO FIND ENTRIES TO MERGE
  1.  ;
  1.  ;N BPMD0
  1.  ;
  1.  ;S BPMD0=0
  1.  ;F  S BPMD0=$O(^AUPNPROB("AC",BPMFR,BPMD0)) Q:'BPMD0  D
  1.  ;. D ONE(BPMFR,BPMTO,BPMD0,.BPM)
  1.  ;
  1.  ;Q
  1.  ;ONE(BPMFR,BPMTO,BPMD0,BPM) ;
  1.  ;N BPMNUM,DA,DIE,DITC,DR,X,Y
  1.  ;S BPMNUM=$$NUM(BPMTO,BPMD0,.BPM),DITC=1,DIE="^AUPNPROB(",DA=BPMD0,DR=".02////"_BPMTO,DR=DR_";.07////"_BPMNUM
  1.  ;D ^DIE
  1.  ;S BPM(BPMTO,BPMNUM)=BPMD0
  1.  ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
  1. ONE(BPMFR,BPMTO,BPMI) ;
  1.  ;----- PROCESS ONE ENTRY
  1.  ;
  1.  N FDA
  1.  S FDA(9000011,BPMI_",",.02)=BPMTO ; Name (.02)
  1.  S FDA(9000011,BPMI_",",.07)=$$NEXT(BPMTO,$$GET1^DIQ(9000011,BPMI,.06,"I")) ; NMBR (.07)
  1.  D UPDATE^DIE(,"FDA",)
  1.  ;
  1.  Q
  1. NEXT(DFN,FAC) ;
  1.  ;----- RETURN THE NEXT HIGHEST AVAILABLE SEQUENCE NUMBER
  1.  N BPMOUT,I,X
  1.  S U="^",X=0
  1.  ; SCREEN ENTRIES BASED ON FACILITY
  1.  D FIND^DIC(9000011,,"@;.02I;.06I;.07","PQ",DFN,,"AC","I $P(^(0),U,6)=FAC",,"BPMOUT")
  1.  ; FIND THE HIGHEST CURRENT SEQUENCE NUMBER
  1.  F I=1:1:$P(BPMOUT("DILIST",0),U,1) S:$P(BPMOUT("DILIST",I,0),U,4)>X X=$P(BPMOUT("DILIST",I,0),U,4)
  1.  ; INCREMENT TO THE NEXT WHOLE NUMBER
  1.  S X=X-(X#1)+1
  1.  Q X
  1.  ;IHS/OIT/NKD BPM*1.0*2 END NEW CODE - START OLD CODE
  1.  ;BLD(BPMTO,BPM) ;
  1.  ;----- BUILD ARRAY OF PROBLEMS FOR "TO" ENTRY
  1.  ;
  1.  ;N N,X,Y
  1.  ;
  1.  ;S X=0
  1.  ;F  S X=$O(^AUPNPROB("AC",BPMTO,X)) Q:'X  D
  1.  ;. S Y=$G(^AUPNPROB(X,0))
  1.  ;. S N=$P(Y,U,7)
  1.  ;. I N S BPM(BPMTO,N)=X
  1.  ;Q
  1.  ;NUM(BPMTO,BPMD0,BPM) ;
  1.  ;----- RETURNS PROBLEM NUMBER
  1.  ;
  1.  ;N Y
  1.  ;S Y=$P($G(^AUPNPROB(BPMD0,0)),U,7) S:Y="" Y=1
  1.  ;I $D(BPM(BPMTO,Y)) D
  1.  ;. F Y=1:1 Q:'$D(BPM(BPMTO,Y))
  1.  ;Q Y
  1.  ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE