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

BQIVFTLK.m

Go to the documentation of this file. 
  1. BQIVFTLK ;PRXM/HC/ALA-VFILE TABLE LOOKUP ; 06 Apr 2007  3:47 PM
  1.  ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
  1.  ;
  1.  Q
  1.  ;
  1. LKP(DATA,FNBR,VALUE,SCREEN) ;EP -- BQI VFILE TABLE LOOKUP
  1.  ;
  1.  ;Input
  1.  ;  FNBR   - File number to look up value
  1.  ;  VALUE  - Value to look up in File number
  1.  ;  SCREEN - If this table has special screening logic
  1.  ;
  1.  NEW UID,II,X,DDATA
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIVFTLK",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTLK D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S FNBR=$G(FNBR,""),VALUE=$G(VALUE,"")
  1.  I VALUE="" S BMXSEC="RPC Call Failed: No value to look up" Q
  1.  I FNBR="" S BMXSEC="RPC Call Failed: No file identified to search for value" Q
  1.  ;
  1.  NEW FILE,FIELD,INDEX,FLAGS,NUMB,JJ,IEN,TEXT,DESC
  1.  NEW MAP,HDR,MII,NFLD,TYPE,ERROR,XTLKUT,ROOT
  1.  ; If ICD10 KIDS installed, use a screen based on date
  1.  S ROOT=$S(FNBR=80:"^ICD9(",FNBR=80.1:"^ICD0(",1:"")
  1.  I ROOT'="",$$VERSION^XPDUTL("AICD")>3.51 S SCREEN="I +$P($G(~(1)),U,1)=$$SYS^ICDEXLK3(ROOT,DT)"
  1.  S FILE=FNBR,NUMB="*",INDEX=""
  1.  S SCREEN=$G(SCREEN,""),SCREEN=$TR(SCREEN,"~","^")
  1.  S FIELD="FID;-WID"_$$WP(FILE)
  1.  S:FNBR=50 FIELD=FIELD_";31"
  1.  S:FNBR=9999999.06 FIELD="FID;.04;.05;.07;.12",INDEX="B^C",FLAGS="P"
  1.  I FNBR=81,$$VERSION^XPDUTL("BCSV")'="" S FIELD="2"
  1.  I FNBR=80.1 S FIELD="FID"
  1.  ;S FLAGS=$S(FILE=95.3:"P",1:"MP")
  1.  S FLAGS="MP"
  1.  I $E(VALUE,1)="`" S FLAGS="AP"
  1.  I FNBR=9999999.88 S XTLKUT=1,INDEX="B",FLAGS="P"
  1.  ;
  1.  D FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",INDEX,SCREEN,"","","ERROR")
  1.  ;
  1.  I $D(ERROR)>0 S BMXSEC="RPC Call Failed: "_$G(ERROR("DIERR",1,"TEXT",1)) Q
  1.  ;
  1.  S DDATA=$NA(^TMP("DILIST",UID))
  1.  S MAP=$G(@DDATA@(0,"MAP"))
  1.  I MAP="" S @DATA@(II)="T00015IEN^T00030TEXT^T00120DESCRIPTION"_$C(30)
  1.  I MAP'="" D
  1.  . S HDR=""
  1.  . F MII=1:1:$L(MAP,"^") D
  1.  .. I $P(MAP,"^",MII)="IEN" S HDR=HDR_"T00015IEN^" Q
  1.  .. I $P(MAP,"^",MII)[".01" D CHK(.01) S HDR=HDR_TYPE_"^" Q
  1.  .. S NFLD=$P(MAP,"^",MII)
  1.  .. I NFLD["FID(" S NFLD=$P($P(NFLD,"FID(",2),")",1) D CHK(NFLD) S HDR=HDR_TYPE_"^" Q
  1.  .. D CHK(NFLD) S HDR=HDR_TYPE_"^"
  1.  . I FILE=81 S HDR=HDR_"T00060LOOK_DISPLAY"
  1.  . I FILE=80.1!(FILE=80) D
  1.  .. I $$VERSION^XPDUTL("AICD")>3.51 D
  1.  ... S HDR=HDR_"T00245"_$S(FILE=80.1:"OPERATION/PROCEDURE",1:"DIAGNOSIS")_"^T00060LOOK_DISPLAY"
  1.  .. I $$VERSION^XPDUTL("AICD")<4.0 D
  1.  ... S HDR=HDR_"T00060LOOK_DISPLAY"
  1.  . I FILE=9999999.06 D
  1.  .. S HDR=HDR_"T00120LOOK_DISPLAY"
  1.  .. S HDR=$TR(HDR," ","_")
  1.  . S HDR=$$TKO^BQIUL1(HDR,"^"),HDR=$TR(HDR," ","_")
  1.  . S @DATA@(II)=HDR_$C(30)
  1.  I FNBR=9999999.06 D PRST
  1.  S JJ=0
  1.  F  S JJ=$O(@DDATA@(JJ)) Q:'JJ  D
  1.  . I MAP="" D
  1.  .. S IEN=$P(@DDATA@(JJ,0),U,1)
  1.  .. S TEXT=$P(@DDATA@(JJ,0),U,2)
  1.  .. S DESC=""
  1.  .. S FLD=$S(FNBR=80:3,FNBR=80.1:4,FNBR=81:2,FNBR=81:2,FNBR=9999999.31:.02,1:"")
  1.  .. I FLD'="" S DESC=$$GET1^DIQ(FNBR,IEN,FLD,"E")
  1.  .. S II=II+1,@DATA@(II)=IEN_"^"_TEXT_"^"_DESC_$C(30)
  1.  . I MAP'="" D
  1.  .. NEW IEN,TEXT,DESC,QFL
  1.  .. S IEN=$P(@DDATA@(JJ,0),U,1),QFL=0
  1.  .. S TEXT=$P(@DDATA@(JJ,0),U,2)
  1.  .. I TEXT?.N D
  1.  ... S DESC=$$GET1^DIQ(FNBR,IEN,.01,"E")
  1.  ... S $P(@DDATA@(JJ,0),U,2)=DESC
  1.  .. I FILE=81 S @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$P(@DDATA@(JJ,0),U,2)_"-"_$P(@DDATA@(JJ,0),U,3)
  1.  .. I FILE=80.1!(FILE=80) D
  1.  ... I $$VERSION^XPDUTL("AICD")>3.51 D
  1.  .... S DESC=$$ICDD^BQIUL3(FILE,IEN,"")
  1.  .... S @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_DESC_U_$P(@DDATA@(JJ,0),U,2)_"-"_DESC
  1.  ... I $$VERSION^XPDUTL("AICD")<4.0 D
  1.  .... S @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$P(@DDATA@(JJ,0),U,2)_"-"_$P(@DDATA@(JJ,0),U,3)
  1.  .. I FILE=9999999.06 D  Q:QFL
  1.  ... I $P($G(^DIC(4,IEN,0)),U,11)="L" S QFL=1 Q
  1.  ... S @DDATA@(JJ,0)=@DDATA@(JJ,0)_U_$P(@DDATA@(JJ,0),U,2)_"-"_$P(@DDATA@(JJ,0),U,3)_"-"_$P(@DDATA@(JJ,0),U,4)
  1.  .. S II=II+1,@DATA@(II)=@DDATA@(JJ,0)_$C(30)
  1.  ;
  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,^TMP("BQIVFTLK",UID,II)=$C(31)
  1.  Q
  1.  ;
  1. CHK(BFLD) ;EP - Check for definition of a field
  1.  NEW DLEN
  1.  D FIELD^DID(FNBR,BFLD,"","TYPE","BQX")
  1.  D FIELD^DID(FNBR,BFLD,"","FIELD LENGTH","BQX")
  1.  D FIELD^DID(FNBR,BFLD,"","LABEL","BQX")
  1.  S TYPE=$S(BQX("TYPE")["DATE":"D",1:"T")
  1.  S DLEN=BQX("FIELD LENGTH")+5
  1.  S TYPE=TYPE_$E("00000",$L(DLEN)+1,5)_DLEN_BQX("LABEL")
  1.  K BQX
  1.  Q
  1.  ;
  1. TAB(DATA,FNBR) ;EP -- BQI GET VFILE TABLE
  1.  ;Input
  1.  ;  FNBR  - File number to look up value
  1.  ;
  1.  NEW UID,II,X
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIVFTLK",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTLK D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S FNBR=$G(FNBR,""),IACT=""
  1.  I FNBR="" S BMXSEC="RPC Call Failed: No file identified to search for value" Q
  1.  ;
  1.  I FNBR=9999999.14 D TBL(.DATA,FNBR,"0;7",1) Q
  1.  ;
  1.  I FNBR=9001001.2 D TBL(.DATA,FNBR,"") Q
  1.  ;
  1.  I FNBR=9999999.09!(FNBR=9999999.28) S IACT="0;3"
  1.  I FNBR=9002084.8 D TBL(.DATA,FNBR,"0;3",0) Q
  1.  I FNBR=9999999.41 D TBL(.DATA,FNBR,"0;3",1) Q
  1.  ;
  1.  I FNBR=9999999.15 D EXM(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR=10 S IACT=".02;1"
  1.  I FNBR=10.2 S IACT=".02;1"
  1.  ;
  1.  I FNBR=40.7 S IACT=""
  1.  I FNBR=9001002.5 S IACT=""
  1.  ;
  1.  I FNBR["9999999.64" D HF(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR["9999999.07" D MS(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR="9001015" D HS(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR="9001022" D SP(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR="90451.7" D CLS(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR="90451.5" D ETI(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR="9999999.88" D MOD(.DATA,FNBR) Q
  1.  ;
  1.  I FNBR="FH80" D FH80^BQIUTB5(.DATA) Q
  1.  ;
  1.  I FNBR="GPORD" D GPORD(.DATA) Q
  1.  ;
  1.  ;I FNBR="PROV" D USR^BQIUTB(.DATA,"P") Q
  1.  ;
  1.  I FNBR="FH9999999.36" D FHREL^BQIUTB5(.DATA) Q
  1.  ;
  1.  I FNBR="90621" D EVT(.DATA) Q
  1.  I FNBR="EVTYPE" D EVTY^BQIVFTRT(.DATA,EVIEN)
  1.  I FNBR="EVTAX" D EVTAX^BQIVFTRT(.DATA,EVIEN,EVTYPE)
  1.  ;
  1.  D TBL^BQIUTB(.DATA,FNBR,IACT)
  1.  Q
  1.  ;
  1. HF(DATA,FIL) ;EP - Get Health Factors only
  1.  NEW IEN
  1.  S II=0
  1.  S @DATA@(II)="I00010IEN^T00040"_$C(30)
  1.  S IEN=0,TYP=$E(FNBR,$L(FNBR),$L(FNBR))
  1.  F  S IEN=$O(^AUTTHF(IEN)) Q:'IEN  D
  1.  . I TYP="C" D
  1.  .. I $P($G(^AUTTHF(IEN,0)),U,10)'=TYP Q
  1.  .. I $P($G(^AUTTHF(IEN,0)),U,13)'="" Q
  1.  .. S II=II+1,@DATA@(II)=IEN_U_$P(^AUTTHF(IEN,0),U,1)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EXM(DATA,FILE) ;EP - Get Exams
  1.  NEW IEN,NAME
  1.  S II=0,IEN=0
  1.  S @DATA@(II)="I00010IEN^T00040"_$C(30)
  1.  F  S IEN=$O(^AUTTEXAM(IEN)) Q:'IEN  D
  1.  . S NAME=$P(^AUTTEXAM(IEN,0),U,1)
  1.  . I $P(^AUTTEXAM(IEN,0),U,4)'="" Q
  1.  . I $P(^AUTTEXAM(IEN,0),U,2)=40 Q
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. GPORD(DATA) ;EP - ORDERABLE ITEMS
  1.  NEW PIEN,BAT,PIEN,EVT
  1.  ;S @DATA@(II)="I00010IEN^T00030PROC_NAME^T00030CATEGORY^T00001BATCH"_$C(30)
  1.  S @DATA@(II)="I00010IEN^T00030"_$C(30)
  1.  S PIEN=0
  1.  F  S PIEN=$O(^BTPW(90621,PIEN)) Q:'PIEN  D
  1.  . I $$GET1^DIQ(90621,PIEN_",",.03,"I")'="" Q
  1.  . I $$GET1^DIQ(90621,PIEN_",",.11,"I")="" Q
  1.  . S EVT=$$GET1^DIQ(90621,PIEN_",",.01,"E") Q:EVT=""
  1.  . S II=II+1,@DATA@(II)=PIEN_U_EVT_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. EVT(DATA) ;EP - CMET Events
  1.  NEW PIEN,PRCNAM
  1.  S @DATA@(II)="I00010IEN^T00030"_$C(30)
  1.  S PIEN=0
  1.  F  S PIEN=$O(^BTPW(90621,PIEN)) Q:'PIEN  D
  1.  . I $P(^BTPW(90621,PIEN,0),U,3)'="" Q
  1.  . S PRCNAM=$P(^BTPW(90621,PIEN,0),U,1) I PRCNAM="N/A" Q
  1.  . S II=II+1,@DATA@(II)=PIEN_U_PRCNAM_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. HS(DATA,FILE) ; EP - Get Health Summary Types
  1.  NEW IEN,NAME,KEY
  1.  S II=0,IEN=0
  1.  S @DATA@(II)="I00010IEN^T00040"_$C(30)
  1.  F  S IEN=$O(^APCHSCTL(IEN)) Q:'IEN  D
  1.  . S NAME=$P(^APCHSCTL(IEN,0),U,1) ;,KEY=$P(^(0),U,2)
  1.  . ;I KEY'="",$$KEYCHK^BQIULSC(KEY,DUZ) Q
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CLS(DATA,FILE) ; EP - Get Clinical Classifications
  1.  NEW IEN,NAME,DESC
  1.  S @DATA@(II)="I00010IEN^T00160"_$C(30)
  1.  S IEN=0
  1.  F  S IEN=$O(^BKMV(FILE,IEN)) Q:'IEN  D
  1.  . S NAME=$P(^BKMV(FILE,IEN,0),U,1)
  1.  . S DESC=$P(^BKMV(FILE,IEN,0),U,2)
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_"-"_DESC_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ETI(DATA,FILE) ; EP - Get Etiology
  1.  NEW IEN,NAME,DESC
  1.  S @DATA@(II)="I00010IEN^T00160"_$C(30)
  1.  S IEN=0
  1.  F  S IEN=$O(^BKM(FILE,IEN)) Q:'IEN  D
  1.  . S DESC=$P(^BKM(FILE,IEN,0),U,1)
  1.  . S NAME=$P(^BKM(FILE,IEN,0),U,2)
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_"-"_DESC_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. MOD(DATA,FILE) ; EP - Get CPT Modifiers
  1.  NEW IEN,NAME,DESC
  1.  S @DATA@(II)="I00010IEN^T01024CODE_DESCRIPTION"_$C(30)
  1.  S IEN=0
  1.  F  S IEN=$O(^AUTTCMOD(IEN)) Q:'IEN  D
  1.  . S NAME=$P(^AUTTCMOD(IEN,0),U,1),DESC=$P(^AUTTCMOD(IEN,0),U,2)
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_"-"_DESC_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. SP(DATA,FILE) ; EP - Get Supplements
  1.  NEW IEN,SUPNM,DESC,DN,EXEC,PRGM
  1.  S HDR="I00010IEN^T00030^T00030TAX_CHECK^T01024SUPP_DESC"_$C(30)
  1.  D EN^BQIRSPR(.DATA)
  1.  S @DATA@(0)=HDR
  1.  Q
  1.  ;
  1.  S SUPNM=""
  1.  F  S SUPNM=$O(^APCHSUP("B",SUPNM)) Q:SUPNM=""  D
  1.  . I $E(SUPNM,1,7)="CHRONIC"!($E(SUPNM,1,7)="MEDICAT") Q
  1.  . I SUPNM="ACTION PROFILE" Q
  1.  . S IEN=""
  1.  . F  S IEN=$O(^APCHSUP("B",SUPNM,IEN)) Q:IEN=""  D
  1.  .. S EXEC=$G(^APCHSUP(IEN,11)) I EXEC="" Q
  1.  .. S PRGM=$P(EXEC,"^",2)
  1.  .. I PRGM["(" S PRGM=$P(PRGM,"(",1)
  1.  .. I $T(@("^"_PRGM))="" Q
  1.  .. S DESC="",DN=0
  1.  .. F  S DN=$O(^APCHSUP(IEN,12,DN)) Q:'DN  D
  1.  ... S DESC=DESC_^APCHSUP(IEN,12,DN,0)_$C(10)
  1.  .. S II=II+1,@DATA@(II)=IEN_"^"_SUPNM_"^"_DESC_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. MS(DATA,FILE) ; EP - Get Measurement Types only
  1.  ; excluding the 'ASQ' ones and BMIP
  1.  NEW IEN,NAME
  1.  S II=0,IEN=0
  1.  S @DATA@(II)="I00010IEN^T00040"_$C(30)
  1.  F  S IEN=$O(^AUTTMSR(IEN)) Q:'IEN  D
  1.  . S NAME=$P(^AUTTMSR(IEN,0),U,1)
  1.  . I $E(NAME,1,3)="ASQ"!($E(NAME,1,3)="BMI") Q
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. WP(FILE) ; Exclude identifiers that are word processing fields
  1.  ;
  1.  NEW ID,TYPE,WPFLD
  1.  S ID="",WPFLD=""
  1.  F  S ID=$O(^DD(FILE,0,"ID",ID)) Q:ID=""  D
  1.  . S TYPE=$P($G(^DD(FILE,ID,0)),"^",2) Q:'TYPE
  1.  . I $P($G(^DD(+TYPE,.01,0)),"^",2)["W" S WPFLD=WPFLD_";-"_ID
  1.  Q WPFLD
  1.  ;
  1. TBL(DATA,FILE,INAC,VALS) ;EP - Get table data if generic table lookup cannot
  1.  ;                       be used since inactive field may have length if active
  1.  ;
  1.  ;Input
  1.  ; FILE - FileMan file number where table resides
  1.  ; INAC - Location of inactive field to check, contains
  1.  ;         the node and piece in 'NODE;PIECE' format
  1.  ; VALS - Value(s) that constitute an inactive record (delimited by a comma)
  1.  ; 
  1.  ;Description
  1.  ;  Return the values in a table
  1.  ;
  1.  NEW GLBREF,LENGTH,DLEN,INACFLG,PC,VAL,VFVAL
  1.  ;  
  1.  I '$$VFILE^DILFD(FILE) S BMXSEC="RPC Call Failed: Table doesn't exist in RPMS" Q
  1.  ;
  1.  S GLBREF=$$ROOT^DILFD(FILE,"",1)
  1.  S LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
  1.  S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
  1.  S @DATA@(II)="I00010IEN^T"_DLEN_$C(30)
  1.  ;
  1.  I INAC'="" S NODE=$P(INAC,";",1),PEC=$P(INAC,";",2)
  1.  S IEN=0
  1.  F  S IEN=$O(@GLBREF@(IEN)) Q:'IEN  D
  1.  . I $G(@GLBREF@(IEN,0))="" Q
  1.  . I INAC'="" S INACFLG=0 D  Q:INACFLG
  1.  .. S VFVAL=$P($G(@GLBREF@(IEN,NODE)),"^",PEC)
  1.  .. F PC=1:1:$L(VALS,",") S VAL=$P(VALS,",",PC) I VFVAL=VAL S INACFLG=1 Q
  1.  . S II=II+1,@DATA@(II)=IEN_"^"_$$GET1^DIQ(FILE,IEN_",",.01,"E")_$C(30)
  1.  ;
  1. DONE S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PRST ; Presort results so that matching SERVICE UNIT (and, if possible, AREA) are listed 1st
  1.  NEW SVCUN,DAREA,SEL,ZERO,MAP,CT,AREA,SVCU,NN
  1.  S SVCUN=$$GET1^DIQ(9999999.06,DUZ(2)_",",.05,"E")
  1.  S DAREA=$$GET1^DIQ(9999999.06,DUZ(2)_",",.04,"E")
  1.  S SDATA=$NA(^TMP("BQIVFSORT",UID))
  1.  S SEL=""
  1.  K BQIAS,BQISA,BQISORT
  1.  S JJ=0 F  S JJ=$O(@DDATA@(JJ)) Q:'JJ  D  Q:SEL
  1.  . S AREA=$P(@DDATA@(JJ,0),U,3),SVCU=$P(@DDATA@(JJ,0),U,4)
  1.  . S:AREA="" AREA="unknown" S:SVCU="" SVCU="unknown"
  1.  . S BQIAS(AREA,SVCU,JJ)="",BQISA(SVCU,AREA,JJ)=""
  1.  I DAREA'="",SVCUN'="",$D(BQIAS(DAREA,SVCUN)) D
  1.  . S SEL=$O(BQIAS(DAREA,SVCUN,"")),BQISORT("@",SEL)=@DDATA@(SEL,0)
  1.  I 'SEL,SVCUN'="",$D(BQISA(SVCUN)) D
  1.  . S AREA=$O(BQISA(SVCUN,"")),SEL=$O(BQISA(SVCUN,AREA,"")),BQISORT("@",SEL)=@DDATA@(SEL,0)
  1.  I 'SEL,DAREA'="",$D(BQIAS(DAREA)) D
  1.  . S SVCU=$O(BQIAS(DAREA,"")),SEL=$O(BQIAS(DAREA,SVCU,"")),BQISORT("@",SEL)=@DDATA@(SEL,0)
  1.  I 'SEL,$D(BQIAS) D
  1.  . S AREA=$O(BQIAS("")),SVCU=$O(BQIAS(AREA,"")),SEL=$O(BQIAS(AREA,SVCU,"")),BQISORT("@",SEL)=@DDATA@(SEL,0)
  1.  K BQIAS,BQISA
  1.  S JJ=0,CT=0
  1.  F  S JJ=$O(@DDATA@(JJ)) Q:'JJ  I JJ'=SEL D
  1.  . S CT=CT+1,BQISORT(CT,JJ)=@DDATA@(JJ,0)
  1.  S ZERO=$G(@DDATA@(0))
  1.  S MAP=$G(@DDATA@(0,"MAP"))
  1.  K @DDATA
  1.  S @DDATA@(0)=ZERO
  1.  S @DDATA@(0,"MAP")=MAP
  1.  S CT=0,AREA="@",NN=0
  1.  F  S NN=$O(BQISORT(AREA,NN)) Q:NN=""  D
  1.  . S CT=CT+1,@DDATA@(CT,0)=BQISORT(AREA,NN)
  1.  . K BQISORT(AREA,NN)
  1.  S AREA=""
  1.  F  S AREA=$O(BQISORT(AREA)) Q:AREA=""  D
  1.  . S NN=""
  1.  . F  S NN=$O(BQISORT(AREA,NN)) Q:NN=""  D
  1.  .. S CT=CT+1,@DDATA@(CT,0)=BQISORT(AREA,NN)
  1.  K BQISORT
  1.  Q