BQIPTMRG ;PRXM/HC/ALA-iCare Merge Patient Update ; 18 Oct 2007 3:29 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**1**;Apr 18, 2012;Build 43
;
DESC ;----- ROUTINE DESCRIPTION
;;
;;BPMXBQI:
;;This routine merges patient data for the following iCare files -
;; ICARE USER (#90505), ICARE PATIENT (#90507.5),
;; ICARE DX CAT REGISTRY (#90509 - v 1.2),
;; ICARE DX CAT FACTORS (#90509.5 - v 1.2)
;;
;;This routine is called by the special merge routine driver - ^BPMXDRV
;;
;;The IHS patient merge sofware 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
;
NEW 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
; Input parameter
; BPMRY = Temp global set up by the patient merge software,
; i.e., "^TMP(""XDRFROM"",$J)"
;
NEW 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 patient data
;
NEW DIK,DA,UID,BI
S UID=$J
;Update the ICARE PATIENT File (#90507.5)
I $G(^BQIPAT(BPMTO,0))="" D
. I $P($G(^DPT(BPMTO,.35)),U,1)'="" Q
. ; Create new record
. D NPT^BQITASK(BPMTO)
. I $G(^BQIPAT(BPMFR,0))="" Q
. S $P(^BQIPAT(BPMTO,0),U,2,99)=$P(^BQIPAT(BPMFR,0),U,2,99)
. F BI=10,20,30,40,50,60 M ^BQIPAT(BPMTO,BI)=^BQIPAT(BPMFR,BI)
S DIK="^BQIPAT(",DA=BPMFR D ^DIK
; Reindex new record
S DIK="^BQIPAT(",DA=BPMTO D EN1^DIK
;
;Update the ICARE USER File (#90505)
;Check if patient exists in any panels and update them
NEW OWNR,PLIEN
S OWNR=""
F S OWNR=$O(^BQICARE("AB",BPMFR,OWNR)) Q:OWNR="" D
. S PLIEN=""
. F S PLIEN=$O(^BQICARE("AB",BPMFR,OWNR,PLIEN)) Q:PLIEN="" D
.. NEW DIC,DIE,DA,IENS,X,DATA,DINUM,DLAYGO
.. S DATA=$G(^BQICARE(OWNR,1,PLIEN,40,BPMFR,0)) I DATA="" K ^BQICARE("AB",BPMFR,OWNR,PLIEN) Q
.. ;
.. NEW DA,DIK
.. S DA(2)=OWNR,DA(1)=PLIEN,DA=BPMFR
.. ; Delete old record
.. S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",40," D ^DIK
.. ; Add new record
.. NEW DA,X,DINUM,DIC,DIE,DLAYGO,BQN
.. S DA(2)=OWNR,DA(1)=PLIEN,(X,DINUM)=BPMTO
.. S DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",40,",DIE=DIC
.. S DLAYGO=90505.04,DIC(0)="L",DIC("P")=DLAYGO
.. I '$D(^BQICARE(DA(2),1,DA(1),40,0)) S ^BQICARE(DA(2),1,DA(1),40,0)="^90505.04P^^"
.. K DO,DD D FILE^DICN
.. F BQN=2:1:$L(DATA,U) S $P(^BQICARE(OWNR,1,PLIEN,40,BPMTO,0),U,BQN)=$P(DATA,U,BQN)
.. D STA^BQIPLRF(OWNR,PLIEN)
.. D ULK^BQIPLRF(OWNR,PLIEN)
;
; for version 2.0 of iCare
;Update ICARE DX CAT REGISTRY File (#90509)
I $G(^BQIREG(0))="" Q
NEW IEN,BQIUPD
S IEN=""
F S IEN=$O(^BQIREG("AC",BPMFR,IEN)) Q:IEN="" D
. S BQIUPD(90509,IEN_",",.02)=BPMTO
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
;Update ICARE ICARE DX CAT FACTORS File (#90509.5)
S IEN=""
F S IEN=$O(^BQIFACT("AC",BPMFR,IEN)) Q:IEN="" D
. S BQIUPD(90509.5,IEN_",",.02)=BPMTO
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; Update BKM
I $D(^BKM(90451,"B",BPMFR)) D
. S IEN=$O(^BKM(90451,"B",BPMFR,""))
. S UPD(90451,IEN_",",.01)=BPMTO
. D FILE^DIE("","UPD","ERROR")
;
Q
;
CHK(BPMFR) ;EP - Check if FROM patient is in a panel that is opened
NEW OWNR,PLIEN,UID,ARRAY,BQIX,LOCK,LGLOB,FLAG
S OWNR="",FLAG=1,UID=$J
I $O(^BQICARE("AB",BPMFR,OWNR))="" Q 1
F S OWNR=$O(^BQICARE("AB",BPMFR,OWNR)) Q:OWNR="" D
. S PLIEN=""
. F S PLIEN=$O(^BQICARE("AB",BPMFR,OWNR,PLIEN)) Q:PLIEN="" D
.. ; Try to lock all panels containing the patient being merged
.. S LOCK=$$LCK^BQIPLRF(OWNR,PLIEN)
.. S ARRAY(OWNR,PLIEN)=LOCK
.. I 'LOCK D Q
... D STA^BQIPLRF(OWNR,PLIEN)
.. D STA^BQIPLRF(OWNR,PLIEN,1)
; If any panel was unable to be locked ('1'), set the flag to 'not'
S BQIX="ARRAY" F S BQIX=$Q(@BQIX) Q:BQIX="" S:$P(@BQIX,U,1)=0 FLAG=0
;
;If a panel is found to be locked, unlock all the others that were locked
;in the check above
I FLAG=0 D
. F S OWNR=$O(^BQICARE("AB",BPMFR,OWNR)) Q:OWNR="" D
.. S PLIEN=""
.. F S PLIEN=$O(^BQICARE("AB",BPMFR,OWNR,PLIEN)) Q:PLIEN="" D
... D STA^BQIPLRF(OWNR,PLIEN)
... D ULK^BQIPLRF(OWNR,PLIEN)
Q FLAG
BQIPTMRG ;PRXM/HC/ALA-iCare Merge Patient Update ; 18 Oct 2007 3:29 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**1**;Apr 18, 2012;Build 43
+2 ;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;BPMXBQI:
+3 ;;This routine merges patient data for the following iCare files -
+4 ;; ICARE USER (#90505), ICARE PATIENT (#90507.5),
+5 ;; ICARE DX CAT REGISTRY (#90509 - v 1.2),
+6 ;; ICARE DX CAT FACTORS (#90509.5 - v 1.2)
+7 ;;
+8 ;;This routine is called by the special merge routine driver - ^BPMXDRV
+9 ;;
+10 ;;The IHS patient merge sofware 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
+21 FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
DO EN^DDIOL(X)
+22 QUIT
+23 ;
EN(BPMRY) ;EP -- Main entry point
+1 ; Input parameter
+2 ; BPMRY = Temp global set up by the patient merge software,
+3 ; i.e., "^TMP(""XDRFROM"",$J)"
+4 ;
+5 NEW BPMFR,BPMTO
+6 ;
+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
+14 ;
PROC(BPMFR,BPMTO) ; Process patient data
+1 ;
+2 NEW DIK,DA,UID,BI
+3 SET UID=$JOB
+4 ;Update the ICARE PATIENT File (#90507.5)
+5 IF $GET(^BQIPAT(BPMTO,0))=""
Begin DoDot:1
+6 IF $PIECE($GET(^DPT(BPMTO,.35)),U,1)'=""
QUIT
+7 ; Create new record
+8 DO NPT^BQITASK(BPMTO)
+9 IF $GET(^BQIPAT(BPMFR,0))=""
QUIT
+10 SET $PIECE(^BQIPAT(BPMTO,0),U,2,99)=$PIECE(^BQIPAT(BPMFR,0),U,2,99)
+11 FOR BI=10,20,30,40,50,60
MERGE ^BQIPAT(BPMTO,BI)=^BQIPAT(BPMFR,BI)
End DoDot:1
+12 SET DIK="^BQIPAT("
SET DA=BPMFR
DO ^DIK
+13 ; Reindex new record
+14 SET DIK="^BQIPAT("
SET DA=BPMTO
DO EN1^DIK
+15 ;
+16 ;Update the ICARE USER File (#90505)
+17 ;Check if patient exists in any panels and update them
+18 NEW OWNR,PLIEN
+19 SET OWNR=""
+20 FOR
SET OWNR=$ORDER(^BQICARE("AB",BPMFR,OWNR))
IF OWNR=""
QUIT
Begin DoDot:1
+21 SET PLIEN=""
+22 FOR
SET PLIEN=$ORDER(^BQICARE("AB",BPMFR,OWNR,PLIEN))
IF PLIEN=""
QUIT
Begin DoDot:2
+23 NEW DIC,DIE,DA,IENS,X,DATA,DINUM,DLAYGO
+24 SET DATA=$GET(^BQICARE(OWNR,1,PLIEN,40,BPMFR,0))
IF DATA=""
KILL ^BQICARE("AB",BPMFR,OWNR,PLIEN)
QUIT
+25 ;
+26 NEW DA,DIK
+27 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=BPMFR
+28 ; Delete old record
+29 SET DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",40,"
DO ^DIK
+30 ; Add new record
+31 NEW DA,X,DINUM,DIC,DIE,DLAYGO,BQN
+32 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET (X,DINUM)=BPMTO
+33 SET DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",40,"
SET DIE=DIC
+34 SET DLAYGO=90505.04
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+35 IF '$DATA(^BQICARE(DA(2),1,DA(1),40,0))
SET ^BQICARE(DA(2),1,DA(1),40,0)="^90505.04P^^"
+36 KILL DO,DD
DO FILE^DICN
+37 FOR BQN=2:1:$LENGTH(DATA,U)
SET $PIECE(^BQICARE(OWNR,1,PLIEN,40,BPMTO,0),U,BQN)=$PIECE(DATA,U,BQN)
+38 DO STA^BQIPLRF(OWNR,PLIEN)
+39 DO ULK^BQIPLRF(OWNR,PLIEN)
End DoDot:2
End DoDot:1
+40 ;
+41 ; for version 2.0 of iCare
+42 ;Update ICARE DX CAT REGISTRY File (#90509)
+43 IF $GET(^BQIREG(0))=""
QUIT
+44 NEW IEN,BQIUPD
+45 SET IEN=""
+46 FOR
SET IEN=$ORDER(^BQIREG("AC",BPMFR,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+47 SET BQIUPD(90509,IEN_",",.02)=BPMTO
End DoDot:1
+48 DO FILE^DIE("","BQIUPD","ERROR")
+49 KILL BQIUPD
+50 ;
+51 ;Update ICARE ICARE DX CAT FACTORS File (#90509.5)
+52 SET IEN=""
+53 FOR
SET IEN=$ORDER(^BQIFACT("AC",BPMFR,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+54 SET BQIUPD(90509.5,IEN_",",.02)=BPMTO
End DoDot:1
+55 DO FILE^DIE("","BQIUPD","ERROR")
+56 KILL BQIUPD
+57 ;
+58 ; Update BKM
+59 IF $DATA(^BKM(90451,"B",BPMFR))
Begin DoDot:1
+60 SET IEN=$ORDER(^BKM(90451,"B",BPMFR,""))
+61 SET UPD(90451,IEN_",",.01)=BPMTO
+62 DO FILE^DIE("","UPD","ERROR")
End DoDot:1
+63 ;
+64 QUIT
+65 ;
CHK(BPMFR) ;EP - Check if FROM patient is in a panel that is opened
+1 NEW OWNR,PLIEN,UID,ARRAY,BQIX,LOCK,LGLOB,FLAG
+2 SET OWNR=""
SET FLAG=1
SET UID=$JOB
+3 IF $ORDER(^BQICARE("AB",BPMFR,OWNR))=""
QUIT 1
+4 FOR
SET OWNR=$ORDER(^BQICARE("AB",BPMFR,OWNR))
IF OWNR=""
QUIT
Begin DoDot:1
+5 SET PLIEN=""
+6 FOR
SET PLIEN=$ORDER(^BQICARE("AB",BPMFR,OWNR,PLIEN))
IF PLIEN=""
QUIT
Begin DoDot:2
+7 ; Try to lock all panels containing the patient being merged
+8 SET LOCK=$$LCK^BQIPLRF(OWNR,PLIEN)
+9 SET ARRAY(OWNR,PLIEN)=LOCK
+10 IF 'LOCK
Begin DoDot:3
+11 DO STA^BQIPLRF(OWNR,PLIEN)
End DoDot:3
QUIT
+12 DO STA^BQIPLRF(OWNR,PLIEN,1)
End DoDot:2
End DoDot:1
+13 ; If any panel was unable to be locked ('1'), set the flag to 'not'
+14 SET BQIX="ARRAY"
FOR
SET BQIX=$QUERY(@BQIX)
IF BQIX=""
QUIT
IF $PIECE(@BQIX,U,1)=0
SET FLAG=0
+15 ;
+16 ;If a panel is found to be locked, unlock all the others that were locked
+17 ;in the check above
+18 IF FLAG=0
Begin DoDot:1
+19 FOR
SET OWNR=$ORDER(^BQICARE("AB",BPMFR,OWNR))
IF OWNR=""
QUIT
Begin DoDot:2
+20 SET PLIEN=""
+21 FOR
SET PLIEN=$ORDER(^BQICARE("AB",BPMFR,OWNR,PLIEN))
IF PLIEN=""
QUIT
Begin DoDot:3
+22 DO STA^BQIPLRF(OWNR,PLIEN)
+23 DO ULK^BQIPLRF(OWNR,PLIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT FLAG
