BQIPLTP ;VNGT/HC/KML-Reassign Panel Functions ; 2 Feb 2006 4:05 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
Q
;
EN(DATA,OWNR,OPLIEN,NOWNR) ; EP - BQI REASSIGN PANEL
; Description
; Transfers ownership of a panel specified by OWNR and PLIEN
; under the New Owner.
;
; Input:
; OWNR - Owner of the panel (DUZ)
; OPLIEN - Original panel IEN
; NOWNR - New OWNER (DUZ)
; 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
;
N UID,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLTP",UID))
K @DATA
;
N $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLCP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I '$$KEYCHK^BQIULSC("BQIZMGR",DUZ) S BMXSEC="You do not have the security access to REASSIGN a panel."_$C(10)_"Please see your supervisor or program manager." Q
;
; Create owner (DUZ) if new to iCare - If unable to do so - error
I '$$OWNR^BQIPLUSR(DUZ) S BMXSEC="Unable to reassign panel" Q
;
N DA,DIK,OIENS,PLNM,II
S II=0
; Create header record
S @DATA@(II)="I00010RESULT^T00100MSG"_$C(30)
;
S RESULT=1,MSG=""
; Get panel name from 'original' panel
S DA=OPLIEN,DA(1)=OWNR,OIENS=$$IENS^DILF(.DA)
S PLNM=$$GET1^DIQ(90505.01,OIENS,".01","I")
I PLNM']"" S RESULT=-1,MSG="Panel Does Not Exist for Original Owner." G DONE
;
D CREATE(OWNR,NOWNR,PLNM,OPLIEN,.PLIEN) G DONE:$G(MSG)]"" ; create stub entry and 0 node of reassigned panel for new owner
D CPY(OWNR,NOWNR,OPLIEN,PLIEN) ; copy data from remaining subscripts
D DELPNL(OWNR,OPLIEN) ; remove panel from previous owner
;
DONE ;
S II=II+1,@DATA@(II)=RESULT_U_MSG_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
CREATE(ODUZ,NDUZ,PLNM,OPIEN,NPIEN) ; create stub panel entry under new owner
; ODUZ = DUZ of the old owner
; NDUZ = DUZ of the new owner
; PLNM = name of panel to be reassigned
; OPIEN - previous panel IEN
; NPIEN - panel IEN for New Owner
L +^BQICARE(NDUZ,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
N PIENS,ERROR,II
D
. ; First try to create a new name for the panel using "Copy of "_OldName.
. S DA(1)=NDUZ,DA=""
. S PIENS=$$IENS^DILF(.DA)
. Q:'$$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR") ; Reassigned panel name not currently in use by new owner.
. ; Otherwise create a new name for the panel using "Copy (n) of "_OldName.
. F II=1:1 D I PLNM]"" Q
.. S PLNM="Reassigned Copy ("_II_") of "_PLNM
.. S PIENS=$$IENS^DILF(.DA)
.. Q:'$$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR") ; Reassigned panel name not currently in use by new owner.
.. S PLNM="" ; Clear panel name if currently in use
. Q
; File new panel
N X,DINUM,DIC,DIE,DLAYGO
S DA(1)=NDUZ,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,NPIEN)=+Y
I NPIEN=-1 S RESULT=-1,MSG="Error encountered while filing panel."
L -^BQICARE(NDUZ,1,0)
K DA
Q:$G(MSG)]""
;
N BQINEW
M ^BQICARE(NDUZ,1,NPIEN,0)=^BQICARE(ODUZ,1,OPIEN,0)
; Update panel name, creation date/time, last updated by
; and updated date/time for 'new' panel
S DA(1)=NDUZ,DA=NPIEN,PIENS=$$IENS^DILF(.DA)
S BQINEW(90505.01,PIENS,.01)=PLNM
I $$GET1^DIQ(90505.01,PIENS,.02,"I")="" S BQINEW(90505.01,IENS,.02)=$$NOW^XLFDT()
S BQINEW(90505.01,PIENS,.04)=NDUZ
S BQINEW(90505.01,PIENS,.05)=$$NOW^XLFDT()
D FILE^DIE("","BQINEW","ERROR")
;
; If an error occurred, remove the half-filed panel and return BMXSEC.
I $D(ERROR) D
. S DIK="^BQICARE("_DA(1)_",1,"
. D ^DIK
. S RESULT=-1,MSG=$G(ERROR("DIERR",1,"TEXT",1))
. ;S BMXSEC="Error encountered while copying panel definition."
Q
;
CPY(ODUZ,NDUZ,OPIEN,NPIEN) ;EP -- Copy remaining panel data from previous owner to new owner
; Input
; ODUZ - DUZ of the previous owner of panel
; NDUZ - DUZ of the new owner of panel
; OPIEN - previous panel IEN
; NPIEN - New panel IEN
; description of nodes to be merged
;^BQICARE(D0,1,D1,1) = panel description
;^BQICARE(D0,1,D1,3)= panel definition node
;^BQICARE(D0,1,D1,5)= panel definition node
;^BQICARE(D0,1,D1,4)= Template References
;^BQICARE(D0,1,D1,10)= parameter definition
;^BQICARE(D0,1,D1,15)= filter defintion
;^BQICARE(D0,1,D1,20)= patient layout
;^BQICARE(D0,1,D1,22)= reminders
;^BQICARE(D0,1,D1,23)= Care Mgmt Layouts (Asthma and HIV/AIDS)
;^BQICARE(D0,1,D1,25)= Nat'l Meas
;^BQICARE(D0,1,D1,30)= shared users
;^BQICARE(D0,1,D1,40)= patient list
;
N I,DIK,DA,SUBSTR,SUB,SHRDUSR
S SHRDUSR=0
;
; if the new owner was a shared user on the orignal panel then move to subscripts
; reprsenting new owner's layouts
I $D(^BQICARE("C",NDUZ,ODUZ,OPIEN,NDUZ)) S SHRDUSR=1 D
. M ^BQICARE(NDUZ,1,NPIEN,4)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,4)
. S $P(^BQICARE(NDUZ,1,NPIEN,4,0),U,2)="90505.14"
. M ^BQICARE(NDUZ,1,NPIEN,20)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,20)
. S $P(^BQICARE(DUZ,1,NPIEN,20,0),U,2)="90505.05P"
. M ^BQICARE(NDUZ,1,NPIEN,22)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,22)
. S $P(^BQICARE(NDUZ,1,NPIEN,22,0),U,2)="90505.122"
. M ^BQICARE(NDUZ,1,NPIEN,23)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,23)
. S $P(^BQICARE(NDUZ,1,NPIEN,23,0),U,2)="90505.123"
. N I S I=0 F S I=$O(^BQICARE(NDUZ,1,PLIEN,23,I)) Q:'I S $P(^BQICARE(NDUZ,1,PLIEN,23,I,1,0),U,2)="90505.1231"
. M ^BQICARE(NDUZ,1,NPIEN,25)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,25)
. S $P(^BQICARE(NDUZ,1,NPIEN,25,0),U,2)="90505.125"
. D DELPNL(ODUZ,OPIEN,NDUZ) ; need to delete new owner from the shared user sub-file
;
;
I SHRDUSR S SUBSTR="1,3,5,10,15,30,40" ; only merge remaining subscripts
E S SUBSTR="1,3,4,5,10,15,20,22,23,25,30,40" ; merge all panel subscripts
F I=1:1:$L(SUBSTR,",") S SUB=$P(SUBSTR,",",I) D
. M ^BQICARE(NDUZ,1,NPIEN,SUB)=^BQICARE(ODUZ,1,OPIEN,SUB)
;
; Update cross references for merged entries
S DIK="^BQICARE(",DA=NDUZ
D IX^DIK
S DA(1)=NDUZ
S DIK="^BQICARE("_DA(1)_",1,"
D IX^DIK
;
; Handle "My Patient" Lists
N IENS,SRCTYP
S DA(1)=NDUZ,DA=NPIEN,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(NDUZ,NPIEN,.DESC)
;D PEN^BQIPLDSC(NDUZ,NPIEN,.DESC)
D WP^DIE(90505.01,IENS,5,"","DESC")
K DESC
N DFN
S DFN=0
F S DFN=$O(^BQICARE(NDUZ,1,NPIEN,40,DFN)) Q:'DFN D
. I $P(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,2)'="" Q
. S $P(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,2)="A"
. S $P(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,4)=$$NOW^XLFDT()
Q
;
DELPNL(ODUZ,OPIEN,NDUZ) ; EP - delete panel entry from previous owner
; ODUZ - DUZ of the previous owner of panel
; NDUZ - DUZ of the new owner of panel
; OPIEN - previous panel IEN
S DA(1)=ODUZ,DA=OPIEN
S DIK="^BQICARE("_DA(1)_",1,"
I $G(NDUZ) D ; delete new owner from shared panel
. S DA=NDUZ,DA(1)=OPIEN,DA(2)=ODUZ
. S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",30,"
D ^DIK
;
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
BQIPLTP ;VNGT/HC/KML-Reassign 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,NOWNR) ; EP - BQI REASSIGN PANEL
+1 ; Description
+2 ; Transfers ownership of a panel specified by OWNR and PLIEN
+3 ; under the New Owner.
+4 ;
+5 ; Input:
+6 ; OWNR - Owner of the panel (DUZ)
+7 ; OPLIEN - Original panel IEN
+8 ; NOWNR - New OWNER (DUZ)
+9 ; Output:
+10 ; DATA = name of global (passed by reference) in which the data is stored
+11 ;
+12 ; PLIEN - panel IEN (for the new panel)
+13 ; PLID - panel ID (DUZ of new owner and panel ien)
+14 ; PLNM - panel name (new panel name)
+15 ; or
+16 ; BMXSEC - if record can't be locked or if $D(ERROR)
+17 ; when filing or M error encountered
+18 ;
+19 NEW UID,X
+20 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+21 SET DATA=$NAME(^TMP("BQIPLTP",UID))
+22 KILL @DATA
+23 ;
+24 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLCP D UNWIND^%ZTER"
+25 ;
+26 IF '$$KEYCHK^BQIULSC("BQIZMGR",DUZ)
SET BMXSEC="You do not have the security access to REASSIGN a panel."_$CHAR(10)_"Please see your supervisor or program manager."
QUIT
+27 ;
+28 ; Create owner (DUZ) if new to iCare - If unable to do so - error
+29 IF '$$OWNR^BQIPLUSR(DUZ)
SET BMXSEC="Unable to reassign panel"
QUIT
+30 ;
+31 NEW DA,DIK,OIENS,PLNM,II
+32 SET II=0
+33 ; Create header record
+34 SET @DATA@(II)="I00010RESULT^T00100MSG"_$CHAR(30)
+35 ;
+36 SET RESULT=1
SET MSG=""
+37 ; Get panel name from 'original' panel
+38 SET DA=OPLIEN
SET DA(1)=OWNR
SET OIENS=$$IENS^DILF(.DA)
+39 SET PLNM=$$GET1^DIQ(90505.01,OIENS,".01","I")
+40 IF PLNM']""
SET RESULT=-1
SET MSG="Panel Does Not Exist for Original Owner."
GOTO DONE
+41 ;
+42 ; create stub entry and 0 node of reassigned panel for new owner
DO CREATE(OWNR,NOWNR,PLNM,OPLIEN,.PLIEN)
IF $GET(MSG)]""
GOTO DONE
+43 ; copy data from remaining subscripts
DO CPY(OWNR,NOWNR,OPLIEN,PLIEN)
+44 ; remove panel from previous owner
DO DELPNL(OWNR,OPLIEN)
+45 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=RESULT_U_MSG_$CHAR(30)
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 QUIT
+4 ;
CREATE(ODUZ,NDUZ,PLNM,OPIEN,NPIEN) ; create stub panel entry under new owner
+1 ; ODUZ = DUZ of the old owner
+2 ; NDUZ = DUZ of the new owner
+3 ; PLNM = name of panel to be reassigned
+4 ; OPIEN - previous panel IEN
+5 ; NPIEN - panel IEN for New Owner
+6 LOCK +^BQICARE(NDUZ,1,0):5
+7 ; NOTE: It is possible that the lock should be extended around the whole copy procedure.
+8 ; Potential problem is that the panel could become available to a shared user during
+9 ; the IX^DIK process but before the panel x-ref completes. This is a very small
+10 ; period of time, but should still be tested.
+11 ; Error - unable to assign next panel IEN
IF '$TEST
SET BMXSEC="Unable to create panel"
QUIT
+12 NEW PIENS,ERROR,II
+13 Begin DoDot:1
+14 ; First try to create a new name for the panel using "Copy of "_OldName.
+15 SET DA(1)=NDUZ
SET DA=""
+16 SET PIENS=$$IENS^DILF(.DA)
+17 ; Reassigned panel name not currently in use by new owner.
IF '$$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")
QUIT
+18 ; Otherwise create a new name for the panel using "Copy (n) of "_OldName.
+19 FOR II=1:1
Begin DoDot:2
+20 SET PLNM="Reassigned Copy ("_II_") of "_PLNM
+21 SET PIENS=$$IENS^DILF(.DA)
+22 ; Reassigned panel name not currently in use by new owner.
IF '$$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")
QUIT
+23 ; Clear panel name if currently in use
SET PLNM=""
End DoDot:2
IF PLNM]""
QUIT
+24 QUIT
End DoDot:1
+25 ; File new panel
+26 NEW X,DINUM,DIC,DIE,DLAYGO
+27 SET DA(1)=NDUZ
SET X=PLNM
SET DLAYGO=90505.01
+28 SET DIC="^BQICARE("_DA(1)_",1,"
SET DIE=DIC
+29 SET DIC(0)="L"
SET DIC("P")=DLAYGO
+30 KILL DO,DD
DO FILE^DICN
+31 SET (DA,NPIEN)=+Y
+32 IF NPIEN=-1
SET RESULT=-1
SET MSG="Error encountered while filing panel."
+33 LOCK -^BQICARE(NDUZ,1,0)
+34 KILL DA
+35 IF $GET(MSG)]""
QUIT
+36 ;
+37 NEW BQINEW
+38 MERGE ^BQICARE(NDUZ,1,NPIEN,0)=^BQICARE(ODUZ,1,OPIEN,0)
+39 ; Update panel name, creation date/time, last updated by
+40 ; and updated date/time for 'new' panel
+41 SET DA(1)=NDUZ
SET DA=NPIEN
SET PIENS=$$IENS^DILF(.DA)
+42 SET BQINEW(90505.01,PIENS,.01)=PLNM
+43 IF $$GET1^DIQ(90505.01,PIENS,.02,"I")=""
SET BQINEW(90505.01,IENS,.02)=$$NOW^XLFDT()
+44 SET BQINEW(90505.01,PIENS,.04)=NDUZ
+45 SET BQINEW(90505.01,PIENS,.05)=$$NOW^XLFDT()
+46 DO FILE^DIE("","BQINEW","ERROR")
+47 ;
+48 ; If an error occurred, remove the half-filed panel and return BMXSEC.
+49 IF $DATA(ERROR)
Begin DoDot:1
+50 SET DIK="^BQICARE("_DA(1)_",1,"
+51 DO ^DIK
+52 SET RESULT=-1
SET MSG=$GET(ERROR("DIERR",1,"TEXT",1))
+53 ;S BMXSEC="Error encountered while copying panel definition."
End DoDot:1
+54 QUIT
+55 ;
CPY(ODUZ,NDUZ,OPIEN,NPIEN) ;EP -- Copy remaining panel data from previous owner to new owner
+1 ; Input
+2 ; ODUZ - DUZ of the previous owner of panel
+3 ; NDUZ - DUZ of the new owner of panel
+4 ; OPIEN - previous panel IEN
+5 ; NPIEN - New panel IEN
+6 ; description of nodes to be merged
+7 ;^BQICARE(D0,1,D1,1) = panel description
+8 ;^BQICARE(D0,1,D1,3)= panel definition node
+9 ;^BQICARE(D0,1,D1,5)= panel definition node
+10 ;^BQICARE(D0,1,D1,4)= Template References
+11 ;^BQICARE(D0,1,D1,10)= parameter definition
+12 ;^BQICARE(D0,1,D1,15)= filter defintion
+13 ;^BQICARE(D0,1,D1,20)= patient layout
+14 ;^BQICARE(D0,1,D1,22)= reminders
+15 ;^BQICARE(D0,1,D1,23)= Care Mgmt Layouts (Asthma and HIV/AIDS)
+16 ;^BQICARE(D0,1,D1,25)= Nat'l Meas
+17 ;^BQICARE(D0,1,D1,30)= shared users
+18 ;^BQICARE(D0,1,D1,40)= patient list
+19 ;
+20 NEW I,DIK,DA,SUBSTR,SUB,SHRDUSR
+21 SET SHRDUSR=0
+22 ;
+23 ; if the new owner was a shared user on the orignal panel then move to subscripts
+24 ; reprsenting new owner's layouts
+25 IF $DATA(^BQICARE("C",NDUZ,ODUZ,OPIEN,NDUZ))
SET SHRDUSR=1
Begin DoDot:1
+26 MERGE ^BQICARE(NDUZ,1,NPIEN,4)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,4)
+27 SET $PIECE(^BQICARE(NDUZ,1,NPIEN,4,0),U,2)="90505.14"
+28 MERGE ^BQICARE(NDUZ,1,NPIEN,20)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,20)
+29 SET $PIECE(^BQICARE(DUZ,1,NPIEN,20,0),U,2)="90505.05P"
+30 MERGE ^BQICARE(NDUZ,1,NPIEN,22)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,22)
+31 SET $PIECE(^BQICARE(NDUZ,1,NPIEN,22,0),U,2)="90505.122"
+32 MERGE ^BQICARE(NDUZ,1,NPIEN,23)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,23)
+33 SET $PIECE(^BQICARE(NDUZ,1,NPIEN,23,0),U,2)="90505.123"
+34 NEW I
SET I=0
FOR
SET I=$ORDER(^BQICARE(NDUZ,1,PLIEN,23,I))
IF 'I
QUIT
SET $PIECE(^BQICARE(NDUZ,1,PLIEN,23,I,1,0),U,2)="90505.1231"
+35 MERGE ^BQICARE(NDUZ,1,NPIEN,25)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,25)
+36 SET $PIECE(^BQICARE(NDUZ,1,NPIEN,25,0),U,2)="90505.125"
+37 ; need to delete new owner from the shared user sub-file
DO DELPNL(ODUZ,OPIEN,NDUZ)
End DoDot:1
+38 ;
+39 ;
+40 ; only merge remaining subscripts
IF SHRDUSR
SET SUBSTR="1,3,5,10,15,30,40"
+41 ; merge all panel subscripts
IF '$TEST
SET SUBSTR="1,3,4,5,10,15,20,22,23,25,30,40"
+42 FOR I=1:1:$LENGTH(SUBSTR,",")
SET SUB=$PIECE(SUBSTR,",",I)
Begin DoDot:1
+43 MERGE ^BQICARE(NDUZ,1,NPIEN,SUB)=^BQICARE(ODUZ,1,OPIEN,SUB)
End DoDot:1
+44 ;
+45 ; Update cross references for merged entries
+46 SET DIK="^BQICARE("
SET DA=NDUZ
+47 DO IX^DIK
+48 SET DA(1)=NDUZ
+49 SET DIK="^BQICARE("_DA(1)_",1,"
+50 DO IX^DIK
+51 ;
+52 ; Handle "My Patient" Lists
+53 NEW IENS,SRCTYP
+54 SET DA(1)=NDUZ
SET DA=NPIEN
SET IENS=$$IENS^DILF(.DA)
+55 SET SRCTYP=$$GET1^DIQ(90505.01,IENS,.03,"I")
+56 IF SRCTYP'="Y"
QUIT
+57 SET BQIUPD(90505.01,IENS,.03)="M"
+58 DO FILE^DIE("","BQIUPD","ERROR")
+59 KILL BQIUPD
+60 KILL DESC
+61 DO DESC^BQIPDSCM(NDUZ,NPIEN,.DESC)
+62 ;D PEN^BQIPLDSC(NDUZ,NPIEN,.DESC)
+63 DO WP^DIE(90505.01,IENS,5,"","DESC")
+64 KILL DESC
+65 NEW DFN
+66 SET DFN=0
+67 FOR
SET DFN=$ORDER(^BQICARE(NDUZ,1,NPIEN,40,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+68 IF $PIECE(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,2)'=""
QUIT
+69 SET $PIECE(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,2)="A"
+70 SET $PIECE(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,4)=$$NOW^XLFDT()
End DoDot:1
+71 QUIT
+72 ;
DELPNL(ODUZ,OPIEN,NDUZ) ; EP - delete panel entry from previous owner
+1 ; ODUZ - DUZ of the previous owner of panel
+2 ; NDUZ - DUZ of the new owner of panel
+3 ; OPIEN - previous panel IEN
+4 SET DA(1)=ODUZ
SET DA=OPIEN
+5 SET DIK="^BQICARE("_DA(1)_",1,"
+6 ; delete new owner from shared panel
IF $GET(NDUZ)
Begin DoDot:1
+7 SET DA=NDUZ
SET DA(1)=OPIEN
SET DA(2)=ODUZ
+8 SET DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",30,"
End DoDot:1
+9 DO ^DIK
+10 ;
+11 QUIT
+12 ;
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
