BQIPLCP ;PRXM/HC/KJH-Copy Panel Functions ; 2 Feb 2006 4:05 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
Q
;
EN(DATA,OWNR,OPLIEN,NPLNM,LYOUT) ; EP - BQI COPY PANEL
; Description
; Creates a copy of the original panel specified by OWNR and PLIEN
; under the current user (DUZ). All data is copied, except that the
; new panel name will be "Copy of "_OldPanelName if this is the first
; copy or "Copy (n) of "_OldPanelName if this is a subsequent copy.
;
; All data is copied from the original panel except the panel creation
; date/time (which is set to NOW). If the panel OWNR and the DUZ are
; different then the shared access information will also not be copied.
; Input:
; OWNR - Owner of the panel
; OPLIEN - Original panel IEN
; NPLNM - New panel name
; LYOUT - Flag to indicate whether to copy the layouts as well
; Output:
; DATA = name of global (passed by reference) in which the data is stored
;
; PLIEN - panel IEN (for the new panel)
; PLID - panel ID (DUZ of new owner and panel ien)
; PLNM - panel name (new panel name)
; or
; BMXSEC - if record can't be locked or if $D(ERROR)
; when filing or M error encountered
;
NEW UID,X,BQII
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLCP",UID))
K ^TMP("BQIPLCP",UID)
S LYOUT=$S($G(LYOUT)="Y":1,1:0)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLCP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Create owner (DUZ) if new to iCare - If unable to do so - error
I '$$OWNR^BQIPLUSR(DUZ) S BMXSEC="Unable to create panel" Q
;
; Create header record
S BQII=0,^TMP("BQIPLCP",UID,BQII)="I00010PANEL_IEN^T00020PANEL_ID^T00120PANEL_NAME"_$C(30)
;
N DA,DIK,OIENS,IENS,BQINEW,ERROR,OPLNM,SRCTYP
;
; Get panel name from 'original' panel
S DA=OPLIEN,DA(1)=OWNR,OIENS=$$IENS^DILF(.DA)
S OPLNM=$$GET1^DIQ(90505.01,OIENS,".01","I")
;
; Create a new panel and name
D FILE I $G(BMXSEC)]"" Q
;
; Copy PANEL DEFINITION (0 node)
M ^BQICARE(DUZ,1,PLIEN,0)=^BQICARE(OWNR,1,OPLIEN,0)
;
; Copy IPC field/Category
S $P(^BQICARE(DUZ,1,PLIEN,2),U)=$P($G(^BQICARE(OWNR,1,OPLIEN,2)),U)
S:DUZ=OWNR $P(^BQICARE(DUZ,1,PLIEN,2),U,2)=$P($G(^BQICARE(OWNR,1,OPLIEN,2)),U,2)
S:DUZ'=OWNR $P(^BQICARE(DUZ,1,PLIEN,2),U,2)=$P($G(^BQICARE(OWNR,1,OPLIEN,30,DUZ,0)),U,6)
;
; Update panel name, creation date/time, last updated by
; and updated date/time for 'new' panel
S DA(1)=DUZ,DA=PLIEN,IENS=$$IENS^DILF(.DA)
S BQINEW(90505.01,IENS,.01)=PLNM
I $$GET1^DIQ(90505.01,IENS,.02,"I")="" S BQINEW(90505.01,IENS,.02)=$$NOW^XLFDT()
S BQINEW(90505.01,IENS,.04)=DUZ
S BQINEW(90505.01,IENS,.05)=$$NOW^XLFDT()
D FILE^DIE("","BQINEW","ERROR")
;
; If an error occurred, remove the half-filed panel and return BMXSEC.
I $D(ERROR) D Q
. S DIK="^BQICARE("_DA(1)_",1,"
. D ^DIK
. S BMXSEC="Error encountered while copying panel definition."
. Q
;
; Copy data
D CPY(OWNR,OPLIEN,PLIEN)
;
; Check type of panel if moving a share
I OWNR'=DUZ D
. NEW DA,IENS
. S DA(1)=DUZ,DA=PLIEN,IENS=$$IENS^DILF(.DA)
. S SRCTYP=$$GET1^DIQ(90505.01,IENS,.03,"I")
. I SRCTYP'="Y" Q
. S BQIUPD(90505.01,IENS,.03)="M"
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
. K DESC
. D DESC^BQIPDSCM(DUZ,PLIEN,.DESC)
. D WP^DIE(90505.01,IENS,5,"","DESC")
. K DESC
. NEW DFN
. S DFN=0
. F S DFN=$O(^BQICARE(DUZ,1,PLIEN,40,DFN)) Q:'DFN D
.. I $P(^BQICARE(DUZ,1,PLIEN,40,DFN,0),U,2)'="" Q
.. S $P(^BQICARE(DUZ,1,PLIEN,40,DFN,0),U,2)="A"
.. S $P(^BQICARE(DUZ,1,PLIEN,40,DFN,0),U,4)=$$NOW^XLFDT()
;
; if user selected to copy the layout
I LYOUT D LAY(OWNR,OPLIEN,PLIEN)
;
; Return panel IEN, ID, and NAME on success
S PLID=$$PLID^BQIUG1(DUZ,PLIEN)
S BQII=BQII+1,^TMP("BQIPLCP",UID,BQII)=PLIEN_"^"_PLID_"^"_PLNM_$C(30)
S BQII=BQII+1,^TMP("BQIPLCP",UID,BQII)=$C(31)
K PLID,PLNM
Q
;
FILE ; Create name and file new panel under current DUZ
L +^BQICARE(DUZ,1,0):5
; NOTE: It is possible that the lock should be extended around the whole copy procedure.
; Potential problem is that the panel could become available to a shared user during
; the IX^DIK process but before the panel x-ref completes. This is a very small
; period of time, but should still be tested.
I '$T S BMXSEC="Unable to create panel" Q ; Error - unable to assign next panel IEN
D
. ; First try to create a new name for the panel using "Copy of "_OldName.
. N DA,PIENS,ERROR,II
. S PLNM=$S($G(NPLNM)'="":NPLNM,1:"Copy of "_OPLNM)
. S DA(1)=DUZ,DA=""
. S PIENS=$$IENS^DILF(.DA)
. I $$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")=0 Q ; New panel name not currently in use.
. ; Otherwise create a new name for the panel using "Copy (n) of "_OldName.
. F II=1:1 D I PLNM]"" Q
.. N DA,PIENS,ERROR
.. S PLNM="Copy ("_II_") of "_OPLNM
.. S DA(1)=DUZ,DA=""
.. S PIENS=$$IENS^DILF(.DA)
.. I $$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")=0 Q ; New panel name not currently in use.
.. S PLNM="" ; Clear panel name if currently in use
. Q
; File new panel
N DA,X,DINUM,DIC,DIE,DLAYGO
S DA(1)=DUZ,X=PLNM,DLAYGO=90505.01
S DIC="^BQICARE("_DA(1)_",1,",DIE=DIC
S DIC(0)="L",DIC("P")=DLAYGO
K DO,DD D FILE^DICN
S (DA,PLIEN)=+Y
I PLIEN=-1 S BMXSEC="Error encountered while filing panel."
L -^BQICARE(DUZ,1,0)
Q
;
ERR ;
L -^BQICARE(DUZ,1,0)
D ^%ZTER
N Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
Q
;
CPY(OWNR,OPLIEN,PLIEN) ;EP -- Copy data from one panel to another
; Input
; OWNR - Owner of panel
; OPLIEN - Original panel IEN
; PLIEN - New panel IEN
;
; Copy PANEL DEFINITION (remaining nodes)
;
I $D(^BQICARE(OWNR,1,OPLIEN,3)) M ^BQICARE(DUZ,1,PLIEN,3)=^BQICARE(OWNR,1,OPLIEN,3)
I $D(^BQICARE(OWNR,1,OPLIEN,5)) M ^BQICARE(DUZ,1,PLIEN,5)=^BQICARE(OWNR,1,OPLIEN,5)
;
; Copy PARAMETER DEFINITION
I $D(^BQICARE(OWNR,1,OPLIEN,10)) M ^BQICARE(DUZ,1,PLIEN,10)=^BQICARE(OWNR,1,OPLIEN,10)
;
; Copy FILTER DEFINITION
I $D(^BQICARE(OWNR,1,OPLIEN,15)) M ^BQICARE(DUZ,1,PLIEN,15)=^BQICARE(OWNR,1,OPLIEN,15)
;
; Copy PATIENT LIST
I $D(^BQICARE(OWNR,1,OPLIEN,40)) M ^BQICARE(DUZ,1,PLIEN,40)=^BQICARE(OWNR,1,OPLIEN,40)
;
; Update cross references for merged entries
S DIK="^BQICARE("_DA(1)_",1,"
D IX^DIK
Q
;
LAY(OWNR,OPLIEN,PLIEN) ;EP - Copy the layouts
NEW LYI,TMPLNM,DIK,DA,TMIEN,TMTYP
;
; if the user is the owner
;
I OWNR=DUZ D
. M ^BQICARE(DUZ,1,PLIEN,4)=^BQICARE(OWNR,1,OPLIEN,4) ;Template References
. M ^BQICARE(DUZ,1,PLIEN,20)=^BQICARE(OWNR,1,OPLIEN,20) ;Patient Layout
. M ^BQICARE(DUZ,1,PLIEN,22)=^BQICARE(OWNR,1,OPLIEN,22) ;Reminders
. M ^BQICARE(DUZ,1,PLIEN,25)=^BQICARE(OWNR,1,OPLIEN,25) ;Nat'l Meas
. M ^BQICARE(DUZ,1,PLIEN,23)=^BQICARE(OWNR,1,OPLIEN,23) ;Care Mgmt Layouts (Asthma and HIV/AIDS)
;
; if the user is not the owner, create customized
I OWNR'=DUZ D
. M ^BQICARE(DUZ,1,PLIEN,4)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,4)
. S $P(^BQICARE(DUZ,1,PLIEN,4,0),U,2)="90505.14"
. M ^BQICARE(DUZ,1,PLIEN,20)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,20)
. S $P(^BQICARE(DUZ,1,PLIEN,20,0),U,2)="90505.05P"
. M ^BQICARE(DUZ,1,PLIEN,22)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,22)
. S $P(^BQICARE(DUZ,1,PLIEN,22,0),U,2)="90505.122"
. M ^BQICARE(DUZ,1,PLIEN,23)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,23)
. S $P(^BQICARE(DUZ,1,PLIEN,23,0),U,2)="90505.123"
. N I S I=0 F S I=$O(^BQICARE(DUZ,1,PLIEN,23,I)) Q:'I S $P(^BQICARE(DUZ,1,PLIEN,23,I,1,0),U,2)="90505.1231"
. M ^BQICARE(DUZ,1,PLIEN,25)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,25)
. S $P(^BQICARE(DUZ,1,PLIEN,25,0),U,2)="90505.125"
;
; Update cross references for merged entries
S DIK="^BQICARE(",DA=DUZ
D IX^DIK
Q
BQIPLCP ;PRXM/HC/KJH-Copy Panel Functions ; 2 Feb 2006 4:05 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 QUIT
+4 ;
EN(DATA,OWNR,OPLIEN,NPLNM,LYOUT) ; EP - BQI COPY PANEL
+1 ; Description
+2 ; Creates a copy of the original panel specified by OWNR and PLIEN
+3 ; under the current user (DUZ). All data is copied, except that the
+4 ; new panel name will be "Copy of "_OldPanelName if this is the first
+5 ; copy or "Copy (n) of "_OldPanelName if this is a subsequent copy.
+6 ;
+7 ; All data is copied from the original panel except the panel creation
+8 ; date/time (which is set to NOW). If the panel OWNR and the DUZ are
+9 ; different then the shared access information will also not be copied.
+10 ; Input:
+11 ; OWNR - Owner of the panel
+12 ; OPLIEN - Original panel IEN
+13 ; NPLNM - New panel name
+14 ; LYOUT - Flag to indicate whether to copy the layouts as well
+15 ; Output:
+16 ; DATA = name of global (passed by reference) in which the data is stored
+17 ;
+18 ; PLIEN - panel IEN (for the new panel)
+19 ; PLID - panel ID (DUZ of new owner and panel ien)
+20 ; PLNM - panel name (new panel name)
+21 ; or
+22 ; BMXSEC - if record can't be locked or if $D(ERROR)
+23 ; when filing or M error encountered
+24 ;
+25 NEW UID,X,BQII
+26 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+27 SET DATA=$NAME(^TMP("BQIPLCP",UID))
+28 KILL ^TMP("BQIPLCP",UID)
+29 SET LYOUT=$SELECT($GET(LYOUT)="Y":1,1:0)
+30 ;
+31 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLCP D UNWIND^%ZTER"
+32 ;
+33 ; Create owner (DUZ) if new to iCare - If unable to do so - error
+34 IF '$$OWNR^BQIPLUSR(DUZ)
SET BMXSEC="Unable to create panel"
QUIT
+35 ;
+36 ; Create header record
+37 SET BQII=0
SET ^TMP("BQIPLCP",UID,BQII)="I00010PANEL_IEN^T00020PANEL_ID^T00120PANEL_NAME"_$CHAR(30)
+38 ;
+39 NEW DA,DIK,OIENS,IENS,BQINEW,ERROR,OPLNM,SRCTYP
+40 ;
+41 ; Get panel name from 'original' panel
+42 SET DA=OPLIEN
SET DA(1)=OWNR
SET OIENS=$$IENS^DILF(.DA)
+43 SET OPLNM=$$GET1^DIQ(90505.01,OIENS,".01","I")
+44 ;
+45 ; Create a new panel and name
+46 DO FILE
IF $GET(BMXSEC)]""
QUIT
+47 ;
+48 ; Copy PANEL DEFINITION (0 node)
+49 MERGE ^BQICARE(DUZ,1,PLIEN,0)=^BQICARE(OWNR,1,OPLIEN,0)
+50 ;
+51 ; Copy IPC field/Category
+52 SET $PIECE(^BQICARE(DUZ,1,PLIEN,2),U)=$PIECE($GET(^BQICARE(OWNR,1,OPLIEN,2)),U)
+53 IF DUZ=OWNR
SET $PIECE(^BQICARE(DUZ,1,PLIEN,2),U,2)=$PIECE($GET(^BQICARE(OWNR,1,OPLIEN,2)),U,2)
+54 IF DUZ'=OWNR
SET $PIECE(^BQICARE(DUZ,1,PLIEN,2),U,2)=$PIECE($GET(^BQICARE(OWNR,1,OPLIEN,30,DUZ,0)),U,6)
+55 ;
+56 ; Update panel name, creation date/time, last updated by
+57 ; and updated date/time for 'new' panel
+58 SET DA(1)=DUZ
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+59 SET BQINEW(90505.01,IENS,.01)=PLNM
+60 IF $$GET1^DIQ(90505.01,IENS,.02,"I")=""
SET BQINEW(90505.01,IENS,.02)=$$NOW^XLFDT()
+61 SET BQINEW(90505.01,IENS,.04)=DUZ
+62 SET BQINEW(90505.01,IENS,.05)=$$NOW^XLFDT()
+63 DO FILE^DIE("","BQINEW","ERROR")
+64 ;
+65 ; If an error occurred, remove the half-filed panel and return BMXSEC.
+66 IF $DATA(ERROR)
Begin DoDot:1
+67 SET DIK="^BQICARE("_DA(1)_",1,"
+68 DO ^DIK
+69 SET BMXSEC="Error encountered while copying panel definition."
+70 QUIT
End DoDot:1
QUIT
+71 ;
+72 ; Copy data
+73 DO CPY(OWNR,OPLIEN,PLIEN)
+74 ;
+75 ; Check type of panel if moving a share
+76 IF OWNR'=DUZ
Begin DoDot:1
+77 NEW DA,IENS
+78 SET DA(1)=DUZ
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+79 SET SRCTYP=$$GET1^DIQ(90505.01,IENS,.03,"I")
+80 IF SRCTYP'="Y"
QUIT
+81 SET BQIUPD(90505.01,IENS,.03)="M"
+82 DO FILE^DIE("","BQIUPD","ERROR")
+83 KILL BQIUPD
+84 KILL DESC
+85 DO DESC^BQIPDSCM(DUZ,PLIEN,.DESC)
+86 DO WP^DIE(90505.01,IENS,5,"","DESC")
+87 KILL DESC
+88 NEW DFN
+89 SET DFN=0
+90 FOR
SET DFN=$ORDER(^BQICARE(DUZ,1,PLIEN,40,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+91 IF $PIECE(^BQICARE(DUZ,1,PLIEN,40,DFN,0),U,2)'=""
QUIT
+92 SET $PIECE(^BQICARE(DUZ,1,PLIEN,40,DFN,0),U,2)="A"
+93 SET $PIECE(^BQICARE(DUZ,1,PLIEN,40,DFN,0),U,4)=$$NOW^XLFDT()
End DoDot:2
End DoDot:1
+94 ;
+95 ; if user selected to copy the layout
+96 IF LYOUT
DO LAY(OWNR,OPLIEN,PLIEN)
+97 ;
+98 ; Return panel IEN, ID, and NAME on success
+99 SET PLID=$$PLID^BQIUG1(DUZ,PLIEN)
+100 SET BQII=BQII+1
SET ^TMP("BQIPLCP",UID,BQII)=PLIEN_"^"_PLID_"^"_PLNM_$CHAR(30)
+101 SET BQII=BQII+1
SET ^TMP("BQIPLCP",UID,BQII)=$CHAR(31)
+102 KILL PLID,PLNM
+103 QUIT
+104 ;
FILE ; Create name and file new panel under current DUZ
+1 LOCK +^BQICARE(DUZ,1,0):5
+2 ; NOTE: It is possible that the lock should be extended around the whole copy procedure.
+3 ; Potential problem is that the panel could become available to a shared user during
+4 ; the IX^DIK process but before the panel x-ref completes. This is a very small
+5 ; period of time, but should still be tested.
+6 ; Error - unable to assign next panel IEN
IF '$TEST
SET BMXSEC="Unable to create panel"
QUIT
+7 Begin DoDot:1
+8 ; First try to create a new name for the panel using "Copy of "_OldName.
+9 NEW DA,PIENS,ERROR,II
+10 SET PLNM=$SELECT($GET(NPLNM)'="":NPLNM,1:"Copy of "_OPLNM)
+11 SET DA(1)=DUZ
SET DA=""
+12 SET PIENS=$$IENS^DILF(.DA)
+13 ; New panel name not currently in use.
IF $$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")=0
QUIT
+14 ; Otherwise create a new name for the panel using "Copy (n) of "_OldName.
+15 FOR II=1:1
Begin DoDot:2
+16 NEW DA,PIENS,ERROR
+17 SET PLNM="Copy ("_II_") of "_OPLNM
+18 SET DA(1)=DUZ
SET DA=""
+19 SET PIENS=$$IENS^DILF(.DA)
+20 ; New panel name not currently in use.
IF $$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")=0
QUIT
+21 ; Clear panel name if currently in use
SET PLNM=""
End DoDot:2
IF PLNM]""
QUIT
+22 QUIT
End DoDot:1
+23 ; File new panel
+24 NEW DA,X,DINUM,DIC,DIE,DLAYGO
+25 SET DA(1)=DUZ
SET X=PLNM
SET DLAYGO=90505.01
+26 SET DIC="^BQICARE("_DA(1)_",1,"
SET DIE=DIC
+27 SET DIC(0)="L"
SET DIC("P")=DLAYGO
+28 KILL DO,DD
DO FILE^DICN
+29 SET (DA,PLIEN)=+Y
+30 IF PLIEN=-1
SET BMXSEC="Error encountered while filing panel."
+31 LOCK -^BQICARE(DUZ,1,0)
+32 QUIT
+33 ;
ERR ;
+1 LOCK -^BQICARE(DUZ,1,0)
+2 DO ^%ZTER
+3 NEW Y,ERRDTM
+4 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+5 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+6 QUIT
+7 ;
CPY(OWNR,OPLIEN,PLIEN) ;EP -- Copy data from one panel to another
+1 ; Input
+2 ; OWNR - Owner of panel
+3 ; OPLIEN - Original panel IEN
+4 ; PLIEN - New panel IEN
+5 ;
+6 ; Copy PANEL DEFINITION (remaining nodes)
+7 ;
+8 IF $DATA(^BQICARE(OWNR,1,OPLIEN,3))
MERGE ^BQICARE(DUZ,1,PLIEN,3)=^BQICARE(OWNR,1,OPLIEN,3)
+9 IF $DATA(^BQICARE(OWNR,1,OPLIEN,5))
MERGE ^BQICARE(DUZ,1,PLIEN,5)=^BQICARE(OWNR,1,OPLIEN,5)
+10 ;
+11 ; Copy PARAMETER DEFINITION
+12 IF $DATA(^BQICARE(OWNR,1,OPLIEN,10))
MERGE ^BQICARE(DUZ,1,PLIEN,10)=^BQICARE(OWNR,1,OPLIEN,10)
+13 ;
+14 ; Copy FILTER DEFINITION
+15 IF $DATA(^BQICARE(OWNR,1,OPLIEN,15))
MERGE ^BQICARE(DUZ,1,PLIEN,15)=^BQICARE(OWNR,1,OPLIEN,15)
+16 ;
+17 ; Copy PATIENT LIST
+18 IF $DATA(^BQICARE(OWNR,1,OPLIEN,40))
MERGE ^BQICARE(DUZ,1,PLIEN,40)=^BQICARE(OWNR,1,OPLIEN,40)
+19 ;
+20 ; Update cross references for merged entries
+21 SET DIK="^BQICARE("_DA(1)_",1,"
+22 DO IX^DIK
+23 QUIT
+24 ;
LAY(OWNR,OPLIEN,PLIEN) ;EP - Copy the layouts
+1 NEW LYI,TMPLNM,DIK,DA,TMIEN,TMTYP
+2 ;
+3 ; if the user is the owner
+4 ;
+5 IF OWNR=DUZ
Begin DoDot:1
+6 ;Template References
MERGE ^BQICARE(DUZ,1,PLIEN,4)=^BQICARE(OWNR,1,OPLIEN,4)
+7 ;Patient Layout
MERGE ^BQICARE(DUZ,1,PLIEN,20)=^BQICARE(OWNR,1,OPLIEN,20)
+8 ;Reminders
MERGE ^BQICARE(DUZ,1,PLIEN,22)=^BQICARE(OWNR,1,OPLIEN,22)
+9 ;Nat'l Meas
MERGE ^BQICARE(DUZ,1,PLIEN,25)=^BQICARE(OWNR,1,OPLIEN,25)
+10 ;Care Mgmt Layouts (Asthma and HIV/AIDS)
MERGE ^BQICARE(DUZ,1,PLIEN,23)=^BQICARE(OWNR,1,OPLIEN,23)
End DoDot:1
+11 ;
+12 ; if the user is not the owner, create customized
+13 IF OWNR'=DUZ
Begin DoDot:1
+14 MERGE ^BQICARE(DUZ,1,PLIEN,4)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,4)
+15 SET $PIECE(^BQICARE(DUZ,1,PLIEN,4,0),U,2)="90505.14"
+16 MERGE ^BQICARE(DUZ,1,PLIEN,20)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,20)
+17 SET $PIECE(^BQICARE(DUZ,1,PLIEN,20,0),U,2)="90505.05P"
+18 MERGE ^BQICARE(DUZ,1,PLIEN,22)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,22)
+19 SET $PIECE(^BQICARE(DUZ,1,PLIEN,22,0),U,2)="90505.122"
+20 MERGE ^BQICARE(DUZ,1,PLIEN,23)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,23)
+21 SET $PIECE(^BQICARE(DUZ,1,PLIEN,23,0),U,2)="90505.123"
+22 NEW I
SET I=0
FOR
SET I=$ORDER(^BQICARE(DUZ,1,PLIEN,23,I))
IF 'I
QUIT
SET $PIECE(^BQICARE(DUZ,1,PLIEN,23,I,1,0),U,2)="90505.1231"
+23 MERGE ^BQICARE(DUZ,1,PLIEN,25)=^BQICARE(OWNR,1,OPLIEN,30,DUZ,25)
+24 SET $PIECE(^BQICARE(DUZ,1,PLIEN,25,0),U,2)="90505.125"
End DoDot:1
+25 ;
+26 ; Update cross references for merged entries
+27 SET DIK="^BQICARE("
SET DA=DUZ
+28 DO IX^DIK
+29 QUIT
