BQIRGUTL ;PRXM/HC/ALA-Register Utilities ; 26 Nov 2007 1:51 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
MEAS(BQIDFN,TYPE,HDR) ;EP - Get last FEV value for this patient
NEW IEN,QFL,VALUE,FLD
S FLD=$S(TYPE="FEV":.05,TYPE="FEF":.06,1:.07)
S IEN="",QFL=0,VALUE=""
F S IEN=$O(^AUPNVAST("C",BQIDFN,""),-1) Q:IEN="" D Q:QFL
. S VALUE=$$GET1^DIQ(9000010.41,IEN_",",FLD,"E")
. I VALUE'="" S QFL=1 Q
I $E(HDR,1,1)="N",VALUE="" S VALUE=-1
Q VALUE
;
HIV(BQIDFN,HFLD,OUT) ;EP - Get HIV register data
NEW BQRIEN,HIVIEN,HFIL,DA,IENS
S OUT=$G(OUT,"E")
S BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN) I BQRIEN="" Q ""
S HIVIEN=$$HIVIEN^BKMIXX3() I HIVIEN="" Q ""
S HFIL=90451.01
S DA(1)=BQRIEN,DA=HIVIEN,IENS=$$IENS^DILF(.DA)
S VAL=$$GET1^DIQ(HFIL,IENS,HFLD,OUT)
Q VAL
;
HIVD(BQIDFN,HFLD) ; EP - Get HIV register dates
NEW BQRIEN,HIVIEN,HFIL,DA,IENS
S BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN) I BQRIEN="" Q ""
S HIVIEN=$$HIVIEN^BKMIXX3() I HIVIEN="" Q ""
S HFIL=90451.01
S DA(1)=BQRIEN,DA=HIVIEN,IENS=$$IENS^DILF(.DA)
S VAL=$$GET1^DIQ(HFIL,IENS,HFLD,"I")
S VAL=$$FMTE^BQIUL1(VAL)
Q VAL
;
HIVM(BQIDFN,HFLD,HSBFLD,HSRTFLD) ; EP - Get last entry for an HIV multiple field
NEW BQRIEN,HIVIEN,HFIL,DA,IENS,HARRAY,LIEN,BQVAL,HSBFIL,NOD,HTYPE
NEW SARRAY,SDATA,SNOD,SORT,SPC,LSTSRT
S BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN) I BQRIEN="" Q ""
S HIVIEN=$$HIVIEN^BKMIXX3() I HIVIEN="" Q ""
; Get subfile number for the multiple
S HSRTFLD=$G(HSRTFLD)
K HARRAY
S HFIL=90451.01
D FIELD^DID(HFIL,HFLD,"","SPECIFIER;GLOBAL SUBSCRIPT LOCATION","HARRAY")
S HSBFIL=$G(HARRAY("SPECIFIER")) I HSBFIL="" Q
S HSBFIL=$$STRIP^XLFSTR(HSBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S NOD=$P($G(HARRAY("GLOBAL SUBSCRIPT LOCATION")),";",1) I NOD="" Q
S BQVAL="A"
;S BQVAL=""
I HSRTFLD D
. D FIELD^DID(HSBFIL,HSRTFLD,"","GLOBAL SUBSCRIPT LOCATION","SARRAY")
. S SNOD=$P($G(SARRAY("GLOBAL SUBSCRIPT LOCATION")),";",1) I SNOD="" Q
. S SPC=$P(SARRAY("GLOBAL SUBSCRIPT LOCATION"),";",2) I SPC="" Q
. S BQVAL=0
. F S BQVAL=$O(^BKM(90451,BQRIEN,1,HIVIEN,NOD,BQVAL)) Q:'BQVAL D
.. S SORT=$P($G(^BKM(90451,BQRIEN,1,HIVIEN,NOD,BQVAL,SNOD)),U,SPC)
.. S SDATA(" "_SORT,BQVAL)=""
. S LIEN="",LSTSRT=$O(SDATA(""),-1) I LSTSRT'="" S LIEN=$O(SDATA(LSTSRT,""),-1)
I 'HSRTFLD S QFL=0 D I QFL Q ""
. I $D(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B")) S QFL=0 D I QFL Q
.. S BQVAL=$O(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B",BQVAL),-1)
.. ;S BQVAL=$O(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B",BQVAL))
.. I BQVAL="" S QFL=1 Q
.. S LIEN="A"
.. S LIEN=$O(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B",BQVAL,LIEN),-1)
.. I LIEN="" S QFL=1
. ;
. I '$D(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B")) D
.. S BQVAL=$O(^BKM(90451,BQRIEN,1,HIVIEN,NOD,""),-1)
.. S LIEN=BQVAL
I $G(LIEN)="" Q ""
;
S DA(2)=BQRIEN,DA(1)=HIVIEN,DA=LIEN,IENS=$$IENS^DILF(.DA)
K HARRAY
D FIELD^DID(HSBFIL,HSBFLD,"","TYPE","HARRAY")
S HTYPE=$G(HARRAY("TYPE"))
;I HTYPE="POINTER"!(HTYPE="SET") S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"I")_$C(28)_$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"E")
I HTYPE'["DATE" D
. ;I HTYPE="POINTER" S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"I")_$C(28)_$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"E") Q
. ;I HTYPE="SET" Q
. S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"E")
I HTYPE["DATE" S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"I"),VAL=$$FMTE^BQIUL1(VAL)
I HTYPE="WORD-PROCESSING" D
. K BARRAY
. S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"Z","BARRAY")
. S LIEN=0,VAL=""
. F S LIEN=$O(BARRAY(LIEN)) Q:'LIEN D
.. S VAL=VAL_BARRAY(LIEN,0)_$C(10)
. S VAL=$$TKO^BQIUL1(VAL,$C(10))
Q VAL
;
HIVS(STR,CSTR,SEP) ; EP - Add separator for last entry for an HIV multiple
; String that may need a separator
; String that STR will be concatenated to
; Separator
;
I $G(SEP)="" Q STR
I $G(CSTR)'="",$E(CSTR,$L(CSTR))'=SEP S STR=SEP_STR
Q STR
;
HIVST(STR,CSTR,SEP) ; EP - Strip trailing separator
NEW STR1,STR2
S STR1=$$TKO^BQIUL1(CSTR_STR,SEP)
F S STR2=$$TKO^BQIUL1(STR1,SEP) Q:STR1=STR2!(STR2="")
Q STR2
;
STRIP(STR,VAL) ;EP - Remove one or more characters in a string.
;
;Description
; Removes one or more trailing characters
; at the end of a string.
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; Same STR without the trailing character(s).
;
I $G(STR)="" Q STR
I $G(VAL)="" Q STR
;
NEW LVAL
S LVAL=$L(VAL)
F Q:$E(STR,$L(STR)-LVAL+1,$L(STR))'=VAL S STR=$E(STR,1,($L(STR)-LVAL))
Q STR
;
HIVW(BQIDFN,HFLD) ; EP - Get a word-processing field
NEW BQRIEN,HIVIEN,HFIL,DA,IENS,HARRAY,LIEN
S BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN) I BQRIEN="" Q ""
S HIVIEN=$$HIVIEN^BKMIXX3() I HIVIEN="" Q ""
K HARRAY
S HFIL=90451.01
S DA(1)=BQRIEN,DA=HIVIEN,IENS=$$IENS^DILF(.DA)
S VAL=$$GET1^DIQ(HFIL,IENS,HFLD,"Z","HARRAY")
S LIEN=0,VAL=""
F S LIEN=$O(HARRAY(LIEN)) Q:'LIEN D
. S VAL=VAL_HARRAY(LIEN,0)_$C(10)
S VAL=$$TKO^BQIUL1(VAL,$C(10))
Q VAL
;
HIVTR(DATA,LOC) ; EP - BQI HMS LOCATION TRIGGER
;
; Input
; LOC - Location selected (required)
; If location has a facility code of 49 or larger enable Other Location
; and Other Provider
NEW UID,II,CODE,ABLE
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIQOCTR",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRREG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T00008SOURCE^T00001ABLE_FLAG"_$C(30)
S ABLE="N"
; Check facility code - if >48 enable Other Location and Other Provider fields
S CODE=$$GET1^DIQ(9999999.06,LOC,.07,"I") I CODE>48 S ABLE="Y"
S II=II+1,@DATA@(II)="BKMOL^"_ABLE_$C(30) ; Other Location
S II=II+1,@DATA@(II)="BKMOP^"_ABLE_$C(30) ; Other Provider
S II=II+1,@DATA@(II)=$C(31)
Q
;
LST(DATA,FAKE) ;EP - BQI REGISTER TAB LIST
NEW UID,II,CAT,CLIN,DCIEN,REGIEN,REG
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J),II=0
S DATA=$NA(^TMP("BQIRGLST",UID))
K @DATA
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGLST D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T00030REGISTER^I00010REG_IEN^T00030REMINDER_CATEGORY^T00030REMINDER_CLIN_GROUP"_$C(30)
;
S DCIEN=0
F S DCIEN=$O(^BQI(90507,DCIEN)) Q:'DCIEN D
. S REG=$$GET1^DIQ(90507,DCIEN_",",.01,"E")
. S REGIEN=+$$GET1^DIQ(90507,DCIEN_",",.16,"I")
. I 'REGIEN Q
. S CAT=$$GET1^DIQ(90507,DCIEN_",",4.01,"E")
. S CLIN=$$GET1^DIQ(90507,DCIEN_",",4.02,"E")
. S II=II+1,@DATA@(II)=REG_U_DCIEN_U_CAT_U_CLIN_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
HMS(BQIDFN) ;EP - Return HMS record IENS
NEW BQRIEN,HIVIEN,IENS,DA
S BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN) I BQRIEN="" Q ""
S HIVIEN=$$HIVIEN^BKMIXX3() I HIVIEN="" Q ""
S DA(1)=BQRIEN,DA=HIVIEN
Q $$IENS^DILF(.DA)
BQIRGUTL ;PRXM/HC/ALA-Register Utilities ; 26 Nov 2007 1:51 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
MEAS(BQIDFN,TYPE,HDR) ;EP - Get last FEV value for this patient
+1 NEW IEN,QFL,VALUE,FLD
+2 SET FLD=$SELECT(TYPE="FEV":.05,TYPE="FEF":.06,1:.07)
+3 SET IEN=""
SET QFL=0
SET VALUE=""
+4 FOR
SET IEN=$ORDER(^AUPNVAST("C",BQIDFN,""),-1)
IF IEN=""
QUIT
Begin DoDot:1
+5 SET VALUE=$$GET1^DIQ(9000010.41,IEN_",",FLD,"E")
+6 IF VALUE'=""
SET QFL=1
QUIT
End DoDot:1
IF QFL
QUIT
+7 IF $EXTRACT(HDR,1,1)="N"
IF VALUE=""
SET VALUE=-1
+8 QUIT VALUE
+9 ;
HIV(BQIDFN,HFLD,OUT) ;EP - Get HIV register data
+1 NEW BQRIEN,HIVIEN,HFIL,DA,IENS
+2 SET OUT=$GET(OUT,"E")
+3 SET BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN)
IF BQRIEN=""
QUIT ""
+4 SET HIVIEN=$$HIVIEN^BKMIXX3()
IF HIVIEN=""
QUIT ""
+5 SET HFIL=90451.01
+6 SET DA(1)=BQRIEN
SET DA=HIVIEN
SET IENS=$$IENS^DILF(.DA)
+7 SET VAL=$$GET1^DIQ(HFIL,IENS,HFLD,OUT)
+8 QUIT VAL
+9 ;
HIVD(BQIDFN,HFLD) ; EP - Get HIV register dates
+1 NEW BQRIEN,HIVIEN,HFIL,DA,IENS
+2 SET BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN)
IF BQRIEN=""
QUIT ""
+3 SET HIVIEN=$$HIVIEN^BKMIXX3()
IF HIVIEN=""
QUIT ""
+4 SET HFIL=90451.01
+5 SET DA(1)=BQRIEN
SET DA=HIVIEN
SET IENS=$$IENS^DILF(.DA)
+6 SET VAL=$$GET1^DIQ(HFIL,IENS,HFLD,"I")
+7 SET VAL=$$FMTE^BQIUL1(VAL)
+8 QUIT VAL
+9 ;
HIVM(BQIDFN,HFLD,HSBFLD,HSRTFLD) ; EP - Get last entry for an HIV multiple field
+1 NEW BQRIEN,HIVIEN,HFIL,DA,IENS,HARRAY,LIEN,BQVAL,HSBFIL,NOD,HTYPE
+2 NEW SARRAY,SDATA,SNOD,SORT,SPC,LSTSRT
+3 SET BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN)
IF BQRIEN=""
QUIT ""
+4 SET HIVIEN=$$HIVIEN^BKMIXX3()
IF HIVIEN=""
QUIT ""
+5 ; Get subfile number for the multiple
+6 SET HSRTFLD=$GET(HSRTFLD)
+7 KILL HARRAY
+8 SET HFIL=90451.01
+9 DO FIELD^DID(HFIL,HFLD,"","SPECIFIER;GLOBAL SUBSCRIPT LOCATION","HARRAY")
+10 SET HSBFIL=$GET(HARRAY("SPECIFIER"))
IF HSBFIL=""
QUIT
+11 SET HSBFIL=$$STRIP^XLFSTR(HSBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+12 SET NOD=$PIECE($GET(HARRAY("GLOBAL SUBSCRIPT LOCATION")),";",1)
IF NOD=""
QUIT
+13 SET BQVAL="A"
+14 ;S BQVAL=""
+15 IF HSRTFLD
Begin DoDot:1
+16 DO FIELD^DID(HSBFIL,HSRTFLD,"","GLOBAL SUBSCRIPT LOCATION","SARRAY")
+17 SET SNOD=$PIECE($GET(SARRAY("GLOBAL SUBSCRIPT LOCATION")),";",1)
IF SNOD=""
QUIT
+18 SET SPC=$PIECE(SARRAY("GLOBAL SUBSCRIPT LOCATION"),";",2)
IF SPC=""
QUIT
+19 SET BQVAL=0
+20 FOR
SET BQVAL=$ORDER(^BKM(90451,BQRIEN,1,HIVIEN,NOD,BQVAL))
IF 'BQVAL
QUIT
Begin DoDot:2
+21 SET SORT=$PIECE($GET(^BKM(90451,BQRIEN,1,HIVIEN,NOD,BQVAL,SNOD)),U,SPC)
+22 SET SDATA(" "_SORT,BQVAL)=""
End DoDot:2
+23 SET LIEN=""
SET LSTSRT=$ORDER(SDATA(""),-1)
IF LSTSRT'=""
SET LIEN=$ORDER(SDATA(LSTSRT,""),-1)
End DoDot:1
+24 IF 'HSRTFLD
SET QFL=0
Begin DoDot:1
+25 IF $DATA(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B"))
SET QFL=0
Begin DoDot:2
+26 SET BQVAL=$ORDER(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B",BQVAL),-1)
+27 ;S BQVAL=$O(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B",BQVAL))
+28 IF BQVAL=""
SET QFL=1
QUIT
+29 SET LIEN="A"
+30 SET LIEN=$ORDER(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B",BQVAL,LIEN),-1)
+31 IF LIEN=""
SET QFL=1
End DoDot:2
IF QFL
QUIT
+32 ;
+33 IF '$DATA(^BKM(90451,BQRIEN,1,HIVIEN,NOD,"B"))
Begin DoDot:2
+34 SET BQVAL=$ORDER(^BKM(90451,BQRIEN,1,HIVIEN,NOD,""),-1)
+35 SET LIEN=BQVAL
End DoDot:2
End DoDot:1
IF QFL
QUIT ""
+36 IF $GET(LIEN)=""
QUIT ""
+37 ;
+38 SET DA(2)=BQRIEN
SET DA(1)=HIVIEN
SET DA=LIEN
SET IENS=$$IENS^DILF(.DA)
+39 KILL HARRAY
+40 DO FIELD^DID(HSBFIL,HSBFLD,"","TYPE","HARRAY")
+41 SET HTYPE=$GET(HARRAY("TYPE"))
+42 ;I HTYPE="POINTER"!(HTYPE="SET") S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"I")_$C(28)_$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"E")
+43 IF HTYPE'["DATE"
Begin DoDot:1
+44 ;I HTYPE="POINTER" S VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"I")_$C(28)_$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"E") Q
+45 ;I HTYPE="SET" Q
+46 SET VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"E")
End DoDot:1
+47 IF HTYPE["DATE"
SET VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"I")
SET VAL=$$FMTE^BQIUL1(VAL)
+48 IF HTYPE="WORD-PROCESSING"
Begin DoDot:1
+49 KILL BARRAY
+50 SET VAL=$$GET1^DIQ(HSBFIL,IENS,HSBFLD,"Z","BARRAY")
+51 SET LIEN=0
SET VAL=""
+52 FOR
SET LIEN=$ORDER(BARRAY(LIEN))
IF 'LIEN
QUIT
Begin DoDot:2
+53 SET VAL=VAL_BARRAY(LIEN,0)_$CHAR(10)
End DoDot:2
+54 SET VAL=$$TKO^BQIUL1(VAL,$CHAR(10))
End DoDot:1
+55 QUIT VAL
+56 ;
HIVS(STR,CSTR,SEP) ; EP - Add separator for last entry for an HIV multiple
+1 ; String that may need a separator
+2 ; String that STR will be concatenated to
+3 ; Separator
+4 ;
+5 IF $GET(SEP)=""
QUIT STR
+6 IF $GET(CSTR)'=""
IF $EXTRACT(CSTR,$LENGTH(CSTR))'=SEP
SET STR=SEP_STR
+7 QUIT STR
+8 ;
HIVST(STR,CSTR,SEP) ; EP - Strip trailing separator
+1 NEW STR1,STR2
+2 SET STR1=$$TKO^BQIUL1(CSTR_STR,SEP)
+3 FOR
SET STR2=$$TKO^BQIUL1(STR1,SEP)
IF STR1=STR2!(STR2="")
QUIT
+4 QUIT STR2
+5 ;
STRIP(STR,VAL) ;EP - Remove one or more characters in a string.
+1 ;
+2 ;Description
+3 ; Removes one or more trailing characters
+4 ; at the end of a string.
+5 ;Input
+6 ; STR - String of data
+7 ; VAL - Delimiter character
+8 ;Output
+9 ; Same STR without the trailing character(s).
+10 ;
+11 IF $GET(STR)=""
QUIT STR
+12 IF $GET(VAL)=""
QUIT STR
+13 ;
+14 NEW LVAL
+15 SET LVAL=$LENGTH(VAL)
+16 FOR
IF $EXTRACT(STR,$LENGTH(STR)-LVAL+1,$LENGTH(STR))'=VAL
QUIT
SET STR=$EXTRACT(STR,1,($LENGTH(STR)-LVAL))
+17 QUIT STR
+18 ;
HIVW(BQIDFN,HFLD) ; EP - Get a word-processing field
+1 NEW BQRIEN,HIVIEN,HFIL,DA,IENS,HARRAY,LIEN
+2 SET BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN)
IF BQRIEN=""
QUIT ""
+3 SET HIVIEN=$$HIVIEN^BKMIXX3()
IF HIVIEN=""
QUIT ""
+4 KILL HARRAY
+5 SET HFIL=90451.01
+6 SET DA(1)=BQRIEN
SET DA=HIVIEN
SET IENS=$$IENS^DILF(.DA)
+7 SET VAL=$$GET1^DIQ(HFIL,IENS,HFLD,"Z","HARRAY")
+8 SET LIEN=0
SET VAL=""
+9 FOR
SET LIEN=$ORDER(HARRAY(LIEN))
IF 'LIEN
QUIT
Begin DoDot:1
+10 SET VAL=VAL_HARRAY(LIEN,0)_$CHAR(10)
End DoDot:1
+11 SET VAL=$$TKO^BQIUL1(VAL,$CHAR(10))
+12 QUIT VAL
+13 ;
HIVTR(DATA,LOC) ; EP - BQI HMS LOCATION TRIGGER
+1 ;
+2 ; Input
+3 ; LOC - Location selected (required)
+4 ; If location has a facility code of 49 or larger enable Other Location
+5 ; and Other Provider
+6 NEW UID,II,CODE,ABLE
+7 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+8 SET DATA=$NAME(^TMP("BQIQOCTR",UID))
+9 KILL @DATA
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRREG D UNWIND^%ZTER"
+12 ;
+13 SET @DATA@(II)="T00008SOURCE^T00001ABLE_FLAG"_$CHAR(30)
+14 SET ABLE="N"
+15 ; Check facility code - if >48 enable Other Location and Other Provider fields
+16 SET CODE=$$GET1^DIQ(9999999.06,LOC,.07,"I")
IF CODE>48
SET ABLE="Y"
+17 ; Other Location
SET II=II+1
SET @DATA@(II)="BKMOL^"_ABLE_$CHAR(30)
+18 ; Other Provider
SET II=II+1
SET @DATA@(II)="BKMOP^"_ABLE_$CHAR(30)
+19 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+20 QUIT
+21 ;
LST(DATA,FAKE) ;EP - BQI REGISTER TAB LIST
+1 NEW UID,II,CAT,CLIN,DCIEN,REGIEN,REG
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
SET II=0
+3 SET DATA=$NAME(^TMP("BQIRGLST",UID))
+4 KILL @DATA
+5 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGLST D UNWIND^%ZTER"
+6 ;
+7 SET @DATA@(II)="T00030REGISTER^I00010REG_IEN^T00030REMINDER_CATEGORY^T00030REMINDER_CLIN_GROUP"_$CHAR(30)
+8 ;
+9 SET DCIEN=0
+10 FOR
SET DCIEN=$ORDER(^BQI(90507,DCIEN))
IF 'DCIEN
QUIT
Begin DoDot:1
+11 SET REG=$$GET1^DIQ(90507,DCIEN_",",.01,"E")
+12 SET REGIEN=+$$GET1^DIQ(90507,DCIEN_",",.16,"I")
+13 IF 'REGIEN
QUIT
+14 SET CAT=$$GET1^DIQ(90507,DCIEN_",",4.01,"E")
+15 SET CLIN=$$GET1^DIQ(90507,DCIEN_",",4.02,"E")
+16 SET II=II+1
SET @DATA@(II)=REG_U_DCIEN_U_CAT_U_CLIN_$CHAR(30)
End DoDot:1
+17 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+18 QUIT
+19 ;
HMS(BQIDFN) ;EP - Return HMS record IENS
+1 NEW BQRIEN,HIVIEN,IENS,DA
+2 SET BQRIEN=$$BKMIEN^BKMIXX3(BQIDFN)
IF BQRIEN=""
QUIT ""
+3 SET HIVIEN=$$HIVIEN^BKMIXX3()
IF HIVIEN=""
QUIT ""
+4 SET DA(1)=BQRIEN
SET DA=HIVIEN
+5 QUIT $$IENS^DILF(.DA)
