BQIUTB ;PRXM/HC/ALA-Table utilities ; 02 Nov 2005 2:52 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
Q
;
TBL(DATA,FILE,INAC) ;EP - Generic table retrieve function
;
;Description
; Return the values in a table
;Input
; FILE - FileMan file number where table resides
; INAC - If file has an inactive field to check, contains
; the node and piece in 'NODE;PIECE' format
;
NEW GLBREF,IEN,LENGTH,TEST1,DLEN,PEC,NODE,X,TXT
S INAC=$G(INAC,"")
;
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I '$$VFILE^DILFD(FILE) S BMXSEC="Table doesn't exist in RPMS" Q
;
S GLBREF=$$ROOT^DILFD(FILE,"",1)
S LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S @DATA@(II)="I00010IEN^T"_DLEN_$C(30)
;
I INAC'="" S NODE=$P(INAC,";",1),PEC=$P(INAC,";",2)
S IEN=0
F S IEN=$O(@GLBREF@(IEN)) Q:'IEN D
. I $G(@GLBREF@(IEN,0))="" Q
. I INAC'="",$P($G(@GLBREF@(IEN,NODE)),"^",PEC)'="" Q
. S TXT=$$GET1^DIQ(FILE,IEN_",",.01,"E")
. I FILE=90360.3 D
.. S TXT=$$LOWER^VALM1(TXT)
.. I $P(TXT," ",1)="Hiv" D
... S TXT="HIV "_$P(TXT," ",2,99)
.. I $P(TXT," ",1)="Ob" D
... S TXT="OB "_$P(TXT," ",2,99)
. S II=II+1,@DATA@(II)=IEN_"^"_TXT_$C(30)
;
DONE S II=II+1,@DATA@(II)=$C(31)
Q
;
TAB(DATA,TEXT) ; PEP -- BQI GET TABLE
;
;Description
; Get the values of a table, including the internal entry
; number and the text
;Input
; TEXT - Value from parameter definition
;
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITABLE",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I TEXT="DETAIL" D DET^BQIUTB3(.DATA)
;
I TEXT="MUTAB" D MUT^BQIUTB2(.DATA)
;
I TEXT["RANGE" D TMFRAM^BQIUTB4(.DATA,TEXT)
I TEXT="PTMFRAME" D TMFRAM^BQIUTB4(.DATA,TEXT)
I TEXT="PSTMFRAM" D TMFRAM^BQIUTB4(.DATA,TEXT)
;
I TEXT="ETOP" D ETOP^BQIUTB4(.DATA)
I TEXT="EDUC" D EDUC^BQIUTB4(.DATA)
I TEXT="EPICK" D EPICK^BQIUTB4(.DATA)
;
I TEXT="PROV" D USR^BQIUTB5(.DATA,"P")
I TEXT="MPROV" D PRCL^BQIUTB5(.DATA)
I TEXT="DPCP" D DPCP^BQIUTB2(.DATA)
;
I TEXT="COMM" D COMM(.DATA,9999999.05,0)
I TEXT="COMMALL" D COMM(.DATA,9999999.05,1)
;
I TEXT="CLIN" D CLIN^BQIUTB2(.DATA)
;
I TEXT="SPEC" D TBL(.DATA,90360.3,"")
;
I TEXT="HLOC" D LOC^BQIUTB5(.DATA,1)
I TEXT="HLOCALL" D LOC^BQIUTB5(.DATA,1)
;
I TEXT="USER" D USR^BQIUTB5(.DATA,"")
;
I TEXT="IUSER" D IUSR^BQIUTB1(.DATA,"I")
;
I TEXT="EUSER" D IUSR^BQIUTB1(.DATA,"E")
;
I TEXT="REG" D REG(.DATA)
;
I TEXT="ILOC" D TBL(.DATA,9999999.06,"0;21")
;
I TEXT="TEAM" D TBL(.DATA,9009017.5,"0;3")
;
I TEXT="CMT" D CMT(.DATA)
;
I TEXT="TSTAT" D TSTA(.DATA)
;
I TEXT="IPCAT" D IPCAT^BQIUTB2(.DATA)
;
I TEXT="DIAG" D TBL(.DATA,80,"0;11")
I TEXT="POV" D DXN^BQIUTB3(.DATA)
I TEXT="POVS" D POVS^BQIUTB3(.DATA)
;
I TEXT="RACE" D TBL(.DATA,10,".02;1")
I TEXT="ETHN" D TBL(.DATA,10.2,".02;1")
I TEXT="LANG" D LANG^BQIUTB3(.DATA)
I TEXT="PCOMM" D PRFC^BQIUTB4(.DATA)
I TEXT="SEX" D SEX(.DATA)
;
I TEXT="PCAT" D TBL(.DATA,90360.3,"")
;
I TEXT="VIEW" D VW(.DATA)
;
I TEXT="DXCAT" D DCT(.DATA)
;
I TEXT="VFILE" D VFL^BQIUTB2(.DATA,"V")
;
I TEXT="VOTHER" D VFL^BQIUTB2(.DATA,"O")
;
I TEXT="APSTAT" D APST^BQIUTB2(.DATA)
I TEXT="PRSTAT" D PRST^BQIUTB2(.DATA)
;
I TEXT="LAB" D LAB^BQIUTB3(.DATA)
I TEXT="LABR" D LABR^BQIUTB3(.DATA)
;
I TEXT="MED" D MED^BQIUTB3(.DATA)
I TEXT="CPT" D CPT^BQIUTB3(.DATA)
;
I TEXT="PROB" D PROB^BQIUTB3(.DATA)
I TEXT="PROBS" D PROBS^BQIUTB3(.DATA)
;
I TEXT="COMMTX" D COMMTX(.DATA)
;
I TEXT="TABS" D TBS(.DATA)
;
I TEXT="BEN" D BEN(.DATA)
;
I TEXT="CARE" D CRM^BQIUTB4(.DATA)
;
I TEXT="REM" D REM(.DATA)
;
I TEXT="PERS" D EPLIST^BQIUTB2(.DATA)
;
I TEXT="FILTER" D FLTR^BQIUTB2(.DATA)
;
I TEXT="ALLERGIES" D ALG^BQIUTB3(.DATA)
;
I TEXT="UCLASS" D UCL^BQIUTB2(.DATA)
;
I TEXT="FH80" D FH80^BQIUTB5(.DATA)
;
I TEXT="FH9999999.36" D FHREL^BQIUTB5(.DATA)
;
I TEXT="EMPL" D EMP^BQIUTB3(.DATA)
;
I TEXT="DIV" D DIV^BQIUTB3(.DATA)
;
I TEXT="ACM" D ACM^BQIUTB4(.DATA)
;
I TEXT="MEAS" D MEAS^BQIUTB6(.DATA)
;
I TEXT="WARD" D WARD^BQIUTB4(.DATA)
I TEXT="FSPEC" D FSPEC^BQIUTB4(.DATA)
I TEXT="IATYPE" D IATYP^BQIUTB4(.DATA)
I TEXT="IDTYPE" D IDTYP^BQIUTB4(.DATA)
;
I TEXT="EDTYPE" D EDTYP^BQIUTB4(.DATA)
I TEXT="EVTYPE" D EVTYP^BQIUTB4(.DATA)
I TEXT="EDACU" D EDACU^BQIUTB4(.DATA)
;
I TEXT="COD" D COD^BQIUTB3(.DATA)
;
K TEXT
Q
;
CLS(PR) ; Get user classification
S USN="",TYPE=""
F S USN=$O(^USR(8930.3,"B",PR,USN),-1) Q:USN="" D
. I '$$CURRENT^USRLM(USN) Q
. S TYPE=$P(^USR(8930.3,USN,0),U,2)
. I TYPE'="" S TYPE=$S($P($G(^USR(8930,TYPE,0)),U,4)'="":$P($G(^USR(8930,TYPE,0)),U,4),1:$P($G(^USR(8930,TYPE,0)),U,1))
Q TYPE
;
CMT(DATA) ;EP - Get the table of comments that users can select from
NEW FLAG
S II=0
S @DATA@(II)="I00010IEN^T00030^T00001FLAG^T00010ASSOC_STATUS^T00001DISPLAY_ORDER"_$C(30)
S IEN=0
F S IEN=$O(^BQI(90509.1,IEN)) Q:'IEN D
. I $P(^BQI(90509.1,IEN,0),U,2)=1 Q
. S FLAG=$S($P(^BQI(90509.1,IEN,0),U,3)=1:"Y",1:"N")
. S II=II+1,@DATA@(II)=IEN_"^"_$$GET1^DIQ(90509.1,IEN_",",.01,"E")_"^"_FLAG_"^"_$$GET1^DIQ(90509.1,IEN_",",.04,"E")_"^"_$$GET1^DIQ(90509.1,IEN_",",.05,"E")_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
TSTA(DATA) ;EP - Get the table of tag statuses
NEW FLAG,VALUE,BJ,CODE,TEXT
S II=0
S @DATA@(II)="T00001CODE^T00030^T00001FLAG"_$C(30)
S VALUE=$P(^DD(90509,.03,0),U,3)
F BJ=1:1:$L(VALUE,";") D
. S CODE=$P(VALUE,";",BJ) Q:CODE=""
. S TEXT=$P(CODE,":",2)
. S II=II+1,@DATA@(II)=$P(CODE,":",1)_"^"_TEXT_"^"_$S(BJ<4:"Y",1:"N")_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
SEX(DATA) ;EP - Get a list of sexes
NEW FLAG,VALUE,BJ,CODE,TEXT
S II=0
S @DATA@(II)="T00001CODE^T00030"_$C(30)
S VALUE=$P(^DD(2,.02,0),U,3)
F BJ=1:1:$L(VALUE,";") D
. S CODE=$P(VALUE,";",BJ) Q:CODE=""
. S TEXT=$P(CODE,":",2)
. S II=II+1,@DATA@(II)=$P(CODE,":",1)_"^"_TEXT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
TBS(DATA) ;EP - Get a list of GUI tabs
NEW ORD,IEN,SEL
S II=0
S @DATA@(II)="I00010IEN^T00030TAB_NAME^T00030TAB_KEY^T00015TAB_TYPE^T00003DESELECT"_$C(30)
S ORD=""
F S ORD=$O(^BQI(90506.4,"AC",ORD)) Q:ORD="" D
. S IEN=$O(^BQI(90506.4,"AC",ORD,"")) Q:'$D(^BQI(90506.4,IEN,0))
. I $P(^BQI(90506.4,IEN,0),U,4)=1 Q
. S SEL=$P(^BQI(90506.4,IEN,0),U,7),SEL=$S(SEL=1:"NO",1:"YES")
. S II=II+1,@DATA@(II)=IEN_U_$P(^BQI(90506.4,IEN,0),U,6)_U_$P(^(0),U,2)_U_$$GET1^DIQ(90506.4,IEN_",",.03,"E")_U_SEL_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
VW(DATA) ;EP - Get the table of customized views
NEW BQILOC,LII
D EN^BQIMSLST(.BQILOC,"D")
S LII=$O(@BQILOC@(""),-1)
F II=0:1:LII-1 S @DATA@(II)=@BQILOC@(II)
S II=II+1,@DATA@(II)=$C(31)
K @BQILOC
Q
;
DCT(DATA) ;EP - Get the table of diagnoses categories
S II=0
S @DATA@(II)="I00010IEN^T00031^I00010FILE_DEFN_IEN"_$C(30)
NEW IEN,IACT,REG,REGFL,REGIEN
S IEN=0
F S IEN=$O(^BQI(90506.2,IEN)) Q:'IEN D
. I $$GET1^DIQ(90506.2,IEN_",",.05,"I") Q
. S II=II+1,REGIEN=""
. S IACT=$$GET1^DIQ(90506.2,IEN_",",.03,"I")
. S NAME=$$GET1^DIQ(90506.2,IEN_",",.01,"E")
. ; Return ien for file 90506.3 based on associated register ien
. S REG=$$GET1^DIQ(90506.2,IEN_",",.08,"I")
. I REG'="" D
.. S REGFL=$$GET1^DIQ(90507,REG_",",.02,"I")
.. I REGFL'="" S REGIEN=$O(^BQI(90506.3,"C",REGFL,""))
. S @DATA@(II)=IEN_"^"_$S(IACT=1:"*",1:"")_NAME_"^"_REGIEN_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
REG(DATA) ;EP - Get the table of registers
NEW II,IEN,NAME,SREG,RLTD,STAT
S II=0
S @DATA@(II)="I00010REG_IEN^T00030REG_NAME^T00001SUB_REG^T00030RELATED_TO^T00001STATUS"_$C(30)
S IEN=0
F S IEN=$O(^BQI(90507,IEN)) Q:'IEN D
. ; If the register is not active, quit
. I $$GET1^DIQ(90507,IEN_",",.08,"I") Q
. S NAME=$$GET1^DIQ(90507,IEN_",",.01,"E")
. S SREG=$$GET1^DIQ(90507,IEN_",",.11,"I")
. S RLTD=$$GET1^DIQ(90507,IEN_",",.17,"I")
. S STAT=$$GET1^DIQ(90507,IEN_",",.14,"E")
. S STAT=$S(STAT="":"N",1:"Y")
. S II=II+1,@DATA@(II)=IEN_"^"_NAME_"^"_SREG_"^"_RLTD_"^"_STAT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
COMM(DATA,FILE,FLAG) ;EP - Get the Community Table
NEW CIEN
S II=0
S @DATA@(II)="I00010IEN^T00050^T00005COUNT"_$C(30)
;
I $O(^XTMP("BQICOMM",0))="" D COMM^BQINIGH1
S CIEN=0
F S CIEN=$O(^XTMP("BQICOMM",CIEN)) Q:'CIEN D
. I 'FLAG,$P(^XTMP("BQICOMM",CIEN),U,3)=0 Q
. S II=II+1,@DATA@(II)=^XTMP("BQICOMM",CIEN)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
COMMTX(DATA) ;EP - Get list of Community Taxonomies
N TAXIEN,TYPE,COM,ITEM,OK,COMTXNM
S TAXIEN=0
S @DATA@(II)="I00010IEN^T00050COMM_TAX_NAME"_$C(30)
F S TAXIEN=$O(^ATXAX(TAXIEN)) Q:'TAXIEN D
. S TYPE=$P($G(^ATXAX(TAXIEN,0)),"^",15) Q:TYPE'=9999999.05
. S ITEM=0,OK=0
. F S ITEM=$O(^ATXAX(TAXIEN,21,ITEM)) Q:'ITEM D Q:OK
.. S COM=$P(^ATXAX(TAXIEN,21,ITEM,0),U) Q:COM=""
.. I '$D(^AUTTCOM("B",COM)) Q
.. S COMTXNM=$$GET1^DIQ(9002226,TAXIEN,.01,"I"),OK=1
.. S II=II+1,@DATA@(II)=TAXIEN_"^"_COMTXNM_$C(30)
.. D UPD^BQITAXX4(COMTXNM,"","CM",7)
S II=II+1,@DATA@(II)=$C(31)
Q
;
BEN(DATA) ;EP - Get list of Beneficiary Codes
N BENIEN,NAME,CODE
S BENIEN=0
S @DATA@(II)="I00010IEN^T00050"_$C(30)
F S BENIEN=$O(^AUTTBEN(BENIEN)) Q:'BENIEN D
. I '$D(^AUTTBEN(BENIEN,0)) Q
. S NAME=$P(^AUTTBEN(BENIEN,0),"^")
. S II=II+1,@DATA@(II)=BENIEN_"^"_NAME_$C(30) ;_"^"_CODE_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
REM(DATA) ;EP - Reminders
NEW RM,CODE,NAME
S RM=""
S @DATA@(II)="T00010IEN^T00050"_$C(30)
F S RM=$O(^BQI(90506.1,"AC","R",RM)) Q:RM="" D
. I $P(^BQI(90506.1,RM,0),"^",10)'="" Q
. S CODE=$P(^BQI(90506.1,RM,0),"^",1),NAME=$P(^BQI(90506.1,RM,0),"^",3)
. I $P(CODE,"_",1)="AUTTIMM" Q
. I $P(CODE,"_",1)'="EHR",$P(CODE,"_",1)'="REG",$P(CODE,"_",1)'="CMET",$P(CODE,"_",1)'="IZ" S NAME=NAME_" (HS)"
. I $P(CODE,"_",1)="EHR" S NAME=NAME_" (EHR)"
. I $P(CODE,"_",1)="REG" S NAME=NAME_" (HMS)"
. I $P(CODE,"_",1)="CMET" S NAME=NAME_" (CMET)"
. I $P(CODE,"_",1)="IZ" S NAME=NAME_" (IZ)"
. S II=II+1,@DATA@(II)=CODE_"^"_NAME_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
BQIUTB ;PRXM/HC/ALA-Table utilities ; 02 Nov 2005 2:52 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
+3 QUIT
+4 ;
TBL(DATA,FILE,INAC) ;EP - Generic table retrieve function
+1 ;
+2 ;Description
+3 ; Return the values in a table
+4 ;Input
+5 ; FILE - FileMan file number where table resides
+6 ; INAC - If file has an inactive field to check, contains
+7 ; the node and piece in 'NODE;PIECE' format
+8 ;
+9 NEW GLBREF,IEN,LENGTH,TEST1,DLEN,PEC,NODE,X,TXT
+10 SET INAC=$GET(INAC,"")
+11 ;
+12 SET II=0
+13 ;
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIUTB D UNWIND^%ZTER"
+15 ;
+16 IF '$$VFILE^DILFD(FILE)
SET BMXSEC="Table doesn't exist in RPMS"
QUIT
+17 ;
+18 SET GLBREF=$$ROOT^DILFD(FILE,"",1)
+19 SET LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
+20 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+21 SET @DATA@(II)="I00010IEN^T"_DLEN_$CHAR(30)
+22 ;
+23 IF INAC'=""
SET NODE=$PIECE(INAC,";",1)
SET PEC=$PIECE(INAC,";",2)
+24 SET IEN=0
+25 FOR
SET IEN=$ORDER(@GLBREF@(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+26 IF $GET(@GLBREF@(IEN,0))=""
QUIT
+27 IF INAC'=""
IF $PIECE($GET(@GLBREF@(IEN,NODE)),"^",PEC)'=""
QUIT
+28 SET TXT=$$GET1^DIQ(FILE,IEN_",",.01,"E")
+29 IF FILE=90360.3
Begin DoDot:2
+30 SET TXT=$$LOWER^VALM1(TXT)
+31 IF $PIECE(TXT," ",1)="Hiv"
Begin DoDot:3
+32 SET TXT="HIV "_$PIECE(TXT," ",2,99)
End DoDot:3
+33 IF $PIECE(TXT," ",1)="Ob"
Begin DoDot:3
+34 SET TXT="OB "_$PIECE(TXT," ",2,99)
End DoDot:3
End DoDot:2
+35 SET II=II+1
SET @DATA@(II)=IEN_"^"_TXT_$CHAR(30)
End DoDot:1
+36 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
TAB(DATA,TEXT) ; PEP -- BQI GET TABLE
+1 ;
+2 ;Description
+3 ; Get the values of a table, including the internal entry
+4 ; number and the text
+5 ;Input
+6 ; TEXT - Value from parameter definition
+7 ;
+8 NEW UID,II,X
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQITABLE",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIUTB D UNWIND^%ZTER"
+16 ;
+17 IF TEXT="DETAIL"
DO DET^BQIUTB3(.DATA)
+18 ;
+19 IF TEXT="MUTAB"
DO MUT^BQIUTB2(.DATA)
+20 ;
+21 IF TEXT["RANGE"
DO TMFRAM^BQIUTB4(.DATA,TEXT)
+22 IF TEXT="PTMFRAME"
DO TMFRAM^BQIUTB4(.DATA,TEXT)
+23 IF TEXT="PSTMFRAM"
DO TMFRAM^BQIUTB4(.DATA,TEXT)
+24 ;
+25 IF TEXT="ETOP"
DO ETOP^BQIUTB4(.DATA)
+26 IF TEXT="EDUC"
DO EDUC^BQIUTB4(.DATA)
+27 IF TEXT="EPICK"
DO EPICK^BQIUTB4(.DATA)
+28 ;
+29 IF TEXT="PROV"
DO USR^BQIUTB5(.DATA,"P")
+30 IF TEXT="MPROV"
DO PRCL^BQIUTB5(.DATA)
+31 IF TEXT="DPCP"
DO DPCP^BQIUTB2(.DATA)
+32 ;
+33 IF TEXT="COMM"
DO COMM(.DATA,9999999.05,0)
+34 IF TEXT="COMMALL"
DO COMM(.DATA,9999999.05,1)
+35 ;
+36 IF TEXT="CLIN"
DO CLIN^BQIUTB2(.DATA)
+37 ;
+38 IF TEXT="SPEC"
DO TBL(.DATA,90360.3,"")
+39 ;
+40 IF TEXT="HLOC"
DO LOC^BQIUTB5(.DATA,1)
+41 IF TEXT="HLOCALL"
DO LOC^BQIUTB5(.DATA,1)
+42 ;
+43 IF TEXT="USER"
DO USR^BQIUTB5(.DATA,"")
+44 ;
+45 IF TEXT="IUSER"
DO IUSR^BQIUTB1(.DATA,"I")
+46 ;
+47 IF TEXT="EUSER"
DO IUSR^BQIUTB1(.DATA,"E")
+48 ;
+49 IF TEXT="REG"
DO REG(.DATA)
+50 ;
+51 IF TEXT="ILOC"
DO TBL(.DATA,9999999.06,"0;21")
+52 ;
+53 IF TEXT="TEAM"
DO TBL(.DATA,9009017.5,"0;3")
+54 ;
+55 IF TEXT="CMT"
DO CMT(.DATA)
+56 ;
+57 IF TEXT="TSTAT"
DO TSTA(.DATA)
+58 ;
+59 IF TEXT="IPCAT"
DO IPCAT^BQIUTB2(.DATA)
+60 ;
+61 IF TEXT="DIAG"
DO TBL(.DATA,80,"0;11")
+62 IF TEXT="POV"
DO DXN^BQIUTB3(.DATA)
+63 IF TEXT="POVS"
DO POVS^BQIUTB3(.DATA)
+64 ;
+65 IF TEXT="RACE"
DO TBL(.DATA,10,".02;1")
+66 IF TEXT="ETHN"
DO TBL(.DATA,10.2,".02;1")
+67 IF TEXT="LANG"
DO LANG^BQIUTB3(.DATA)
+68 IF TEXT="PCOMM"
DO PRFC^BQIUTB4(.DATA)
+69 IF TEXT="SEX"
DO SEX(.DATA)
+70 ;
+71 IF TEXT="PCAT"
DO TBL(.DATA,90360.3,"")
+72 ;
+73 IF TEXT="VIEW"
DO VW(.DATA)
+74 ;
+75 IF TEXT="DXCAT"
DO DCT(.DATA)
+76 ;
+77 IF TEXT="VFILE"
DO VFL^BQIUTB2(.DATA,"V")
+78 ;
+79 IF TEXT="VOTHER"
DO VFL^BQIUTB2(.DATA,"O")
+80 ;
+81 IF TEXT="APSTAT"
DO APST^BQIUTB2(.DATA)
+82 IF TEXT="PRSTAT"
DO PRST^BQIUTB2(.DATA)
+83 ;
+84 IF TEXT="LAB"
DO LAB^BQIUTB3(.DATA)
+85 IF TEXT="LABR"
DO LABR^BQIUTB3(.DATA)
+86 ;
+87 IF TEXT="MED"
DO MED^BQIUTB3(.DATA)
+88 IF TEXT="CPT"
DO CPT^BQIUTB3(.DATA)
+89 ;
+90 IF TEXT="PROB"
DO PROB^BQIUTB3(.DATA)
+91 IF TEXT="PROBS"
DO PROBS^BQIUTB3(.DATA)
+92 ;
+93 IF TEXT="COMMTX"
DO COMMTX(.DATA)
+94 ;
+95 IF TEXT="TABS"
DO TBS(.DATA)
+96 ;
+97 IF TEXT="BEN"
DO BEN(.DATA)
+98 ;
+99 IF TEXT="CARE"
DO CRM^BQIUTB4(.DATA)
+100 ;
+101 IF TEXT="REM"
DO REM(.DATA)
+102 ;
+103 IF TEXT="PERS"
DO EPLIST^BQIUTB2(.DATA)
+104 ;
+105 IF TEXT="FILTER"
DO FLTR^BQIUTB2(.DATA)
+106 ;
+107 IF TEXT="ALLERGIES"
DO ALG^BQIUTB3(.DATA)
+108 ;
+109 IF TEXT="UCLASS"
DO UCL^BQIUTB2(.DATA)
+110 ;
+111 IF TEXT="FH80"
DO FH80^BQIUTB5(.DATA)
+112 ;
+113 IF TEXT="FH9999999.36"
DO FHREL^BQIUTB5(.DATA)
+114 ;
+115 IF TEXT="EMPL"
DO EMP^BQIUTB3(.DATA)
+116 ;
+117 IF TEXT="DIV"
DO DIV^BQIUTB3(.DATA)
+118 ;
+119 IF TEXT="ACM"
DO ACM^BQIUTB4(.DATA)
+120 ;
+121 IF TEXT="MEAS"
DO MEAS^BQIUTB6(.DATA)
+122 ;
+123 IF TEXT="WARD"
DO WARD^BQIUTB4(.DATA)
+124 IF TEXT="FSPEC"
DO FSPEC^BQIUTB4(.DATA)
+125 IF TEXT="IATYPE"
DO IATYP^BQIUTB4(.DATA)
+126 IF TEXT="IDTYPE"
DO IDTYP^BQIUTB4(.DATA)
+127 ;
+128 IF TEXT="EDTYPE"
DO EDTYP^BQIUTB4(.DATA)
+129 IF TEXT="EVTYPE"
DO EVTYP^BQIUTB4(.DATA)
+130 IF TEXT="EDACU"
DO EDACU^BQIUTB4(.DATA)
+131 ;
+132 IF TEXT="COD"
DO COD^BQIUTB3(.DATA)
+133 ;
+134 KILL TEXT
+135 QUIT
+136 ;
CLS(PR) ; Get user classification
+1 SET USN=""
SET TYPE=""
+2 FOR
SET USN=$ORDER(^USR(8930.3,"B",PR,USN),-1)
IF USN=""
QUIT
Begin DoDot:1
+3 IF '$$CURRENT^USRLM(USN)
QUIT
+4 SET TYPE=$PIECE(^USR(8930.3,USN,0),U,2)
+5 IF TYPE'=""
SET TYPE=$SELECT($PIECE($GET(^USR(8930,TYPE,0)),U,4)'="":$PIECE($GET(^USR(8930,TYPE,0)),U,4),1:$PIECE($GET(^USR(8930,TYPE,0)),U,1))
End DoDot:1
+6 QUIT TYPE
+7 ;
CMT(DATA) ;EP - Get the table of comments that users can select from
+1 NEW FLAG
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00030^T00001FLAG^T00010ASSOC_STATUS^T00001DISPLAY_ORDER"_$CHAR(30)
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^BQI(90509.1,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 IF $PIECE(^BQI(90509.1,IEN,0),U,2)=1
QUIT
+7 SET FLAG=$SELECT($PIECE(^BQI(90509.1,IEN,0),U,3)=1:"Y",1:"N")
+8 SET II=II+1
SET @DATA@(II)=IEN_"^"_$$GET1^DIQ(90509.1,IEN_",",.01,"E")_"^"_FLAG_"^"_$$GET1^DIQ(90509.1,IEN_",",.04,"E")_"^"_$$GET1^DIQ(90509.1,IEN_",",.05,"E")_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
TSTA(DATA) ;EP - Get the table of tag statuses
+1 NEW FLAG,VALUE,BJ,CODE,TEXT
+2 SET II=0
+3 SET @DATA@(II)="T00001CODE^T00030^T00001FLAG"_$CHAR(30)
+4 SET VALUE=$PIECE(^DD(90509,.03,0),U,3)
+5 FOR BJ=1:1:$LENGTH(VALUE,";")
Begin DoDot:1
+6 SET CODE=$PIECE(VALUE,";",BJ)
IF CODE=""
QUIT
+7 SET TEXT=$PIECE(CODE,":",2)
+8 SET II=II+1
SET @DATA@(II)=$PIECE(CODE,":",1)_"^"_TEXT_"^"_$SELECT(BJ<4:"Y",1:"N")_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
SEX(DATA) ;EP - Get a list of sexes
+1 NEW FLAG,VALUE,BJ,CODE,TEXT
+2 SET II=0
+3 SET @DATA@(II)="T00001CODE^T00030"_$CHAR(30)
+4 SET VALUE=$PIECE(^DD(2,.02,0),U,3)
+5 FOR BJ=1:1:$LENGTH(VALUE,";")
Begin DoDot:1
+6 SET CODE=$PIECE(VALUE,";",BJ)
IF CODE=""
QUIT
+7 SET TEXT=$PIECE(CODE,":",2)
+8 SET II=II+1
SET @DATA@(II)=$PIECE(CODE,":",1)_"^"_TEXT_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
TBS(DATA) ;EP - Get a list of GUI tabs
+1 NEW ORD,IEN,SEL
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00030TAB_NAME^T00030TAB_KEY^T00015TAB_TYPE^T00003DESELECT"_$CHAR(30)
+4 SET ORD=""
+5 FOR
SET ORD=$ORDER(^BQI(90506.4,"AC",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+6 SET IEN=$ORDER(^BQI(90506.4,"AC",ORD,""))
IF '$DATA(^BQI(90506.4,IEN,0))
QUIT
+7 IF $PIECE(^BQI(90506.4,IEN,0),U,4)=1
QUIT
+8 SET SEL=$PIECE(^BQI(90506.4,IEN,0),U,7)
SET SEL=$SELECT(SEL=1:"NO",1:"YES")
+9 SET II=II+1
SET @DATA@(II)=IEN_U_$PIECE(^BQI(90506.4,IEN,0),U,6)_U_$PIECE(^(0),U,2)_U_$$GET1^DIQ(90506.4,IEN_",",.03,"E")_U_SEL_$CHAR(30)
End DoDot:1
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 QUIT
+12 ;
VW(DATA) ;EP - Get the table of customized views
+1 NEW BQILOC,LII
+2 DO EN^BQIMSLST(.BQILOC,"D")
+3 SET LII=$ORDER(@BQILOC@(""),-1)
+4 FOR II=0:1:LII-1
SET @DATA@(II)=@BQILOC@(II)
+5 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 KILL @BQILOC
+7 QUIT
+8 ;
DCT(DATA) ;EP - Get the table of diagnoses categories
+1 SET II=0
+2 SET @DATA@(II)="I00010IEN^T00031^I00010FILE_DEFN_IEN"_$CHAR(30)
+3 NEW IEN,IACT,REG,REGFL,REGIEN
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^BQI(90506.2,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 IF $$GET1^DIQ(90506.2,IEN_",",.05,"I")
QUIT
+7 SET II=II+1
SET REGIEN=""
+8 SET IACT=$$GET1^DIQ(90506.2,IEN_",",.03,"I")
+9 SET NAME=$$GET1^DIQ(90506.2,IEN_",",.01,"E")
+10 ; Return ien for file 90506.3 based on associated register ien
+11 SET REG=$$GET1^DIQ(90506.2,IEN_",",.08,"I")
+12 IF REG'=""
Begin DoDot:2
+13 SET REGFL=$$GET1^DIQ(90507,REG_",",.02,"I")
+14 IF REGFL'=""
SET REGIEN=$ORDER(^BQI(90506.3,"C",REGFL,""))
End DoDot:2
+15 SET @DATA@(II)=IEN_"^"_$SELECT(IACT=1:"*",1:"")_NAME_"^"_REGIEN_$CHAR(30)
End DoDot:1
+16 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+17 QUIT
+18 ;
REG(DATA) ;EP - Get the table of registers
+1 NEW II,IEN,NAME,SREG,RLTD,STAT
+2 SET II=0
+3 SET @DATA@(II)="I00010REG_IEN^T00030REG_NAME^T00001SUB_REG^T00030RELATED_TO^T00001STATUS"_$CHAR(30)
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^BQI(90507,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 ; If the register is not active, quit
+7 IF $$GET1^DIQ(90507,IEN_",",.08,"I")
QUIT
+8 SET NAME=$$GET1^DIQ(90507,IEN_",",.01,"E")
+9 SET SREG=$$GET1^DIQ(90507,IEN_",",.11,"I")
+10 SET RLTD=$$GET1^DIQ(90507,IEN_",",.17,"I")
+11 SET STAT=$$GET1^DIQ(90507,IEN_",",.14,"E")
+12 SET STAT=$SELECT(STAT="":"N",1:"Y")
+13 SET II=II+1
SET @DATA@(II)=IEN_"^"_NAME_"^"_SREG_"^"_RLTD_"^"_STAT_$CHAR(30)
End DoDot:1
+14 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+15 QUIT
+16 ;
COMM(DATA,FILE,FLAG) ;EP - Get the Community Table
+1 NEW CIEN
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00050^T00005COUNT"_$CHAR(30)
+4 ;
+5 IF $ORDER(^XTMP("BQICOMM",0))=""
DO COMM^BQINIGH1
+6 SET CIEN=0
+7 FOR
SET CIEN=$ORDER(^XTMP("BQICOMM",CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+8 IF 'FLAG
IF $PIECE(^XTMP("BQICOMM",CIEN),U,3)=0
QUIT
+9 SET II=II+1
SET @DATA@(II)=^XTMP("BQICOMM",CIEN)_$CHAR(30)
End DoDot:1
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 QUIT
+12 ;
COMMTX(DATA) ;EP - Get list of Community Taxonomies
+1 NEW TAXIEN,TYPE,COM,ITEM,OK,COMTXNM
+2 SET TAXIEN=0
+3 SET @DATA@(II)="I00010IEN^T00050COMM_TAX_NAME"_$CHAR(30)
+4 FOR
SET TAXIEN=$ORDER(^ATXAX(TAXIEN))
IF 'TAXIEN
QUIT
Begin DoDot:1
+5 SET TYPE=$PIECE($GET(^ATXAX(TAXIEN,0)),"^",15)
IF TYPE'=9999999.05
QUIT
+6 SET ITEM=0
SET OK=0
+7 FOR
SET ITEM=$ORDER(^ATXAX(TAXIEN,21,ITEM))
IF 'ITEM
QUIT
Begin DoDot:2
+8 SET COM=$PIECE(^ATXAX(TAXIEN,21,ITEM,0),U)
IF COM=""
QUIT
+9 IF '$DATA(^AUTTCOM("B",COM))
QUIT
+10 SET COMTXNM=$$GET1^DIQ(9002226,TAXIEN,.01,"I")
SET OK=1
+11 SET II=II+1
SET @DATA@(II)=TAXIEN_"^"_COMTXNM_$CHAR(30)
+12 DO UPD^BQITAXX4(COMTXNM,"","CM",7)
End DoDot:2
IF OK
QUIT
End DoDot:1
+13 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+14 QUIT
+15 ;
BEN(DATA) ;EP - Get list of Beneficiary Codes
+1 NEW BENIEN,NAME,CODE
+2 SET BENIEN=0
+3 SET @DATA@(II)="I00010IEN^T00050"_$CHAR(30)
+4 FOR
SET BENIEN=$ORDER(^AUTTBEN(BENIEN))
IF 'BENIEN
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUTTBEN(BENIEN,0))
QUIT
+6 SET NAME=$PIECE(^AUTTBEN(BENIEN,0),"^")
+7 ;_"^"_CODE_$C(30)
SET II=II+1
SET @DATA@(II)=BENIEN_"^"_NAME_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
REM(DATA) ;EP - Reminders
+1 NEW RM,CODE,NAME
+2 SET RM=""
+3 SET @DATA@(II)="T00010IEN^T00050"_$CHAR(30)
+4 FOR
SET RM=$ORDER(^BQI(90506.1,"AC","R",RM))
IF RM=""
QUIT
Begin DoDot:1
+5 IF $PIECE(^BQI(90506.1,RM,0),"^",10)'=""
QUIT
+6 SET CODE=$PIECE(^BQI(90506.1,RM,0),"^",1)
SET NAME=$PIECE(^BQI(90506.1,RM,0),"^",3)
+7 IF $PIECE(CODE,"_",1)="AUTTIMM"
QUIT
+8 IF $PIECE(CODE,"_",1)'="EHR"
IF $PIECE(CODE,"_",1)'="REG"
IF $PIECE(CODE,"_",1)'="CMET"
IF $PIECE(CODE,"_",1)'="IZ"
SET NAME=NAME_" (HS)"
+9 IF $PIECE(CODE,"_",1)="EHR"
SET NAME=NAME_" (EHR)"
+10 IF $PIECE(CODE,"_",1)="REG"
SET NAME=NAME_" (HMS)"
+11 IF $PIECE(CODE,"_",1)="CMET"
SET NAME=NAME_" (CMET)"
+12 IF $PIECE(CODE,"_",1)="IZ"
SET NAME=NAME_" (IZ)"
+13 SET II=II+1
SET @DATA@(II)=CODE_"^"_NAME_$CHAR(30)
End DoDot:1
+14 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+15 QUIT
+16 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
