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

BQIUTB4.m

Go to the documentation of this file. 
  1. BQIUTB4 ;GDIT/HS/ALA-Tables ; 05 Dec 2012  12:40 PM
  1.  ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
  1.  ;
  1. ACM(DATA) ;EP - ACM Registers
  1.  NEW RN
  1.  S II=0,RN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S RN=$O(^ACM(41.1,RN)) Q:'RN  D
  1.  . I $G(^ACM(41.1,RN,0))="" Q
  1.  . I $P(^ACM(41.1,RN,0),U,14)'=1 Q
  1.  . I '$D(^ACM(41.1,RN,"AU",DUZ)) Q
  1.  . S II=II+1,@DATA@(II)=RN_U_$P(^ACM(41.1,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. WARD(DATA) ;EP - Ward
  1.  NEW RN
  1.  S II=0,RN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S RN=$O(^DIC(42,RN)) Q:'RN  D
  1.  . S II=II+1,@DATA@(II)=RN_U_$P(^DIC(42,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. FSPEC(DATA) ;EP - Treating Specialty
  1.  NEW RN,N
  1.  S II=0,RN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S RN=$O(^DIC(45.7,RN)) Q:'RN  D
  1.  . I '$D(^DIC(45.7,RN,"E")) Q
  1.  . S N=0
  1.  . F  S N=$O(^DIC(45.7,RN,"E",N)) Q:'N  D
  1.  .. I $P(^DIC(45.7,RN,"E",N,0),"^",2)'=1 Q
  1.  .. S II=II+1,@DATA@(II)=RN_U_$P(^DIC(45.7,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. IATYP(DATA) ; EP - Admit Type
  1.  NEW RN
  1.  S II=0,RN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S RN=$O(^DG(405.1,RN)) Q:'RN  D
  1.  . I $$GET1^DIQ(405.1,RN_",",.02,"E")'="ADMISSION" Q
  1.  . I $P(^DG(405.1,RN,0),U,4)'=1 Q
  1.  . S II=II+1,@DATA@(II)=RN_U_$P(^DG(405.1,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. IDTYP(DATA) ; EP - Discharge type
  1.  NEW RN
  1.  S II=0,RN=0
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  F  S RN=$O(^DG(405.1,RN)) Q:'RN  D
  1.  . I $$GET1^DIQ(405.1,RN_",",.02,"E")'="DISCHARGE" Q
  1.  . I $P(^DG(405.1,RN,0),U,4)'=1 Q
  1.  . S II=II+1,@DATA@(II)=RN_U_$P(^DG(405.1,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EDTYP(DATA) ; EP - ER Disposition type
  1.  NEW RN,ETY
  1.  S II=0,RN=""
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  S ETY=$$FIND1^DIC(9009082,"","MOX","DISPOSITION","","","ERROR")
  1.  F  S RN=$O(^AMER(3,"AC",ETY,RN)) Q:RN=""  D
  1.  . S II=II+1,@DATA@(II)=RN_U_$P(^AMER(3,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EVTYP(DATA) ; EP - ER Visit type
  1.  NEW RN,ETY
  1.  S II=0,RN=""
  1.  S @DATA@(II)="T00010IEN^T00030"_$C(30)
  1.  S ETY=$$FIND1^DIC(9009082,"","MOX","VISIT TYPE","","","ERROR")
  1.  F  S RN=$O(^AMER(3,"AC",ETY,RN)) Q:RN=""  D
  1.  . S II=II+1,@DATA@(II)=RN_U_$P(^AMER(3,RN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EDACU(DATA) ;EP - ER Acuity
  1.  S II=0,@DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F I=1:1:5 S II=II+1,@DATA@(II)=I_U_"Acuity Level "_I_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PRFC(DATA) ; EP - Preferred Communication
  1.  NEW FLAG,VALUE,BJ,CODE,TEXT
  1.  S II=0
  1.  S @DATA@(II)="T00001CODE^T00030"_$C(30)
  1.  S VALUE=$P(^DD(9000001,4002,0),U,3)
  1.  F BJ=1:1:$L(VALUE,";") D
  1.  . S CODE=$P(VALUE,";",BJ) Q:CODE=""
  1.  . S TEXT=$P(CODE,":",2)
  1.  . S II=II+1,@DATA@(II)=$P(CODE,":",1)_"^"_TEXT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ETOP(DATA) ; EP - Education Topics
  1.  NEW LN,VALUE,TOP
  1.  S II=0,LN=0
  1.  S @DATA@(II)="T00030IEN^T00060"_$C(30)
  1.  F  S LN=$O(^AUTTEDMT(LN)) Q:'LN  D
  1.  . S II=II+1,@DATA@(II)=LN_U_$P(^AUTTEDMT(LN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EDUC(DATA) ;EP - Education
  1.  NEW LN
  1.  S II=0,LN=0
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  F  S LN=$O(^AUPNVPED("B",LN)) Q:LN=""  D
  1.  . I $G(^AUTTEDT(LN,0))="" Q
  1.  . I $P(^AUTTEDT(LN,0),U,3)'="" Q
  1.  . S II=II+1,@DATA@(II)=LN_U_$P(^AUTTEDT(LN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. TMFRAM(DATA,PARM) ;EP - List of timeframes by parameter
  1.  NEW LN,BZ
  1.  K BZ
  1.  S II=0,LN=""
  1.  S @DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  S II=II+1,@DATA@(II)="0^"_$C(30)
  1.  S ORD=""
  1.  F  S ORD=$O(^BQI(90506.9,"D",PARM,ORD)) Q:ORD=""  D
  1.  . S LN=$O(^BQI(90506.9,"D",PARM,ORD,""))
  1.  . S II=II+1,@DATA@(II)=LN_U_$P(^BQI(90506.9,LN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EPICK(DATA) ;EP - EHR Education Picklists
  1.  NEW RET,INP,LN
  1.  S $P(INP,U,3)=DUZ,$P(INP,U,5)=0
  1.  D GETCATS^BGOEDTPR(.RET,INP)
  1.  S II=0,@DATA@(II)="T00010IEN^T00060"_$C(30)
  1.  S LN=0
  1.  F  S LN=$O(@RET@(LN)) Q:LN=""  D
  1.  . S II=II+1,@DATA@(II)=$P(@RET@(LN),U,2)_U_$P(@RET@(LN),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  K @RET
  1.  Q
  1.  ;
  1. PKIT(DATA,PICK) ;EP - BQI GET PICKLIST ITEMS
  1.  NEW UID,II,LN,RET
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIUTB4P",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010IEN^T00030ED_ITEM"_$C(30)
  1.  D GETITEMS^BGOEDTPR(.RET,PICK)
  1.  S LN=0
  1.  F  S LN=$O(@RET@(LN)) Q:LN=""  D
  1.  . S II=II+1,@DATA@(II)=$P(@RET@(LN),U,1)_U_$P(@RET@(LN),U,2)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  K @RET
  1.  Q
  1.  ;
  1. MTIT(DATA,TOP) ;EP - BQI GET ED TOPIC ITEMS
  1.  NEW UID,II,LN,RET,ZZ,TEXT,TOPN
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIUTB4T",UID))
  1.  K @DATA,ZZ
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010IEN^T00060"_$C(30)
  1.  S TOPN=TOP,TOP=$P(^AUTTEDMT(TOPN,0),U,2)
  1.  S LN=0
  1.  F  S LN=$O(^AUTTEDT(LN)) Q:'LN  D
  1.  . S RET=$G(^AUTTEDT(LN,0))
  1.  . I RET="" Q
  1.  . I $P(RET,U,3)'="" Q
  1.  . I $P(RET,U,6)'=TOP Q
  1.  . S TEXT=$P($P(RET,U,1),"-",2,99),ZZ(TEXT)=LN
  1.  S TEXT=""
  1.  F  S TEXT=$O(ZZ(TEXT)) Q:TEXT=""  D
  1.  . S LN=ZZ(TEXT)
  1.  . S II=II+1,@DATA@(II)=LN_U_TEXT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CRM(DATA) ;EP - Care Management Layout Sources
  1.  NEW CIEN,TGIEN,RGIEN,REG,TAG,FMIEN,FORM,VIEW,REM,REPORT,KEY,PNDROP,PTDROP,MTDROP
  1.  S @DATA@(II)="I00010IEN^T00030LAYOUT^T00030FORM^T00030TAG^I00010TAG_IEN^T00030REGISTER^T00001PAT_VIEW^T00001REMINDERS^T00030REPORT^T00001PAT_DROPDOWN^T00001PAN_DROPDOWN^T00001MAT_DROPDOWN"_$C(30)
  1.  S CIEN=0
  1.  F  S CIEN=$O(^BQI(90506.5,CIEN)) Q:'CIEN  D
  1.  . NEW TGIEN,RGIEN,REG,TAG,FMIEN,FORM,VIEW,REM,REPORT,KEY,PNDROP,PTDROP
  1.  . I $P(^BQI(90506.5,CIEN,0),U,4)'=1 Q
  1.  . I $P(^BQI(90506.5,CIEN,0),U,10)=1 Q
  1.  . S KEY=$P(^BQI(90506.5,CIEN,0),U,12)
  1.  . I KEY'="",'$$KEYCHK^BQIULSC(KEY,DUZ) Q
  1.  . S RGIEN=$P(^BQI(90506.5,CIEN,0),U,3)
  1.  . I RGIEN'="" S REG=$$GET1^DIQ(90507,RGIEN_",",.01,"E")
  1.  . I RGIEN'="" S TGIEN=$O(^BQI(90506.2,"AD",RGIEN,""))
  1.  . I $G(TGIEN)'="" S TAG=$$GET1^DIQ(90506.2,TGIEN_",",.01,"E")
  1.  . I $G(TAG)="" S TAG=$$GET1^DIQ(90506.5,CIEN_",",.11,"E"),TGIEN=$$GET1^DIQ(90506.5,CIEN_",",.11,"I")
  1.  . S FMIEN=$O(^BQI(90506.3,"AC",CIEN,""))
  1.  . I FMIEN'="",$P(^BQI(90506.3,FMIEN,0),U,3)'=1 S FORM=$$GET1^DIQ(90506.3,FMIEN_",",.01,"E")
  1.  . ;S VIEW=$S($P(^BQI(90506.5,CIEN,0),U,7)'="":"Y",1:"N")
  1.  . S REM=$S($P(^BQI(90506.5,CIEN,0),U,5)'="":"Y",1:"N")
  1.  . S REPORT=$P(^BQI(90506.5,CIEN,0),U,8)
  1.  . S VIEW=$S($G(FORM)'="":"F",$G(REPORT)'="":"R",1:"")
  1.  . I $G(REG)="" S REG=$P(^BQI(90506.5,CIEN,0),U,1)
  1.  . S PTDROP=$S($P(^BQI(90506.5,CIEN,0),U,13)'="":"Y",1:"")
  1.  . S PNDROP=$S($P(^BQI(90506.5,CIEN,0),U,14)'="":"Y",1:"")
  1.  . S MTDROP=$S($P(^BQI(90506.5,CIEN,0),U,15)'="":"Y",1:"")
  1.  . ;
  1.  . S II=II+1,@DATA@(II)=CIEN_U_$P(^BQI(90506.5,CIEN,0),U,1)_U_$G(FORM)_U_$G(TAG)_U_$G(TGIEN)_U_$G(REG)_U_$G(VIEW)_U_$G(REM)_U_$G(REPORT)_U_$G(PTDROP)_U_$G(PNDROP)_U_$G(MTDROP)_$C(30)
  1.  . K REG,TGIEN,TAG,FMIEN,FORM,VIEW,RGIEN
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q