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

BQIPTMRG.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. DESC ;----- ROUTINE DESCRIPTION
  1.  ;;
  1.  ;;BPMXBQI:
  1.  ;;This routine merges patient data for the following iCare files -
  1.  ;;  ICARE USER (#90505), ICARE PATIENT (#90507.5), 
  1.  ;;  ICARE DX CAT REGISTRY (#90509 - v 1.2), 
  1.  ;;  ICARE DX CAT FACTORS (#90509.5 - v 1.2)
  1.  ;;
  1.  ;;This routine is called by the special merge routine driver - ^BPMXDRV
  1.  ;;
  1.  ;;The IHS patient merge sofware enters at EN line label.  It is expected
  1.  ;;that the following global would have been set up by the patient merge
  1.  ;;software:
  1.  ;;  ^TMP("XDRFROM",$J,FROMIEN,TOIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
  1.  ;;Example:
  1.  ;;  ^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
  1.  ;;where =2 is the parent file (VA PATIENT FILE)
  1.  ;;
  1.  ;;$$END
  1.  ;
  1.  NEW I,X
  1.  F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END"  D EN^DDIOL(X)
  1.  Q
  1.  ;
  1. EN(BPMRY) ;EP -- Main entry point
  1.  ; Input parameter
  1.  ;   BPMRY  =  Temp global set up by the patient merge software,
  1.  ;             i.e., "^TMP(""XDRFROM"",$J)"
  1.  ;
  1.  NEW BPMFR,BPMTO
  1.  ;
  1.  S BPMFR=$O(@BPMRY@(0))
  1.  Q:'BPMFR
  1.  S BPMTO=$O(@BPMRY@(BPMFR,0))
  1.  Q:'BPMTO
  1.  ;
  1.  D PROC(BPMFR,BPMTO)
  1.  Q
  1.  ;
  1. PROC(BPMFR,BPMTO) ; Process patient data
  1.  ;
  1.  NEW DIK,DA,UID,BI
  1.  S UID=$J
  1.  ;Update the ICARE PATIENT File (#90507.5)
  1.  I $G(^BQIPAT(BPMTO,0))="" D
  1.  . I $P($G(^DPT(BPMTO,.35)),U,1)'="" Q
  1.  . ; Create new record
  1.  . D NPT^BQITASK(BPMTO)
  1.  . I $G(^BQIPAT(BPMFR,0))="" Q
  1.  . S $P(^BQIPAT(BPMTO,0),U,2,99)=$P(^BQIPAT(BPMFR,0),U,2,99)
  1.  . F BI=10,20,30,40,50,60 M ^BQIPAT(BPMTO,BI)=^BQIPAT(BPMFR,BI)
  1.  S DIK="^BQIPAT(",DA=BPMFR D ^DIK
  1.  ; Reindex new record
  1.  S DIK="^BQIPAT(",DA=BPMTO D EN1^DIK
  1.  ;
  1.  ;Update the ICARE USER File (#90505)
  1.  ;Check if patient exists in any panels and update them
  1.  NEW OWNR,PLIEN
  1.  S OWNR=""
  1.  F  S OWNR=$O(^BQICARE("AB",BPMFR,OWNR)) Q:OWNR=""  D
  1.  . S PLIEN=""
  1.  . F  S PLIEN=$O(^BQICARE("AB",BPMFR,OWNR,PLIEN)) Q:PLIEN=""  D
  1.  .. NEW DIC,DIE,DA,IENS,X,DATA,DINUM,DLAYGO
  1.  .. S DATA=$G(^BQICARE(OWNR,1,PLIEN,40,BPMFR,0)) I DATA="" K ^BQICARE("AB",BPMFR,OWNR,PLIEN) Q
  1.  .. ;
  1.  .. NEW DA,DIK
  1.  .. S DA(2)=OWNR,DA(1)=PLIEN,DA=BPMFR
  1.  .. ; Delete old record
  1.  .. S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",40," D ^DIK
  1.  .. ; Add new record
  1.  .. NEW DA,X,DINUM,DIC,DIE,DLAYGO,BQN
  1.  .. S DA(2)=OWNR,DA(1)=PLIEN,(X,DINUM)=BPMTO
  1.  .. S DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",40,",DIE=DIC
  1.  .. S DLAYGO=90505.04,DIC(0)="L",DIC("P")=DLAYGO
  1.  .. I '$D(^BQICARE(DA(2),1,DA(1),40,0)) S ^BQICARE(DA(2),1,DA(1),40,0)="^90505.04P^^"
  1.  .. K DO,DD D FILE^DICN
  1.  .. F BQN=2:1:$L(DATA,U) S $P(^BQICARE(OWNR,1,PLIEN,40,BPMTO,0),U,BQN)=$P(DATA,U,BQN)
  1.  .. D STA^BQIPLRF(OWNR,PLIEN)
  1.  .. D ULK^BQIPLRF(OWNR,PLIEN)
  1.  ;
  1.  ; for version 2.0 of iCare
  1.  ;Update ICARE DX CAT REGISTRY File (#90509)
  1.  I $G(^BQIREG(0))="" Q
  1.  NEW IEN,BQIUPD
  1.  S IEN=""
  1.  F  S IEN=$O(^BQIREG("AC",BPMFR,IEN)) Q:IEN=""  D
  1.  . S BQIUPD(90509,IEN_",",.02)=BPMTO
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  ;
  1.  ;Update ICARE ICARE DX CAT FACTORS File (#90509.5)
  1.  S IEN=""
  1.  F  S IEN=$O(^BQIFACT("AC",BPMFR,IEN)) Q:IEN=""  D
  1.  . S BQIUPD(90509.5,IEN_",",.02)=BPMTO
  1.  D FILE^DIE("","BQIUPD","ERROR")
  1.  K BQIUPD
  1.  ;
  1.  ; Update BKM
  1.  I $D(^BKM(90451,"B",BPMFR)) D
  1.  . S IEN=$O(^BKM(90451,"B",BPMFR,""))
  1.  . S UPD(90451,IEN_",",.01)=BPMTO
  1.  . D FILE^DIE("","UPD","ERROR")
  1.  ;
  1.  Q
  1.  ;
  1. CHK(BPMFR) ;EP - Check if FROM patient is in a panel that is opened
  1.  NEW OWNR,PLIEN,UID,ARRAY,BQIX,LOCK,LGLOB,FLAG
  1.  S OWNR="",FLAG=1,UID=$J
  1.  I $O(^BQICARE("AB",BPMFR,OWNR))="" Q 1
  1.  F  S OWNR=$O(^BQICARE("AB",BPMFR,OWNR)) Q:OWNR=""  D
  1.  . S PLIEN=""
  1.  . F  S PLIEN=$O(^BQICARE("AB",BPMFR,OWNR,PLIEN)) Q:PLIEN=""  D
  1.  .. ; Try to lock all panels containing the patient being merged
  1.  .. S LOCK=$$LCK^BQIPLRF(OWNR,PLIEN)
  1.  .. S ARRAY(OWNR,PLIEN)=LOCK
  1.  .. I 'LOCK D  Q
  1.  ... D STA^BQIPLRF(OWNR,PLIEN)
  1.  .. D STA^BQIPLRF(OWNR,PLIEN,1)
  1.  ; If any panel was unable to be locked ('1'), set the flag to 'not'
  1.  S BQIX="ARRAY" F  S BQIX=$Q(@BQIX) Q:BQIX=""  S:$P(@BQIX,U,1)=0 FLAG=0
  1.  ;
  1.  ;If a panel is found to be locked, unlock all the others that were locked
  1.  ;in the check above
  1.  I FLAG=0 D
  1.  . F  S OWNR=$O(^BQICARE("AB",BPMFR,OWNR)) Q:OWNR=""  D
  1.  .. S PLIEN=""
  1.  .. F  S PLIEN=$O(^BQICARE("AB",BPMFR,OWNR,PLIEN)) Q:PLIEN=""  D
  1.  ... D STA^BQIPLRF(OWNR,PLIEN)
  1.  ... D ULK^BQIPLRF(OWNR,PLIEN)
  1.  Q FLAG