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

BQITAXX.m

Go to the documentation of this file. 
  1. BQITAXX ;PRXM/HC/ALA-Enter New Taxonomies ; 16 May 2006  10:27 AM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  ;
  1.  Q
  1.  ;
  1. LST(DATA,REG) ; EP -- BQI GET TAXONOMY LIST
  1.  ; Input
  1.  ;  REG - Retrieves taxonomies for a particular registry.  
  1.  ;        If left blank, it retrieves taxonomies for iCare.
  1.  ;
  1.  ;  Gets the list of taxonomies defined for iCare
  1.  ;
  1.  NEW UID,II,TIEN,TTXT,BQIH,TAXV,X,ID,USER,TXIEN,CAT,CN,PROC,TAXNM,SORT,TAX
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQITXLST",UID)),SORT=$NA(^TMP("BQITXSRT",UID))
  1.  K @DATA,@SORT
  1.  ;
  1.  S REG=$G(REG,"")
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030REGISTER^T00003USER_EDITABLE"_$C(30)
  1.  ;
  1.  I REG'="" D
  1.  . I REG'?.N S REG=$$FIND1^DIC(90507,"","",REG,"B","","")
  1.  . D RGS
  1.  ;
  1.  I REG="" D
  1.  . D ALL^BQITAXX4
  1.  . D ICARE
  1.  . D CMET^BTPWTAX
  1.  . S REG=0
  1.  . F  S REG=$O(^BQI(90507,REG)) Q:'REG  D
  1.  .. I $P(^BQI(90507,REG,0),U,8)=1 Q
  1.  .. D RGS
  1.  ;
  1.  S II=0,TAX=""
  1.  F  S TAX=$O(@SORT@(TAX)) Q:TAX=""  D
  1.  . S CAT="" F  S CAT=$O(@SORT@(TAX,CAT)) Q:CAT=""  D
  1.  .. S ID="" F  S ID=$O(@SORT@(TAX,CAT,ID)) Q:ID=""  S II=II+1,@DATA@(II)=@SORT@(TAX,CAT,ID)_$C(30)
  1.  ;
  1.  D SNOM
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ICARE ; Get taxonomies for iCare
  1.  Q  S TTXT="",BQIH=$$SPM^BQIGPUTL()
  1.  F  S TTXT=$O(^BQI(90508,BQIH,10,"B",TTXT)) Q:TTXT=""  D
  1.  . S TIEN=""
  1.  . F  S TIEN=$O(^BQI(90508,BQIH,10,"B",TTXT,TIEN)) Q:TIEN=""  D
  1.  .. NEW DA,IENS
  1.  .. S DA(1)=BQIH,DA=TIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S II=II+1
  1.  .. S ID=$$GET1^DIQ(90508.03,IENS,.05,"I")
  1.  .. S USER=$S(ID="CM":"YES",1:"NO")
  1.  .. I ID="CM" S TXIEN=$O(^ATXAX("B",TTXT,"")),USER="NO" I TXIEN'="" S USER=$S(DUZ=$P(^ATXAX(TXIEN,0),U,5):"YES",1:"NO")
  1.  .. S TAXN=$$GET1^DIQ(90508.03,IENS,.02,"I"),CAT=$$GET1^DIQ(90508.03,IENS,.03,"E")
  1.  .. S SITE=$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO"),ID=$$GET1^DIQ(90508.03,IENS,.05,"E")
  1.  .. S ITEM=$S($$GET1^DIQ(90508.03,IENS,.02,"I")="":"MIS",$$GET1^DIQ(90508.03,IENS,.07,"I")=1:"YES",'$$ENTRS($$GET1^DIQ(90508.03,IENS,.02,"I")):"NO",1:"YES")
  1.  .. S REGS=""
  1.  .. S @SORT@(TTXT,CAT,ID)=TTXT_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_REGS_U_USER
  1.  .. ;S @DATA@(II)=TTXT_"^"_$$GET1^DIQ(90508.03,IENS,.02,"I")_"^"_$$GET1^DIQ(90508.03,IENS,.03,"E")
  1.  .. ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")_"^"_$$GET1^DIQ(90508.03,IENS,.05,"E")
  1.  .. ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90508.03,IENS,.02,"I")="":"MIS",$$GET1^DIQ(90508.03,IENS,.07,"I")=1:"YES",'$$ENTRS($$GET1^DIQ(90508.03,IENS,.02,"I")):"NO",1:"YES")_"^^"_USER_$C(30)
  1.  Q
  1.  ;
  1. RGS ; Get taxonomies for registers
  1.  S TIEN=0
  1.  F  S TIEN=$O(^BQI(90507,REG,10,TIEN)) Q:'TIEN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=REG,DA=TIEN,IENS=$$IENS^DILF(.DA)
  1.  . S ID=$$GET1^DIQ(90507.01,IENS,.05,"I"),TTXT=$$GET1^DIQ(90507.01,IENS,.01,"E")
  1.  . S USER=$S(ID="CM":"YES",1:"NO")
  1.  . I ID="CM" S TXIEN=$O(^ATXAX("B",TTXT,"")) I TTXT'="" S USER=$S(DUZ=$P(^ATXAX(TXIEN,0),U,5):"YES",1:"NO")
  1.  . ;S BQITAX(TAXNM,CAT,ID)=TAXNM_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_U_USER
  1.  . S TAXN=$$GET1^DIQ(90507.01,IENS,.02,"I"),CAT=$$GET1^DIQ(90507.01,IENS,.03,"E")
  1.  . S SITE=$S($$GET1^DIQ(90507.01,IENS,.04,"I")=1:"YES",1:"NO"),ID=$$GET1^DIQ(90507.01,IENS,.05,"E")
  1.  . S ITEM=$S($$GET1^DIQ(90507.01,IENS,.02,"I")="":"MIS",$$GET1^DIQ(90507.01,IENS,.06,"I")=1:"YES",'$$ENTRS($$GET1^DIQ(90507.01,IENS,.02,"I")):"NO",1:"YES")
  1.  . S REGS=$$GET1^DIQ(90507,REG_",",.01,"E")
  1.  . S @SORT@(TTXT,CAT,ID)=TTXT_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_REGS_U_USER
  1.  . ;S @DATA@(II)=TTXT_"^"_$$GET1^DIQ(90507.01,IENS,.02,"I")_"^"_$$GET1^DIQ(90507.01,IENS,.03,"E")
  1.  . ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90507.01,IENS,.04,"I")=1:"YES",1:"NO")_"^"_$$GET1^DIQ(90507.01,IENS,.05,"E")
  1.  . ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90507.01,IENS,.02,"I")="":"MIS",$$GET1^DIQ(90507.01,IENS,.06,"I")=1:"YES",'$$ENTRS($$GET1^DIQ(90507.01,IENS,.02,"I")):"NO",1:"YES")_"^"_$$GET1^DIQ(90507,REG_",",.01,"E")_U_USER_$C(30)
  1.  Q
  1.  ;
  1. SNOM ;EP - Get SNOMED subsets
  1.  ;NEW BQILIST,BSN
  1.  S BQILIST=$NA(^TMP("BQISNLST",$J)) K @BQILIST
  1.  D SUBSET^BSTSAPIA(BQILIST,"36^1")
  1.  S BSN=0
  1.  F  S BSN=$O(@BQILIST@(BSN)) Q:BSN=""  D
  1.  . S II=II+1
  1.  . S @DATA@(II)=@BQILIST@(BSN)_"^"_@BQILIST@(BSN)_";BSTS^SNOMED Subset^NO^SNOMED Subset^YES^^NO"_$C(30)
  1.  K @BQILIST
  1.  Q
  1.  ;
  1. ENTRS(TAXV) ;EP - Find if any entries in a taxonomy
  1.  ;
  1.  ;Input
  1.  ;  TAXV - Taxonomy internal entry number
  1.  ;
  1.  NEW IEN,GLOBAL
  1.  I TAXV="" Q 0
  1.  S IEN=$P(TAXV,";",1),GLOBAL="^"_$P(TAXV,";",2)_IEN_")"
  1.  I $O(@GLOBAL@(21,0))'="" Q 1
  1.  Q 0
  1.  ;
  1. GREF(VAL) ; EP - Returns the file number
  1.  NEW GL,FILN
  1.  S GL="^"_$P(VAL,";",2)_"0)"
  1.  S FILN=$P($G(@GL),U,2)
  1.  S FILN=$$STRIP^XLFSTR(FILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  Q FILN