BPMXPRB ;IHS/PHXAO/AEF - REPOINT & RESEQUENCE PROBLEM FILE - 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 Changed re-sequencing process based on division
; and sequence
; Update "MODIFIED" x-ref
;;
DESC ;----- ROUTINE DESCRIPTION
;;
;;BPMXPRB:
;;THIS ROUTINE MERGES THE ENTRIES IN THE PROBLEM FILE #9000011.
;;SINCE BOTH FROM AND TO PATIENTS MAY HAVE PROBLEM #1, THEY NEED TO
;;BE RESEQUENCED IN ADDITION TO HAVING THE PATIENT POINTERS UPDATED.
;;
;;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 DATA
; GET THE FROM PATIENT'S PROBLEM LIST, AND STORE IN A LOCAL VARIABLE
; THEN MERGE ENTRIES INTO THE TO PATIENT, BY FACILITY THEN SEQUENCE NUMBER
;
;IHS/OIT/NKD BPM*1.0*2 START OLD CODE
;N BPM
;D BLD(BPMTO,.BPM)
;D LOOP(BPMFR,BPMTO,.BPM)
;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
N BPMRES,BPMTMP,BPMCNT,I,BPMI,BPMF,BPMN
D FIND^DIC(9000011,,"@;.06I;.07","PQ",BPMFR,,"AC",,,"BPMRES")
S BPMCNT=$P(BPMRES("DILIST",0),"^",1)
Q:BPMCNT=0
F I=1:1:BPMCNT D
. S BPMI=$P(BPMRES("DILIST",I,0),"^",1),BPMF=$P(BPMRES("DILIST",I,0),"^",2),BPMN=$P(BPMRES("DILIST",I,0),"^",3)
. ; IF NO FACILITY, SET TO 0 (FOR THE PURPOSE OF SETTING LOCAL VARIABLE)
. S:BPMF="" BPMF=0
. S:BPMN="" BPMN=1
. S BPMTMP(BPMF,BPMN,BPMI)=""
S BPMF=""
F S BPMF=$O(BPMTMP(BPMF)) Q:$L(BPMF)<1 D
. S BPMN=""
. F S BPMN=$O(BPMTMP(BPMF,BPMN)) Q:$L(BPMN)<1 D
. . S BPMI=""
. . F S BPMI=$O(BPMTMP(BPMF,BPMN,BPMI)) Q:$L(BPMI)<1 D
. . . D ONE(BPMFR,BPMTO,BPMI)
;IHS/OIT/NKD BPM*1.0*2 UPDATE MODIFIED X-REF
K ^AUPNPROB("MODIFIED",BPMFR),^AUPNPROB("MODIFIED",BPMTO)
S ^AUPNPROB("MODIFIED",BPMTO,$$NOW^XLFDT())=""
Q
;
;IHS/OIT/NKD BPM*1.0*2 START OLD CODE
;LOOP(BPMFR,BPMTO,BPM) ;
;----- LOOP THROUGH AC XREF TO FIND ENTRIES TO MERGE
;
;N BPMD0
;
;S BPMD0=0
;F S BPMD0=$O(^AUPNPROB("AC",BPMFR,BPMD0)) Q:'BPMD0 D
;. D ONE(BPMFR,BPMTO,BPMD0,.BPM)
;
;Q
;ONE(BPMFR,BPMTO,BPMD0,BPM) ;
;N BPMNUM,DA,DIE,DITC,DR,X,Y
;S BPMNUM=$$NUM(BPMTO,BPMD0,.BPM),DITC=1,DIE="^AUPNPROB(",DA=BPMD0,DR=".02////"_BPMTO,DR=DR_";.07////"_BPMNUM
;D ^DIE
;S BPM(BPMTO,BPMNUM)=BPMD0
;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
ONE(BPMFR,BPMTO,BPMI) ;
;----- PROCESS ONE ENTRY
;
N FDA
S FDA(9000011,BPMI_",",.02)=BPMTO ; Name (.02)
S FDA(9000011,BPMI_",",.07)=$$NEXT(BPMTO,$$GET1^DIQ(9000011,BPMI,.06,"I")) ; NMBR (.07)
D UPDATE^DIE(,"FDA",)
;
Q
NEXT(DFN,FAC) ;
;----- RETURN THE NEXT HIGHEST AVAILABLE SEQUENCE NUMBER
N BPMOUT,I,X
S U="^",X=0
; SCREEN ENTRIES BASED ON FACILITY
D FIND^DIC(9000011,,"@;.02I;.06I;.07","PQ",DFN,,"AC","I $P(^(0),U,6)=FAC",,"BPMOUT")
; FIND THE HIGHEST CURRENT SEQUENCE NUMBER
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)
; INCREMENT TO THE NEXT WHOLE NUMBER
S X=X-(X#1)+1
Q X
;IHS/OIT/NKD BPM*1.0*2 END NEW CODE - START OLD CODE
;BLD(BPMTO,BPM) ;
;----- BUILD ARRAY OF PROBLEMS FOR "TO" ENTRY
;
;N N,X,Y
;
;S X=0
;F S X=$O(^AUPNPROB("AC",BPMTO,X)) Q:'X D
;. S Y=$G(^AUPNPROB(X,0))
;. S N=$P(Y,U,7)
;. I N S BPM(BPMTO,N)=X
;Q
;NUM(BPMTO,BPMD0,BPM) ;
;----- RETURNS PROBLEM NUMBER
;
;N Y
;S Y=$P($G(^AUPNPROB(BPMD0,0)),U,7) S:Y="" Y=1
;I $D(BPM(BPMTO,Y)) D
;. F Y=1:1 Q:'$D(BPM(BPMTO,Y))
;Q Y
;IHS/OIT/NKD BPM*1.0*2 END OLD CODE
BPMXPRB ;IHS/PHXAO/AEF - REPOINT & RESEQUENCE PROBLEM FILE - 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 Changed re-sequencing process based on division
+5 ; and sequence
+6 ; Update "MODIFIED" x-ref
+7 ;;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;BPMXPRB:
+3 ;;THIS ROUTINE MERGES THE ENTRIES IN THE PROBLEM FILE #9000011.
+4 ;;SINCE BOTH FROM AND TO PATIENTS MAY HAVE PROBLEM #1, THEY NEED TO
+5 ;;BE RESEQUENCED IN ADDITION TO HAVING THE PATIENT POINTERS UPDATED.
+6 ;;
+7 ;;THIS ROUTINE IS CALLED BY THE SPECIAL MERGE ROUTINE DRIVER - ^BPMXDRV
+8 ;;
+9 ;;THE IHS PATIENT MERGE SOFTWARE ENTERS AT EN LINE LABEL. IT IS EXPECTED
+10 ;;THAT THE FOLLOWING GLOBAL WOULD HAVE BEEN SET UP BY THE PATIENT MERGE
+11 ;;SOFTWARE:
+12 ;; ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+13 ;;EXAMPLE:
+14 ;; ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+15 ;;WHERE =2 IS THE PARENT FILE (VA PATIENT FILE)
+16 ;;
+17 ;;$$END
+18 ;
+19 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
DO EN^DDIOL(X)
+20 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 ;
+8 SET BPMFR=$ORDER(@BPMRY@(0))
+9 IF 'BPMFR
QUIT
+10 SET BPMTO=$ORDER(@BPMRY@(BPMFR,0))
+11 IF 'BPMTO
QUIT
+12 ;
+13 DO PROC(BPMFR,BPMTO)
+14 QUIT
PROC(BPMFR,BPMTO) ;
+1 ;----- PROCESS DATA
+2 ; GET THE FROM PATIENT'S PROBLEM LIST, AND STORE IN A LOCAL VARIABLE
+3 ; THEN MERGE ENTRIES INTO THE TO PATIENT, BY FACILITY THEN SEQUENCE NUMBER
+4 ;
+5 ;IHS/OIT/NKD BPM*1.0*2 START OLD CODE
+6 ;N BPM
+7 ;D BLD(BPMTO,.BPM)
+8 ;D LOOP(BPMFR,BPMTO,.BPM)
+9 ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
+10 NEW BPMRES,BPMTMP,BPMCNT,I,BPMI,BPMF,BPMN
+11 DO FIND^DIC(9000011,,"@;.06I;.07","PQ",BPMFR,,"AC",,,"BPMRES")
+12 SET BPMCNT=$PIECE(BPMRES("DILIST",0),"^",1)
+13 IF BPMCNT=0
QUIT
+14 FOR I=1:1:BPMCNT
Begin DoDot:1
+15 SET BPMI=$PIECE(BPMRES("DILIST",I,0),"^",1)
SET BPMF=$PIECE(BPMRES("DILIST",I,0),"^",2)
SET BPMN=$PIECE(BPMRES("DILIST",I,0),"^",3)
+16 ; IF NO FACILITY, SET TO 0 (FOR THE PURPOSE OF SETTING LOCAL VARIABLE)
+17 IF BPMF=""
SET BPMF=0
+18 IF BPMN=""
SET BPMN=1
+19 SET BPMTMP(BPMF,BPMN,BPMI)=""
End DoDot:1
+20 SET BPMF=""
+21 FOR
SET BPMF=$ORDER(BPMTMP(BPMF))
IF $LENGTH(BPMF)<1
QUIT
Begin DoDot:1
+22 SET BPMN=""
+23 FOR
SET BPMN=$ORDER(BPMTMP(BPMF,BPMN))
IF $LENGTH(BPMN)<1
QUIT
Begin DoDot:2
+24 SET BPMI=""
+25 FOR
SET BPMI=$ORDER(BPMTMP(BPMF,BPMN,BPMI))
IF $LENGTH(BPMI)<1
QUIT
Begin DoDot:3
+26 DO ONE(BPMFR,BPMTO,BPMI)
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;IHS/OIT/NKD BPM*1.0*2 UPDATE MODIFIED X-REF
+28 KILL ^AUPNPROB("MODIFIED",BPMFR),^AUPNPROB("MODIFIED",BPMTO)
+29 SET ^AUPNPROB("MODIFIED",BPMTO,$$NOW^XLFDT())=""
+30 QUIT
+31 ;
+32 ;IHS/OIT/NKD BPM*1.0*2 START OLD CODE
+33 ;LOOP(BPMFR,BPMTO,BPM) ;
+34 ;----- LOOP THROUGH AC XREF TO FIND ENTRIES TO MERGE
+35 ;
+36 ;N BPMD0
+37 ;
+38 ;S BPMD0=0
+39 ;F S BPMD0=$O(^AUPNPROB("AC",BPMFR,BPMD0)) Q:'BPMD0 D
+40 ;. D ONE(BPMFR,BPMTO,BPMD0,.BPM)
+41 ;
+42 ;Q
+43 ;ONE(BPMFR,BPMTO,BPMD0,BPM) ;
+44 ;N BPMNUM,DA,DIE,DITC,DR,X,Y
+45 ;S BPMNUM=$$NUM(BPMTO,BPMD0,.BPM),DITC=1,DIE="^AUPNPROB(",DA=BPMD0,DR=".02////"_BPMTO,DR=DR_";.07////"_BPMNUM
+46 ;D ^DIE
+47 ;S BPM(BPMTO,BPMNUM)=BPMD0
+48 ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE - START NEW CODE
ONE(BPMFR,BPMTO,BPMI) ;
+1 ;----- PROCESS ONE ENTRY
+2 ;
+3 NEW FDA
+4 ; Name (.02)
SET FDA(9000011,BPMI_",",.02)=BPMTO
+5 ; NMBR (.07)
SET FDA(9000011,BPMI_",",.07)=$$NEXT(BPMTO,$$GET1^DIQ(9000011,BPMI,.06,"I"))
+6 DO UPDATE^DIE(,"FDA",)
+7 ;
+8 QUIT
NEXT(DFN,FAC) ;
+1 ;----- RETURN THE NEXT HIGHEST AVAILABLE SEQUENCE NUMBER
+2 NEW BPMOUT,I,X
+3 SET U="^"
SET X=0
+4 ; SCREEN ENTRIES BASED ON FACILITY
+5 DO FIND^DIC(9000011,,"@;.02I;.06I;.07","PQ",DFN,,"AC","I $P(^(0),U,6)=FAC",,"BPMOUT")
+6 ; FIND THE HIGHEST CURRENT SEQUENCE NUMBER
+7 FOR I=1:1:$PIECE(BPMOUT("DILIST",0),U,1)
IF $PIECE(BPMOUT("DILIST",I,0),U,4)>X
SET X=$PIECE(BPMOUT("DILIST",I,0),U,4)
+8 ; INCREMENT TO THE NEXT WHOLE NUMBER
+9 SET X=X-(X#1)+1
+10 QUIT X
+11 ;IHS/OIT/NKD BPM*1.0*2 END NEW CODE - START OLD CODE
+12 ;BLD(BPMTO,BPM) ;
+13 ;----- BUILD ARRAY OF PROBLEMS FOR "TO" ENTRY
+14 ;
+15 ;N N,X,Y
+16 ;
+17 ;S X=0
+18 ;F S X=$O(^AUPNPROB("AC",BPMTO,X)) Q:'X D
+19 ;. S Y=$G(^AUPNPROB(X,0))
+20 ;. S N=$P(Y,U,7)
+21 ;. I N S BPM(BPMTO,N)=X
+22 ;Q
+23 ;NUM(BPMTO,BPMD0,BPM) ;
+24 ;----- RETURNS PROBLEM NUMBER
+25 ;
+26 ;N Y
+27 ;S Y=$P($G(^AUPNPROB(BPMD0,0)),U,7) S:Y="" Y=1
+28 ;I $D(BPM(BPMTO,Y)) D
+29 ;. F Y=1:1 Q:'$D(BPM(BPMTO,Y))
+30 ;Q Y
+31 ;IHS/OIT/NKD BPM*1.0*2 END OLD CODE
