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