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

BQIUTB5.m

Go to the documentation of this file. 
  1. BQIUTB5 ;GDIT/HS/ALA-Table utilities ; 17 Dec 2014  9:14 AM
  1.  ;;2.5;ICARE MANAGEMENT SYSTEM;**2**;May 24, 2016;Build 14
  1.  ;
  1.  ;
  1. USR(DATA,TYPE,FLAG) ;EP - Go through the User File
  1.  ;
  1.  ;Input
  1.  ;  TYPE - "P" is for provider, otherwise it's a regular user
  1.  ;
  1.  S II=0
  1.  S LENGTH=$$GET1^DID(200,.01,"","FIELD LENGTH","TEST1","ERR")
  1.  S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
  1.  S @DATA@(II)="I00010IEN^T"_DLEN_"^T00001PROVIDER"_$C(30)
  1.  ;
  1.  I TYPE="P" D  G DONE
  1.  . NEW NAME,IEN,TRMDT
  1.  . S NAME=""
  1.  . F  S NAME=$O(^VA(200,"AK.PROVIDER",NAME)) Q:NAME=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^VA(200,"AK.PROVIDER",NAME,IEN)) Q:IEN=""  D
  1.  ... I $G(^VA(200,IEN,0))="" Q
  1.  ... I NAME'=$P(^VA(200,IEN,0),U,1) Q
  1.  ... I IEN\1'=IEN Q
  1.  ... I $P(^VA(200,IEN,0),"^",3)="" Q
  1.  ... I $P($G(^VA(200,IEN,"PS")),U,4)'="",DT'>$P(^("PS"),U,4) Q
  1.  ... ;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
  1.  ... ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0)!(+$P($G(^VA(200,IEN,0)),U,11)'<DT) D
  1.  ... I $G(FLAG)=1 S NAME=NAME_" ("_$$CLS(IEN)_")"
  1.  ... S TRMDT=+$P($G(^VA(200,IEN,0)),U,11)
  1.  ... I TRMDT=0 D SAV Q
  1.  ... I TRMDT'>DT D SAV Q
  1.  ... I TRMDT>DT D SAV Q
  1.  ;
  1.  NEW IEN,NAME,PFLAG,TRMDT
  1.  S IEN=.6
  1.  F  S IEN=$O(^VA(200,IEN)) Q:'IEN  D
  1.  . I $G(^VA(200,IEN,0))="" Q
  1.  . I $P(^VA(200,IEN,0),"^",3)="" Q
  1.  . I IEN\1'=IEN Q
  1.  . ;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
  1.  . ;I (+$P($G(^VA(200,IEN,0)),U,11)'>0)!(+$P($G(^VA(200,IEN,0)),U,11)'<DT) D
  1.  . S NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
  1.  . I NAME="" Q
  1.  . S PFLAG=$S($D(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
  1.  . I $G(FLAG)=1 S NAME=NAME_" ("_$$CLS(IEN)_")"
  1.  . S TRMDT=+$P($G(^VA(200,IEN,0)),U,11)
  1.  . I TRMDT=0 D SAV1 Q
  1.  . I TRMDT'>DT D SAV1 Q
  1.  . I TRMDT>DT D SAV1 Q
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. SAV ;EP - Save record
  1.  S II=II+1,@DATA@(II)=IEN_"^"_NAME_$C(30)
  1.  Q
  1.  ;
  1. SAV1 ;EP - Save record
  1.  S II=II+1,@DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$C(30)
  1.  Q
  1.  ;
  1. PRCL(DATA) ;EP - Get providers with class
  1.  D USR(.DATA,"P",1)
  1.  Q
  1.  ;
  1. USCL(DATA) ;EP - Get users with class
  1.  D USR(.DATA,"",1)
  1.  Q
  1.  ;
  1. COMM(DATA,FILE,FLAG) ;EP - Get the Community Table
  1.  NEW CIEN
  1.  S II=0
  1.  S @DATA@(II)="I00010IEN^T00050^T00005COUNT"_$C(30)
  1.  ;
  1.  I $O(^XTMP("BQICOMM",0))="" D COMM^BQINIGH1
  1.  S CIEN=0
  1.  F  S CIEN=$O(^XTMP("BQICOMM",CIEN)) Q:'CIEN  D
  1.  . I 'FLAG,$P(^XTMP("BQICOMM",CIEN),U,3)=0 Q
  1.  . S II=II+1,@DATA@(II)=^XTMP("BQICOMM",CIEN)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CLS(PR) ; Get user classification
  1.  S USN="",TYPE=""
  1.  F  S USN=$O(^USR(8930.3,"B",PR,USN),-1) Q:USN=""  D
  1.  . I '$$CURRENT^USRLM(USN) Q
  1.  . S TYPE=$P(^USR(8930.3,USN,0),U,2)
  1.  . 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))
  1.  Q TYPE
  1.  ;
  1. LOC(DATA,FLAG) ;EP - Get table of hospital locations
  1.  S II=0
  1.  S LENGTH=$$GET1^DID(44,.01,"","FIELD LENGTH","TEST1","ERR")
  1.  S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
  1.  S @DATA@(II)="I00010IEN^T"_DLEN_"^T00002CLIN_CODE"_$C(30)
  1.  S IEN=0
  1.  F  S IEN=$O(^SC(IEN)) Q:'IEN  D
  1.  . I $G(^SC(IEN,0))="" Q
  1.  . ; If the clinic is inactive, show it with a '*'
  1.  . 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
  1.  . 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
  1.  . 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)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. FH80(DATA) ;EP - Get the Family History Version Subset of File 80
  1.  NEW IEN,II
  1.  S II=0
  1.  S @DATA@(II)="I00010IEN^T00127"_$C(30)
  1.  ;
  1.  I $O(^XTMP("BQIFHDX",0))="" D FHDX^BQINIGH1
  1.  S IEN=0
  1.  F  S IEN=$O(^XTMP("BQIFHDX",IEN)) Q:'IEN  D
  1.  . S II=II+1,@DATA@(II)=^XTMP("BQIFHDX",IEN)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. FHREL(DATA) ;EP - Get the Family History Version Subset of File 9999999.36
  1.  ;
  1.  NEW IEN,II,REL
  1.  ;
  1.  S II=0
  1.  ;
  1.  S @DATA@(II)="I00010IEN^T00070"_$C(30)
  1.  ;
  1.  S REL="" F  S REL=$O(^AUTTRLSH("B",REL)) Q:REL=""  S IEN="" F  S IEN=$O(^AUTTRLSH("B",REL,IEN)) Q:'IEN  D
  1.  . N N,PCC
  1.  . S N=$G(^AUTTRLSH(IEN,0))
  1.  . I $P(N,U,6)=1 Q  ; Quit if inactive
  1.  . S PCC=$P($G(^AUTTRLSH(IEN,21)),U) Q:PCC'=1  ;Filter on USE FOR PCC FAMILY HISTORY field
  1.  . S II=II+1,@DATA@(II)=IEN_U_$P(N,U)_$C(30)
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. DONE S II=II+1,@DATA@(II)=$C(31)
  1.  Q