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

BQIRGACM.m

Go to the documentation of this file. 
  1. BQIRGACM ;HCSD/HSD/ALA-Register Columns ; 19 Feb 2016  9:08 AM
  1.  ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
  1.  ;
  1.  ;
  1. DXN(BQIDFN,SUBREG) ;EP - Diagnoses
  1.  NEW ACMIEN,VLU,TEXT
  1.  S ACMIEN=$O(^ACM(41.1,"B",SUBREG,""))
  1.  S VLU="",TEXT=""
  1.  F  S VLU=$O(^ACM(44,"AC",ACMIEN,BQIDFN,VLU)) Q:VLU=""  D
  1.  . S TEXT=TEXT_$P(^ACM(44.1,VLU,0),U,1)_$C(10)_$C(13)
  1.  Q $$TKO^BQIUL1(TEXT,$C(10)_$C(13))
  1.  ;
  1. COMP(BQIDFN,SUBREG) ; EP - Complications
  1.  NEW ACMIEN,VLU,TEXT
  1.  S ACMIEN=$O(^ACM(41.1,"B",SUBREG,""))
  1.  S VLU="",TEXT=""
  1.  F  S VLU=$O(^ACM(42,"AC",ACMIEN,BQIDFN,VLU)) Q:VLU=""  D
  1.  . S TEXT=TEXT_$P(^ACM(42.1,VLU,0),U,1)_$C(10)_$C(13)
  1.  Q $$TKO^BQIUL1(TEXT,$C(10)_$C(13))
  1.  ;
  1. ADD(DATA,NAME,DESC) ;EP -- BQI CREATE REGISTER
  1.  NEW UID,X,BQII,PLID,TMP,REGIEN,MSG
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP(UID,"BQIRGCR")) K @DATA
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGACM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ; Check that REGISTER name is unique
  1.  S BQII=0,RESULT=1,MSG="",RGIEN=""
  1.  S @DATA@(BQII)="I00010RESULT^I00010REG_IEN^T00030MSG"_$C(30)
  1.  ;
  1.  I NAME'="" D  G DONE:$G(MSG)'=""
  1.  . N DA,IENS,ERROR
  1.  . S IENS=$$IENS^DILF(.DA)
  1.  . S TMP=$$FIND1^DIC(9002241.1,"","X",NAME,"","","ERROR")
  1.  . I TMP=0 Q  ; Name not currently in use
  1.  . S MSG="Register name already exists"
  1.  . Q
  1.  ;
  1.  ; Create record
  1.  S DIC(0)="LMQZ",DLAYGO=9002241.1
  1.  S DIC="^ACM(41.1,",X=NAME
  1.  D ^DIC S DA=+Y
  1.  I DA=-1 K DO,DD D FILE^DICN S DA=+Y
  1.  I DA=-1 S MSG="Unable to create register" G DONE
  1.  S UPD(9002241.1,DA_",",1)=DT,UP(9002241.1,DA_",",3.5)=DUZ,UPD(9002241.1,DA_",",9)=DESC
  1.  S UPD(9002241.1,DA_",",5)=0,UPD(9002241.1,DA_",",6)=0,UPD(9002241.1,DA_",",7)=0
  1.  S UPD(9002241.1,DA_",",100)=1,REGIEN=DA
  1.  D FILE^DIE("","UPD","ERROR")
  1.  I '$D(^ACM(41.1,DA,"AU",0)) S ^ACM(41.1,DA,"AU",0)="^9002241.12P^^"
  1.  S (X,DINUM)=DUZ,DA(1)=DA,DIC="^ACM(41.1,"_DA(1)_",""AU"","
  1.  K DO,DD D FILE^DICN
  1.  ;
  1. DONE ; -- exit code
  1.  I $G(MSG)'="" S RESULT=-1
  1.  S BQII=BQII+1,@DATA@(BQII)=RESULT_U_$G(REGIEN)_U_MSG_$C(30)
  1.  S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  Q
  1.  ;
  1. APAT(DATA,REGIEN,PLIST) ; EP -- BQI ADD PATIENTS TO REGISTER
  1.  NEW UID,II,X,BN,LIST,BQI,DFN,RESULT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIRGAPT",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGACM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="I00010RESULT"_$C(30),RESULT=-1
  1.  I $D(PLIST)>0 D
  1.  . I $D(PLIST)>1 D
  1.  .. S LIST="",BN=""
  1.  .. F  S BN=$O(PLIST(BN)) Q:BN=""  S LIST=LIST_PLIST(BN)
  1.  .. K PLIST S PLIST=LIST
  1.  . F BQI=1:1 S DFN=$P(PLIST,$C(28),BQI) Q:DFN=""  D
  1.  .. S X=REGIEN,DIC="^ACM(41,",DIC(0)="L"
  1.  .. K DD,DO D FILE^DICN K DIC,DIE,DR,DA
  1.  .. S ACMPTNO=+Y
  1.  .. S UPD(9002241,ACMPTNO_",",.02)=DFN,UPD(9002241,ACMPTNO_",",1)="A"
  1.  .. S UPD(9002241,ACMPTNO_",",2)=DT,UPD(9002241,ACMPTNO_",",4)=DT
  1.  . D FILE^DIE("","UPD","ERROR") I '$D(ERROR) S RESULT=1
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q