BQIUTB5 ;GDIT/HS/ALA-Table utilities ; 17 Dec 2014 9:14 AM
;;2.5;ICARE MANAGEMENT SYSTEM;**2**;May 24, 2016;Build 14
;
;
USR(DATA,TYPE,FLAG) ;EP - Go through the User File
;
;Input
; TYPE - "P" is for provider, otherwise it's a regular user
;
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)
;
I TYPE="P" D G DONE
. NEW NAME,IEN,TRMDT
. S NAME=""
. F S NAME=$O(^VA(200,"AK.PROVIDER",NAME)) Q:NAME="" D
.. S IEN=""
.. F S IEN=$O(^VA(200,"AK.PROVIDER",NAME,IEN)) Q:IEN="" D
... I $G(^VA(200,IEN,0))="" Q
... I NAME'=$P(^VA(200,IEN,0),U,1) Q
... I IEN\1'=IEN Q
... I $P(^VA(200,IEN,0),"^",3)="" Q
... I $P($G(^VA(200,IEN,"PS")),U,4)'="",DT'>$P(^("PS"),U,4) 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
... ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0)!(+$P($G(^VA(200,IEN,0)),U,11)'<DT) D
... I $G(FLAG)=1 S NAME=NAME_" ("_$$CLS(IEN)_")"
... 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
;
NEW IEN,NAME,PFLAG,TRMDT
S IEN=.6
F S IEN=$O(^VA(200,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
. ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0)!(+$P($G(^VA(200,IEN,0)),U,11)'<DT) D
. S NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
. I NAME="" Q
. S PFLAG=$S($D(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
. I $G(FLAG)=1 S NAME=NAME_" ("_$$CLS(IEN)_")"
. S TRMDT=+$P($G(^VA(200,IEN,0)),U,11)
. I TRMDT=0 D SAV1 Q
. I TRMDT'>DT D SAV1 Q
. I TRMDT>DT D SAV1 Q
S II=II+1,@DATA@(II)=$C(31)
Q
;
SAV ;EP - Save record
S II=II+1,@DATA@(II)=IEN_"^"_NAME_$C(30)
Q
;
SAV1 ;EP - Save record
S II=II+1,@DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$C(30)
Q
;
PRCL(DATA) ;EP - Get providers with class
D USR(.DATA,"P",1)
Q
;
USCL(DATA) ;EP - Get users with class
D USR(.DATA,"",1)
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
;
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
;
LOC(DATA,FLAG) ;EP - Get table of hospital locations
S II=0
S LENGTH=$$GET1^DID(44,.01,"","FIELD LENGTH","TEST1","ERR")
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S @DATA@(II)="I00010IEN^T"_DLEN_"^T00002CLIN_CODE"_$C(30)
S IEN=0
F S IEN=$O(^SC(IEN)) Q:'IEN D
. I $G(^SC(IEN,0))="" Q
. ; If the clinic is inactive, show it with a '*'
. I FLAG,$P($G(^SC(IEN,"I")),U,1)'="",$P($G(^SC(IEN,"I")),U,1)'>DT,$P($G(^SC(IEN,"I")),U,2)="" S II=II+1,@DATA@(II)=IEN_"^"_$$GET1^DIQ(44,IEN_",",.01,"E")_" *"_$C(30) Q
. I 'FLAG,$P($G(^SC(IEN,"I")),U,1)'="",$P($G(^SC(IEN,"I")),U,1)'>DT,$P($G(^SC(IEN,"I")),U,2)="" Q
. S II=II+1,@DATA@(II)=IEN_"^"_$$GET1^DIQ(44,IEN_",",.01,"E")_"^"_$$PTR^BQIUL2(44,8,$$GET1^DIQ(44,IEN_",",8,"I"),1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
FH80(DATA) ;EP - Get the Family History Version Subset of File 80
NEW IEN,II
S II=0
S @DATA@(II)="I00010IEN^T00127"_$C(30)
;
I $O(^XTMP("BQIFHDX",0))="" D FHDX^BQINIGH1
S IEN=0
F S IEN=$O(^XTMP("BQIFHDX",IEN)) Q:'IEN D
. S II=II+1,@DATA@(II)=^XTMP("BQIFHDX",IEN)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
FHREL(DATA) ;EP - Get the Family History Version Subset of File 9999999.36
;
NEW IEN,II,REL
;
S II=0
;
S @DATA@(II)="I00010IEN^T00070"_$C(30)
;
S REL="" F S REL=$O(^AUTTRLSH("B",REL)) Q:REL="" S IEN="" F S IEN=$O(^AUTTRLSH("B",REL,IEN)) Q:'IEN D
. N N,PCC
. S N=$G(^AUTTRLSH(IEN,0))
. I $P(N,U,6)=1 Q ; Quit if inactive
. S PCC=$P($G(^AUTTRLSH(IEN,21)),U) Q:PCC'=1 ;Filter on USE FOR PCC FAMILY HISTORY field
. S II=II+1,@DATA@(II)=IEN_U_$P(N,U)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
DONE S II=II+1,@DATA@(II)=$C(31)
Q
BQIUTB5 ;GDIT/HS/ALA-Table utilities ; 17 Dec 2014 9:14 AM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**2**;May 24, 2016;Build 14
+2 ;
+3 ;
USR(DATA,TYPE,FLAG) ;EP - Go through the User File
+1 ;
+2 ;Input
+3 ; TYPE - "P" is for provider, otherwise it's a regular user
+4 ;
+5 SET II=0
+6 SET LENGTH=$$GET1^DID(200,.01,"","FIELD LENGTH","TEST1","ERR")
+7 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+8 SET @DATA@(II)="I00010IEN^T"_DLEN_"^T00001PROVIDER"_$CHAR(30)
+9 ;
+10 IF TYPE="P"
Begin DoDot:1
+11 NEW NAME,IEN,TRMDT
+12 SET NAME=""
+13 FOR
SET NAME=$ORDER(^VA(200,"AK.PROVIDER",NAME))
IF NAME=""
QUIT
Begin DoDot:2
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^VA(200,"AK.PROVIDER",NAME,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+16 IF $GET(^VA(200,IEN,0))=""
QUIT
+17 IF NAME'=$PIECE(^VA(200,IEN,0),U,1)
QUIT
+18 IF IEN\1'=IEN
QUIT
+19 IF $PIECE(^VA(200,IEN,0),"^",3)=""
QUIT
+20 IF $PIECE($GET(^VA(200,IEN,"PS")),U,4)'=""
IF DT'>$PIECE(^("PS"),U,4)
QUIT
+21 ;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
+22 ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0)!(+$P($G(^VA(200,IEN,0)),U,11)'<DT) D
+23 IF $GET(FLAG)=1
SET NAME=NAME_" ("_$$CLS(IEN)_")"
+24 SET TRMDT=+$PIECE($GET(^VA(200,IEN,0)),U,11)
+25 IF TRMDT=0
DO SAV
QUIT
+26 IF TRMDT'>DT
DO SAV
QUIT
+27 IF TRMDT>DT
DO SAV
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
GOTO DONE
+28 ;
+29 NEW IEN,NAME,PFLAG,TRMDT
+30 SET IEN=.6
+31 FOR
SET IEN=$ORDER(^VA(200,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+32 IF $GET(^VA(200,IEN,0))=""
QUIT
+33 IF $PIECE(^VA(200,IEN,0),"^",3)=""
QUIT
+34 IF IEN\1'=IEN
QUIT
+35 ;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
+36 ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0)!(+$P($G(^VA(200,IEN,0)),U,11)'<DT) D
+37 SET NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
+38 IF NAME=""
QUIT
+39 SET PFLAG=$SELECT($DATA(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
+40 IF $GET(FLAG)=1
SET NAME=NAME_" ("_$$CLS(IEN)_")"
+41 SET TRMDT=+$PIECE($GET(^VA(200,IEN,0)),U,11)
+42 IF TRMDT=0
DO SAV1
QUIT
+43 IF TRMDT'>DT
DO SAV1
QUIT
+44 IF TRMDT>DT
DO SAV1
QUIT
End DoDot:1
+45 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+46 QUIT
+47 ;
SAV ;EP - Save record
+1 SET II=II+1
SET @DATA@(II)=IEN_"^"_NAME_$CHAR(30)
+2 QUIT
+3 ;
SAV1 ;EP - Save record
+1 SET II=II+1
SET @DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$CHAR(30)
+2 QUIT
+3 ;
PRCL(DATA) ;EP - Get providers with class
+1 DO USR(.DATA,"P",1)
+2 QUIT
+3 ;
USCL(DATA) ;EP - Get users with class
+1 DO USR(.DATA,"",1)
+2 QUIT
+3 ;
COMM(DATA,FILE,FLAG) ;EP - Get the Community Table
+1 NEW CIEN
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00050^T00005COUNT"_$CHAR(30)
+4 ;
+5 IF $ORDER(^XTMP("BQICOMM",0))=""
DO COMM^BQINIGH1
+6 SET CIEN=0
+7 FOR
SET CIEN=$ORDER(^XTMP("BQICOMM",CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+8 IF 'FLAG
IF $PIECE(^XTMP("BQICOMM",CIEN),U,3)=0
QUIT
+9 SET II=II+1
SET @DATA@(II)=^XTMP("BQICOMM",CIEN)_$CHAR(30)
End DoDot:1
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 QUIT
+12 ;
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))
End DoDot:1
+6 QUIT TYPE
+7 ;
LOC(DATA,FLAG) ;EP - Get table of hospital locations
+1 SET II=0
+2 SET LENGTH=$$GET1^DID(44,.01,"","FIELD LENGTH","TEST1","ERR")
+3 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+4 SET @DATA@(II)="I00010IEN^T"_DLEN_"^T00002CLIN_CODE"_$CHAR(30)
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(^SC(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 IF $GET(^SC(IEN,0))=""
QUIT
+8 ; If the clinic is inactive, show it with a '*'
+9 IF FLAG
IF $PIECE($GET(^SC(IEN,"I")),U,1)'=""
IF $PIECE($GET(^SC(IEN,"I")),U,1)'>DT
IF $PIECE($GET(^SC(IEN,"I")),U,2)=""
SET II=II+1
SET @DATA@(II)=IEN_"^"_$$GET1^DIQ(44,IEN_",",.01,"E")_" *"_$CHAR(30)
QUIT
+10 IF 'FLAG
IF $PIECE($GET(^SC(IEN,"I")),U,1)'=""
IF $PIECE($GET(^SC(IEN,"I")),U,1)'>DT
IF $PIECE($GET(^SC(IEN,"I")),U,2)=""
QUIT
+11 SET II=II+1
SET @DATA@(II)=IEN_"^"_$$GET1^DIQ(44,IEN_",",.01,"E")_"^"_$$PTR^BQIUL2(44,8,$$GET1^DIQ(44,IEN_",",8,"I"),1)_$CHAR(30)
End DoDot:1
+12 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+13 QUIT
+14 ;
FH80(DATA) ;EP - Get the Family History Version Subset of File 80
+1 NEW IEN,II
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00127"_$CHAR(30)
+4 ;
+5 IF $ORDER(^XTMP("BQIFHDX",0))=""
DO FHDX^BQINIGH1
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^XTMP("BQIFHDX",IEN))
IF 'IEN
QUIT
Begin DoDot:1
+8 SET II=II+1
SET @DATA@(II)=^XTMP("BQIFHDX",IEN)_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
FHREL(DATA) ;EP - Get the Family History Version Subset of File 9999999.36
+1 ;
+2 NEW IEN,II,REL
+3 ;
+4 SET II=0
+5 ;
+6 SET @DATA@(II)="I00010IEN^T00070"_$CHAR(30)
+7 ;
+8 SET REL=""
FOR
SET REL=$ORDER(^AUTTRLSH("B",REL))
IF REL=""
QUIT
SET IEN=""
FOR
SET IEN=$ORDER(^AUTTRLSH("B",REL,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+9 NEW N,PCC
+10 SET N=$GET(^AUTTRLSH(IEN,0))
+11 ; Quit if inactive
IF $PIECE(N,U,6)=1
QUIT
+12 ;Filter on USE FOR PCC FAMILY HISTORY field
SET PCC=$PIECE($GET(^AUTTRLSH(IEN,21)),U)
IF PCC'=1
QUIT
+13 SET II=II+1
SET @DATA@(II)=IEN_U_$PIECE(N,U)_$CHAR(30)
End DoDot:1
+14 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+15 QUIT
+16 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
