BQIUTB1 ;PRXM/HC/ALA-Table Utilities continued ; 13 Jul 2006 3:47 PM
;;2.5;ICARE MANAGEMENT SYSTEM;**2**;May 24, 2016;Build 14
;
Q
;
SBRG(DATA,REG) ; EP -- BQI GET SUBREGISTERS
;Description
; To return a list of register types for a registry
;Input
; REG - Register IEN from the ICARE REGISTER INDEX file (#90507)
NEW UID,II,FILE,X,FILE,GLBREF,IEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITABLE",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I $G(REG)="" S BMXSEC="No register selected" Q
S @DATA@(II)="I00010SUBREG_IEN^T00030SUBREG_NAME^I00010REG_IEN"_$C(30)
S FILE=$$GET1^DIQ(90507,REG_",",.12,"E")
I FILE="" G DONE
I '$$VFILE^DILFD(FILE) S BMXSEC="Table doesn't exist in RPMS" Q
S GLBREF=$$ROOT^DILFD(FILE,"",1)
;
S IEN=0
F S IEN=$O(@GLBREF@(IEN)) Q:'IEN D
. I $G(@GLBREF@(IEN,0))="" Q
. I $P(@GLBREF@(IEN,0),U,1)="" Q
. S II=II+1
. S @DATA@(II)=IEN_"^"_$P(@GLBREF@(IEN,0),U,1)_"^"_REG_$C(30)
;
DONE S II=II+1,@DATA@(II)=$C(31)
Q
;
REGSTAT(DATA,REG) ; EP -- BQI GET REGISTER STATUS
;
;Description:
; Returns the list of statuses associated with the register selected.
; If no register is passed statuses for all registers will be returned.
;
;RPC: BQI GET REGISTER STATUS
;
;Input:
; REG - Optional register IEN from the ICARE REGISTER INDEX file (#90507)
;
;Output:
; ^TMP("BQIREG",UID,#) = Register ^ status code=description_$C(28)_status code...
; where UID will be either $J or "Z" plus the Task
;
N UID,X,II
S II=0
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIREG",UID))
K @DATA
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S II=II+1,@DATA@(II)="I00010REG_IEN^T00010STATUS_CODE^T00040STATUS_NAME"_$C(30) ;Header
;Retrieve set of codes for Status
S REG=$G(REG)
I REG D SET(REG) G RDNE
S REG=0 F S REG=$O(^BQI(90507,REG)) Q:'REG D SET(REG)
;
RDNE S II=II+1,@DATA@(II)=$C(31)
Q
;
SET(REG) ;EP
N FILE,FIELD,SET,I,PC
I REG=3 D Q
. S II=II+1,@DATA@(II)=REG_"^A^ACTIVE"_$C(30)
. S II=II+1,@DATA@(II)=REG_"^I^INACTIVE"_$C(30)
S FILE=$$GET1^DIQ(90507,REG_",",.15,"E")
S FIELD=$$GET1^DIQ(90507,REG_",",.14,"E")
D FIELD^DID(FILE,.FIELD,,"POINTER","SET")
Q:'$D(SET("POINTER"))
F I=1:1:$L(SET("POINTER"),";") S PC=$P(SET("POINTER"),";",I) I PC'="" D
. S II=II+1,@DATA@(II)=REG_"^"_$TR(PC,":","^")_$C(30)
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
;
DHLP(DATA,DXCN,COL) ;EP -- BQI GET DX CAT HELP TEXT
;
; COL - Width of output (e.g. 132 for 132 character width)
;
NEW UID,II,DXN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITABLE",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S DXCN=$G(DXCN,"")
S COL=$G(COL,"")
S @DATA@(II)="T00010DIAG_IEN^T00040DIAG_CAT^T00015DX_CAT^T01024DESC_TEXT"_$C(30)
;
I DXCN'="" D G DNE
. I DXCN'?.N S DXN=$O(^BQI(90506.2,"B",DXCN,""))
. I DXCN?.N S DXN=DXCN,DXCN=$P(^BQI(90506.2,DXN,0),"^",1)
. D GDATA(DXN,COL)
;
I DXCN="" D
. F S DXCN=$O(^BQI(90506.2,"B",DXCN)) Q:DXCN="" D
.. S DXN=""
.. F S DXN=$O(^BQI(90506.2,"B",DXCN,DXN)) Q:DXN="" D
... I $P(^BQI(90506.2,DXN,0),"^",3)=1 Q
... I $P(^BQI(90506.2,DXN,0),"^",5)=1 Q
... D GDATA(DXN,COL)
DNE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
GDATA(DXN,COL) ;EP - Get tooltip
NEW TEXT,LEN,DXCAT,DC,ARR,I
S DXCAT=$$GET1^DIQ(90506.2,DXN_",",.07,"E")
S DC=0,TEXT=""
S II=II+1
S @DATA@(II)=DXN_"^"_DXCN_"^"_DXCAT_"^"
I COL D S II=II+1,@DATA@(II)=$C(30) Q
.S DC=$O(^BQI(90506.2,DXN,3,DC)) Q:'DC
.S II=II+1,@DATA@(II)=^BQI(90506.2,DXN,3,DC,0)
.F S DC=$O(^BQI(90506.2,DXN,3,DC)) Q:'DC D
.. S TEXT=^BQI(90506.2,DXN,3,DC,0)
.. I TEXT="AND"!(TEXT="OR")!(TEXT?." "1AN1".".E) D UPD Q
.. I $G(@DATA@(II))="AND"!($G(@DATA@(II))="OR") D UPD Q
.. I $L($G(@DATA@(II)))+$L($P(TEXT," "))>COL D UPD Q
.. S LEN=$L(@DATA@(II))+$L(TEXT)
.. I LEN<COL S @DATA@(II)=@DATA@(II)_" "_TEXT Q
.. F I=$L(TEXT," "):-1:1 S LEN=$L(@DATA@(II))+$L($P(TEXT," ",1,I)) I LEN<COL D Q
... S @DATA@(II)=@DATA@(II)_" "_$P(TEXT," ",1,I)_$C(10)
... S II=II+1,@DATA@(II)=$P(TEXT," ",I+1,99)
;
F S DC=$O(^BQI(90506.2,DXN,3,DC)) Q:'DC D
. S II=II+1,@DATA@(II)=^BQI(90506.2,DXN,3,DC,0)_$C(10)
S II=II+1,@DATA@(II)=$C(30)
Q
;
UPD ; Update temporary global
S @DATA@(II)=@DATA@(II)_$C(10)
S II=II+1,@DATA@(II)=TEXT
Q
;
IUSR(DATA,TYPE) ;EP - Retrieve a list of iCare Users/Employer Health Key Holding Users
;
;Input
; TYPE - "I" - All iCare users
; "E" - All Employer Health iCare users
;
S II=0
S LENGTH=$$GET1^DID(200,.01,"","FIELD LENGTH","TEST1","ERR")
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S @DATA@(II)="I00010IEN^T"_DLEN_"^T00001PROVIDER"_$C(30)
;
NEW IEN,NAME,PFLAG,EFLAG,TRMDT
S IEN=0
F S IEN=$O(^BQICARE(IEN)) Q:'IEN D
. I $G(^VA(200,IEN,0))="" Q
. I $P(^VA(200,IEN,0),"^",3)="" Q
. I IEN\1'=IEN Q
. ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0&$P(^(0),U,11)'>DT)!(+$P($G(^VA(200,IEN,0)),U,11)>0&$P(^(0),U,11)>DT) D
. S TRMDT=+$P($G(^VA(200,IEN,0)),U,11)
. I TRMDT=0 D SAV Q
. I TRMDT'>DT D SAV Q
. I TRMDT>DT D SAV Q
S II=II+1,@DATA@(II)=$C(31)
Q
;
SAV ; Save value
S NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
I NAME="" Q
;
;Select only Employer Health iCare users
I TYPE="E",'$D(^XUSEC("BQIZEMPHLTH",IEN)) Q
;
S PFLAG=$S($D(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
S II=II+1,@DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$C(30)
Q
;
INS(DATA) ;EP - Insurance plans
NEW IEN,NAME
S @DATA@(II)="T00060NAME"_$C(30)
S NAME=""
F S NAME=$O(^BQIPAT("AI",NAME)) Q:NAME="" D
. S II=II+1,@DATA@(II)=NAME_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
BQIUTB1 ;PRXM/HC/ALA-Table Utilities continued ; 13 Jul 2006 3:47 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**2**;May 24, 2016;Build 14
+2 ;
+3 QUIT
+4 ;
SBRG(DATA,REG) ; EP -- BQI GET SUBREGISTERS
+1 ;Description
+2 ; To return a list of register types for a registry
+3 ;Input
+4 ; REG - Register IEN from the ICARE REGISTER INDEX file (#90507)
+5 NEW UID,II,FILE,X,FILE,GLBREF,IEN
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BQITABLE",UID))
+8 KILL @DATA
+9 ;
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER"
+12 ;
+13 IF $GET(REG)=""
SET BMXSEC="No register selected"
QUIT
+14 SET @DATA@(II)="I00010SUBREG_IEN^T00030SUBREG_NAME^I00010REG_IEN"_$CHAR(30)
+15 SET FILE=$$GET1^DIQ(90507,REG_",",.12,"E")
+16 IF FILE=""
GOTO DONE
+17 IF '$$VFILE^DILFD(FILE)
SET BMXSEC="Table doesn't exist in RPMS"
QUIT
+18 SET GLBREF=$$ROOT^DILFD(FILE,"",1)
+19 ;
+20 SET IEN=0
+21 FOR
SET IEN=$ORDER(@GLBREF@(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+22 IF $GET(@GLBREF@(IEN,0))=""
QUIT
+23 IF $PIECE(@GLBREF@(IEN,0),U,1)=""
QUIT
+24 SET II=II+1
+25 SET @DATA@(II)=IEN_"^"_$PIECE(@GLBREF@(IEN,0),U,1)_"^"_REG_$CHAR(30)
End DoDot:1
+26 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
REGSTAT(DATA,REG) ; EP -- BQI GET REGISTER STATUS
+1 ;
+2 ;Description:
+3 ; Returns the list of statuses associated with the register selected.
+4 ; If no register is passed statuses for all registers will be returned.
+5 ;
+6 ;RPC: BQI GET REGISTER STATUS
+7 ;
+8 ;Input:
+9 ; REG - Optional register IEN from the ICARE REGISTER INDEX file (#90507)
+10 ;
+11 ;Output:
+12 ; ^TMP("BQIREG",UID,#) = Register ^ status code=description_$C(28)_status code...
+13 ; where UID will be either $J or "Z" plus the Task
+14 ;
+15 NEW UID,X,II
+16 SET II=0
+17 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+18 SET DATA=$NAME(^TMP("BQIREG",UID))
+19 KILL @DATA
+20 ;
+21 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER"
+22 ;Header
SET II=II+1
SET @DATA@(II)="I00010REG_IEN^T00010STATUS_CODE^T00040STATUS_NAME"_$CHAR(30)
+23 ;Retrieve set of codes for Status
+24 SET REG=$GET(REG)
+25 IF REG
DO SET(REG)
GOTO RDNE
+26 SET REG=0
FOR
SET REG=$ORDER(^BQI(90507,REG))
IF 'REG
QUIT
DO SET(REG)
+27 ;
RDNE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
SET(REG) ;EP
+1 NEW FILE,FIELD,SET,I,PC
+2 IF REG=3
Begin DoDot:1
+3 SET II=II+1
SET @DATA@(II)=REG_"^A^ACTIVE"_$CHAR(30)
+4 SET II=II+1
SET @DATA@(II)=REG_"^I^INACTIVE"_$CHAR(30)
End DoDot:1
QUIT
+5 SET FILE=$$GET1^DIQ(90507,REG_",",.15,"E")
+6 SET FIELD=$$GET1^DIQ(90507,REG_",",.14,"E")
+7 DO FIELD^DID(FILE,.FIELD,,"POINTER","SET")
+8 IF '$DATA(SET("POINTER"))
QUIT
+9 FOR I=1:1:$LENGTH(SET("POINTER"),";")
SET PC=$PIECE(SET("POINTER"),";",I)
IF PC'=""
Begin DoDot:1
+10 SET II=II+1
SET @DATA@(II)=REG_"^"_$TRANSLATE(PC,":","^")_$CHAR(30)
End DoDot:1
+11 QUIT
+12 ;
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
+7 ;
DHLP(DATA,DXCN,COL) ;EP -- BQI GET DX CAT HELP TEXT
+1 ;
+2 ; COL - Width of output (e.g. 132 for 132 character width)
+3 ;
+4 NEW UID,II,DXN
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BQITABLE",UID))
+7 KILL @DATA
+8 ;
+9 SET II=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIUTB1 D UNWIND^%ZTER"
+11 SET DXCN=$GET(DXCN,"")
+12 SET COL=$GET(COL,"")
+13 SET @DATA@(II)="T00010DIAG_IEN^T00040DIAG_CAT^T00015DX_CAT^T01024DESC_TEXT"_$CHAR(30)
+14 ;
+15 IF DXCN'=""
Begin DoDot:1
+16 IF DXCN'?.N
SET DXN=$ORDER(^BQI(90506.2,"B",DXCN,""))
+17 IF DXCN?.N
SET DXN=DXCN
SET DXCN=$PIECE(^BQI(90506.2,DXN,0),"^",1)
+18 DO GDATA(DXN,COL)
End DoDot:1
GOTO DNE
+19 ;
+20 IF DXCN=""
Begin DoDot:1
+21 FOR
SET DXCN=$ORDER(^BQI(90506.2,"B",DXCN))
IF DXCN=""
QUIT
Begin DoDot:2
+22 SET DXN=""
+23 FOR
SET DXN=$ORDER(^BQI(90506.2,"B",DXCN,DXN))
IF DXN=""
QUIT
Begin DoDot:3
+24 IF $PIECE(^BQI(90506.2,DXN,0),"^",3)=1
QUIT
+25 IF $PIECE(^BQI(90506.2,DXN,0),"^",5)=1
QUIT
+26 DO GDATA(DXN,COL)
End DoDot:3
End DoDot:2
End DoDot:1
DNE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
GDATA(DXN,COL) ;EP - Get tooltip
+1 NEW TEXT,LEN,DXCAT,DC,ARR,I
+2 SET DXCAT=$$GET1^DIQ(90506.2,DXN_",",.07,"E")
+3 SET DC=0
SET TEXT=""
+4 SET II=II+1
+5 SET @DATA@(II)=DXN_"^"_DXCN_"^"_DXCAT_"^"
+6 IF COL
Begin DoDot:1
+7 SET DC=$ORDER(^BQI(90506.2,DXN,3,DC))
IF 'DC
QUIT
+8 SET II=II+1
SET @DATA@(II)=^BQI(90506.2,DXN,3,DC,0)
+9 FOR
SET DC=$ORDER(^BQI(90506.2,DXN,3,DC))
IF 'DC
QUIT
Begin DoDot:2
+10 SET TEXT=^BQI(90506.2,DXN,3,DC,0)
+11 IF TEXT="AND"!(TEXT="OR")!(TEXT?." "1AN1".".E)
DO UPD
QUIT
+12 IF $GET(@DATA@(II))="AND"!($GET(@DATA@(II))="OR")
DO UPD
QUIT
+13 IF $LENGTH($GET(@DATA@(II)))+$LENGTH($PIECE(TEXT," "))>COL
DO UPD
QUIT
+14 SET LEN=$LENGTH(@DATA@(II))+$LENGTH(TEXT)
+15 IF LEN<COL
SET @DATA@(II)=@DATA@(II)_" "_TEXT
QUIT
+16 FOR I=$LENGTH(TEXT," "):-1:1
SET LEN=$LENGTH(@DATA@(II))+$LENGTH($PIECE(TEXT," ",1,I))
IF LEN<COL
Begin DoDot:3
+17 SET @DATA@(II)=@DATA@(II)_" "_$PIECE(TEXT," ",1,I)_$CHAR(10)
+18 SET II=II+1
SET @DATA@(II)=$PIECE(TEXT," ",I+1,99)
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
SET II=II+1
SET @DATA@(II)=$CHAR(30)
QUIT
+19 ;
+20 FOR
SET DC=$ORDER(^BQI(90506.2,DXN,3,DC))
IF 'DC
QUIT
Begin DoDot:1
+21 SET II=II+1
SET @DATA@(II)=^BQI(90506.2,DXN,3,DC,0)_$CHAR(10)
End DoDot:1
+22 SET II=II+1
SET @DATA@(II)=$CHAR(30)
+23 QUIT
+24 ;
UPD ; Update temporary global
+1 SET @DATA@(II)=@DATA@(II)_$CHAR(10)
+2 SET II=II+1
SET @DATA@(II)=TEXT
+3 QUIT
+4 ;
IUSR(DATA,TYPE) ;EP - Retrieve a list of iCare Users/Employer Health Key Holding Users
+1 ;
+2 ;Input
+3 ; TYPE - "I" - All iCare users
+4 ; "E" - All Employer Health iCare users
+5 ;
+6 SET II=0
+7 SET LENGTH=$$GET1^DID(200,.01,"","FIELD LENGTH","TEST1","ERR")
+8 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+9 SET @DATA@(II)="I00010IEN^T"_DLEN_"^T00001PROVIDER"_$CHAR(30)
+10 ;
+11 NEW IEN,NAME,PFLAG,EFLAG,TRMDT
+12 SET IEN=0
+13 FOR
SET IEN=$ORDER(^BQICARE(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+14 IF $GET(^VA(200,IEN,0))=""
QUIT
+15 IF $PIECE(^VA(200,IEN,0),"^",3)=""
QUIT
+16 IF IEN\1'=IEN
QUIT
+17 ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0&$P(^(0),U,11)'>DT)!(+$P($G(^VA(200,IEN,0)),U,11)>0&$P(^(0),U,11)>DT) D
+18 SET TRMDT=+$PIECE($GET(^VA(200,IEN,0)),U,11)
+19 IF TRMDT=0
DO SAV
QUIT
+20 IF TRMDT'>DT
DO SAV
QUIT
+21 IF TRMDT>DT
DO SAV
QUIT
End DoDot:1
+22 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+23 QUIT
+24 ;
SAV ; Save value
+1 SET NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
+2 IF NAME=""
QUIT
+3 ;
+4 ;Select only Employer Health iCare users
+5 IF TYPE="E"
IF '$DATA(^XUSEC("BQIZEMPHLTH",IEN))
QUIT
+6 ;
+7 SET PFLAG=$SELECT($DATA(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
+8 SET II=II+1
SET @DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$CHAR(30)
+9 QUIT
+10 ;
INS(DATA) ;EP - Insurance plans
+1 NEW IEN,NAME
+2 SET @DATA@(II)="T00060NAME"_$CHAR(30)
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^BQIPAT("AI",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+5 SET II=II+1
SET @DATA@(II)=NAME_$CHAR(30)
End DoDot:1
+6 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+7 QUIT
