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

BQIPLTP.m

Go to the documentation of this file. 
  1. BQIPLTP ;VNGT/HC/KML-Reassign Panel Functions ; 2 Feb 2006  4:05 PM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
  1.  ;
  1.  Q
  1.  ;
  1. EN(DATA,OWNR,OPLIEN,NOWNR) ; EP - BQI REASSIGN PANEL
  1.  ; Description
  1.  ;   Transfers ownership of a panel specified by OWNR and PLIEN
  1.  ;   under the New Owner.
  1.  ;
  1.  ; Input:
  1.  ;   OWNR  - Owner of the panel (DUZ)
  1.  ;   OPLIEN - Original panel IEN
  1.  ;   NOWNR  - New OWNER (DUZ)
  1.  ; Output:
  1.  ;   DATA   = name of global (passed by reference) in which the data is stored
  1.  ;
  1.  ;   PLIEN  - panel IEN (for the new panel)
  1.  ;   PLID   - panel ID (DUZ of new owner and panel ien)
  1.  ;   PLNM   - panel name (new panel name)
  1.  ; or
  1.  ;   BMXSEC - if record can't be locked or if $D(ERROR)
  1.  ;            when filing or M error encountered
  1.  ;            
  1.  N UID,X
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPLTP",UID))
  1.  K @DATA
  1.  ;
  1.  N $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLCP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  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
  1.  ;
  1.  ; Create owner (DUZ) if new to iCare - If unable to do so - error
  1.  I '$$OWNR^BQIPLUSR(DUZ) S BMXSEC="Unable to reassign panel" Q
  1.  ;
  1.  N DA,DIK,OIENS,PLNM,II
  1.  S II=0
  1.  ; Create header record
  1.  S @DATA@(II)="I00010RESULT^T00100MSG"_$C(30)
  1.  ;
  1.  S RESULT=1,MSG=""
  1.  ; Get panel name from 'original' panel
  1.  S DA=OPLIEN,DA(1)=OWNR,OIENS=$$IENS^DILF(.DA)
  1.  S PLNM=$$GET1^DIQ(90505.01,OIENS,".01","I")
  1.  I PLNM']"" S RESULT=-1,MSG="Panel Does Not Exist for Original Owner." G DONE
  1.  ;
  1.  D CREATE(OWNR,NOWNR,PLNM,OPLIEN,.PLIEN)  G DONE:$G(MSG)]""  ; create stub entry and 0 node of reassigned panel for new owner
  1.  D CPY(OWNR,NOWNR,OPLIEN,PLIEN) ; copy data from remaining subscripts
  1.  D DELPNL(OWNR,OPLIEN)  ; remove panel from previous owner
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=RESULT_U_MSG_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CREATE(ODUZ,NDUZ,PLNM,OPIEN,NPIEN) ; create stub panel entry under new owner
  1.  ; ODUZ = DUZ of the old owner
  1.  ; NDUZ = DUZ of the new owner
  1.  ; PLNM = name of panel to be reassigned
  1.  ; OPIEN  - previous panel IEN
  1.  ; NPIEN  - panel IEN for New Owner
  1.  L +^BQICARE(NDUZ,1,0):5
  1.  ; NOTE: It is possible that the lock should be extended around the whole copy procedure.
  1.  ;       Potential problem is that the panel could become available to a shared user during
  1.  ;       the IX^DIK process but before the panel x-ref completes. This is a very small
  1.  ;       period of time, but should still be tested.
  1.  I '$T S BMXSEC="Unable to create panel" Q  ; Error - unable to assign next panel IEN
  1.  N PIENS,ERROR,II
  1.  D
  1.  . ; First try to create a new name for the panel using "Copy of "_OldName.
  1.  . S DA(1)=NDUZ,DA=""
  1.  . S PIENS=$$IENS^DILF(.DA)
  1.  . Q:'$$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")  ; Reassigned panel name not currently in use by new owner.
  1.  . ; Otherwise create a new name for the panel using "Copy (n) of "_OldName.
  1.  . F II=1:1 D  I PLNM]"" Q
  1.  .. S PLNM="Reassigned Copy ("_II_") of "_PLNM
  1.  .. S PIENS=$$IENS^DILF(.DA)
  1.  .. Q:'$$FIND1^DIC(90505.01,PIENS,"X",PLNM,"","","ERROR")  ; Reassigned panel name not currently in use by new owner.
  1.  .. S PLNM="" ; Clear panel name if currently in use
  1.  . Q
  1.  ; File new panel
  1.  N X,DINUM,DIC,DIE,DLAYGO
  1.  S DA(1)=NDUZ,X=PLNM,DLAYGO=90505.01
  1.  S DIC="^BQICARE("_DA(1)_",1,",DIE=DIC
  1.  S DIC(0)="L",DIC("P")=DLAYGO
  1.  K DO,DD D FILE^DICN
  1.  S (DA,NPIEN)=+Y
  1.  I NPIEN=-1 S RESULT=-1,MSG="Error encountered while filing panel."
  1.  L -^BQICARE(NDUZ,1,0)
  1.  K DA
  1.  Q:$G(MSG)]""
  1.  ;
  1.  N BQINEW
  1.  M ^BQICARE(NDUZ,1,NPIEN,0)=^BQICARE(ODUZ,1,OPIEN,0)
  1.  ; Update panel name, creation date/time, last updated by
  1.  ; and updated date/time for 'new' panel
  1.  S DA(1)=NDUZ,DA=NPIEN,PIENS=$$IENS^DILF(.DA)
  1.  S BQINEW(90505.01,PIENS,.01)=PLNM
  1.  I $$GET1^DIQ(90505.01,PIENS,.02,"I")="" S BQINEW(90505.01,IENS,.02)=$$NOW^XLFDT()
  1.  S BQINEW(90505.01,PIENS,.04)=NDUZ
  1.  S BQINEW(90505.01,PIENS,.05)=$$NOW^XLFDT()
  1.  D FILE^DIE("","BQINEW","ERROR")
  1.  ;
  1.  ; If an error occurred, remove the half-filed panel and return BMXSEC.
  1.  I $D(ERROR) D
  1.  . S DIK="^BQICARE("_DA(1)_",1,"
  1.  . D ^DIK
  1.  . S RESULT=-1,MSG=$G(ERROR("DIERR",1,"TEXT",1))
  1.  . ;S BMXSEC="Error encountered while copying panel definition."
  1.  Q
  1.  ;
  1. CPY(ODUZ,NDUZ,OPIEN,NPIEN) ;EP -- Copy remaining panel data from previous owner to new owner
  1.  ; Input
  1.  ;   ODUZ   - DUZ of the previous owner of panel
  1.  ;   NDUZ   - DUZ of the new owner of panel
  1.  ;   OPIEN  - previous panel IEN
  1.  ;   NPIEN  - New panel IEN
  1.  ; description of nodes to be merged
  1.  ;^BQICARE(D0,1,D1,1) = panel description
  1.  ;^BQICARE(D0,1,D1,3)= panel definition node
  1.  ;^BQICARE(D0,1,D1,5)= panel definition node
  1.  ;^BQICARE(D0,1,D1,4)= Template References
  1.  ;^BQICARE(D0,1,D1,10)= parameter definition
  1.  ;^BQICARE(D0,1,D1,15)= filter defintion
  1.  ;^BQICARE(D0,1,D1,20)= patient  layout
  1.  ;^BQICARE(D0,1,D1,22)= reminders
  1.  ;^BQICARE(D0,1,D1,23)= Care Mgmt Layouts (Asthma and HIV/AIDS)
  1.  ;^BQICARE(D0,1,D1,25)= Nat'l Meas
  1.  ;^BQICARE(D0,1,D1,30)= shared users
  1.  ;^BQICARE(D0,1,D1,40)= patient list
  1.  ;
  1.  N I,DIK,DA,SUBSTR,SUB,SHRDUSR
  1.  S SHRDUSR=0
  1.  ;
  1.  ; if the new owner was a shared user on the orignal panel then move to subscripts
  1.  ; reprsenting new owner's layouts
  1.  I $D(^BQICARE("C",NDUZ,ODUZ,OPIEN,NDUZ)) S SHRDUSR=1 D
  1.  . M ^BQICARE(NDUZ,1,NPIEN,4)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,4)
  1.  . S $P(^BQICARE(NDUZ,1,NPIEN,4,0),U,2)="90505.14"
  1.  . M ^BQICARE(NDUZ,1,NPIEN,20)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,20)
  1.  . S $P(^BQICARE(DUZ,1,NPIEN,20,0),U,2)="90505.05P"
  1.  . M ^BQICARE(NDUZ,1,NPIEN,22)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,22)
  1.  . S $P(^BQICARE(NDUZ,1,NPIEN,22,0),U,2)="90505.122"
  1.  . M ^BQICARE(NDUZ,1,NPIEN,23)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,23)
  1.  . S $P(^BQICARE(NDUZ,1,NPIEN,23,0),U,2)="90505.123"
  1.  . 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"
  1.  . M ^BQICARE(NDUZ,1,NPIEN,25)=^BQICARE(ODUZ,1,OPIEN,30,NDUZ,25)
  1.  . S $P(^BQICARE(NDUZ,1,NPIEN,25,0),U,2)="90505.125"
  1.  . D DELPNL(ODUZ,OPIEN,NDUZ)  ; need to delete new owner from the shared user sub-file
  1.  ;
  1.  ;
  1.  I SHRDUSR S SUBSTR="1,3,5,10,15,30,40"   ; only merge remaining subscripts
  1.  E  S SUBSTR="1,3,4,5,10,15,20,22,23,25,30,40"  ; merge all panel subscripts
  1.  F I=1:1:$L(SUBSTR,",") S SUB=$P(SUBSTR,",",I) D
  1.  . M ^BQICARE(NDUZ,1,NPIEN,SUB)=^BQICARE(ODUZ,1,OPIEN,SUB)
  1.  ;
  1.  ; Update cross references for merged entries
  1.  S DIK="^BQICARE(",DA=NDUZ
  1.  D IX^DIK
  1.  S DA(1)=NDUZ
  1.  S DIK="^BQICARE("_DA(1)_",1,"
  1.  D IX^DIK
  1.  ;
  1.  ;  Handle "My Patient" Lists
  1.  N IENS,SRCTYP
  1.  S DA(1)=NDUZ,DA=NPIEN,IENS=$$IENS^DILF(.DA)
  1.  S SRCTYP=$$GET1^DIQ(90505.01,IENS,.03,"I")
  1.  I SRCTYP'="Y" Q
  1.  S BQIUPD(90505.01,IENS,.03)="M"
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  K DESC
  1.  D DESC^BQIPDSCM(NDUZ,NPIEN,.DESC)
  1.  ;D PEN^BQIPLDSC(NDUZ,NPIEN,.DESC)
  1.  D WP^DIE(90505.01,IENS,5,"","DESC")
  1.  K DESC
  1.  N DFN
  1.  S DFN=0
  1.  F  S DFN=$O(^BQICARE(NDUZ,1,NPIEN,40,DFN)) Q:'DFN  D
  1.  . I $P(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,2)'="" Q
  1.  . S $P(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,2)="A"
  1.  . S $P(^BQICARE(NDUZ,1,NPIEN,40,DFN,0),U,4)=$$NOW^XLFDT()
  1.  Q
  1.  ;
  1. DELPNL(ODUZ,OPIEN,NDUZ) ; EP - delete panel entry from previous owner
  1.  ;   ODUZ   - DUZ of the previous owner of panel
  1.  ;   NDUZ   - DUZ of the new owner of panel
  1.  ;   OPIEN  - previous panel IEN
  1.  S DA(1)=ODUZ,DA=OPIEN
  1.  S DIK="^BQICARE("_DA(1)_",1,"
  1.  I $G(NDUZ) D  ; delete new owner from shared panel
  1.  . S DA=NDUZ,DA(1)=OPIEN,DA(2)=ODUZ
  1.  . S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",30,"
  1.  D ^DIK
  1.  ;   
  1.  Q
  1.  ;
  1. ERR ;
  1.  L -^BQICARE(DUZ,1,0)
  1.  D ^%ZTER
  1.  N Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  Q