BQIUTB.m

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))