BQITAXX ;PRXM/HC/ALA-Enter New Taxonomies ; 16 May 2006 10:27 AM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
Q
;
LST(DATA,REG) ; EP -- BQI GET TAXONOMY LIST
; Input
; REG - Retrieves taxonomies for a particular registry.
; If left blank, it retrieves taxonomies for iCare.
;
; Gets the list of taxonomies defined for iCare
;
NEW UID,II,TIEN,TTXT,BQIH,TAXV,X,ID,USER,TXIEN,CAT,CN,PROC,TAXNM,SORT,TAX
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITXLST",UID)),SORT=$NA(^TMP("BQITXSRT",UID))
K @DATA,@SORT
;
S REG=$G(REG,"")
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030REGISTER^T00003USER_EDITABLE"_$C(30)
;
I REG'="" D
. I REG'?.N S REG=$$FIND1^DIC(90507,"","",REG,"B","","")
. D RGS
;
I REG="" D
. D ALL^BQITAXX4
. D ICARE
. D CMET^BTPWTAX
. S REG=0
. F S REG=$O(^BQI(90507,REG)) Q:'REG D
.. I $P(^BQI(90507,REG,0),U,8)=1 Q
.. D RGS
;
S II=0,TAX=""
F S TAX=$O(@SORT@(TAX)) Q:TAX="" D
. S CAT="" F S CAT=$O(@SORT@(TAX,CAT)) Q:CAT="" D
.. S ID="" F S ID=$O(@SORT@(TAX,CAT,ID)) Q:ID="" S II=II+1,@DATA@(II)=@SORT@(TAX,CAT,ID)_$C(30)
;
D SNOM
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
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
;
ICARE ; Get taxonomies for iCare
Q S TTXT="",BQIH=$$SPM^BQIGPUTL()
F S TTXT=$O(^BQI(90508,BQIH,10,"B",TTXT)) Q:TTXT="" D
. S TIEN=""
. F S TIEN=$O(^BQI(90508,BQIH,10,"B",TTXT,TIEN)) Q:TIEN="" D
.. NEW DA,IENS
.. S DA(1)=BQIH,DA=TIEN,IENS=$$IENS^DILF(.DA)
.. S II=II+1
.. S ID=$$GET1^DIQ(90508.03,IENS,.05,"I")
.. S USER=$S(ID="CM":"YES",1:"NO")
.. 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")
.. S TAXN=$$GET1^DIQ(90508.03,IENS,.02,"I"),CAT=$$GET1^DIQ(90508.03,IENS,.03,"E")
.. S SITE=$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO"),ID=$$GET1^DIQ(90508.03,IENS,.05,"E")
.. 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")
.. S REGS=""
.. S @SORT@(TTXT,CAT,ID)=TTXT_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_REGS_U_USER
.. ;S @DATA@(II)=TTXT_"^"_$$GET1^DIQ(90508.03,IENS,.02,"I")_"^"_$$GET1^DIQ(90508.03,IENS,.03,"E")
.. ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")_"^"_$$GET1^DIQ(90508.03,IENS,.05,"E")
.. ;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)
Q
;
RGS ; Get taxonomies for registers
S TIEN=0
F S TIEN=$O(^BQI(90507,REG,10,TIEN)) Q:'TIEN D
. NEW DA,IENS
. S DA(1)=REG,DA=TIEN,IENS=$$IENS^DILF(.DA)
. S ID=$$GET1^DIQ(90507.01,IENS,.05,"I"),TTXT=$$GET1^DIQ(90507.01,IENS,.01,"E")
. S USER=$S(ID="CM":"YES",1:"NO")
. I ID="CM" S TXIEN=$O(^ATXAX("B",TTXT,"")) I TTXT'="" S USER=$S(DUZ=$P(^ATXAX(TXIEN,0),U,5):"YES",1:"NO")
. ;S BQITAX(TAXNM,CAT,ID)=TAXNM_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_U_USER
. S TAXN=$$GET1^DIQ(90507.01,IENS,.02,"I"),CAT=$$GET1^DIQ(90507.01,IENS,.03,"E")
. S SITE=$S($$GET1^DIQ(90507.01,IENS,.04,"I")=1:"YES",1:"NO"),ID=$$GET1^DIQ(90507.01,IENS,.05,"E")
. 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")
. S REGS=$$GET1^DIQ(90507,REG_",",.01,"E")
. S @SORT@(TTXT,CAT,ID)=TTXT_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_REGS_U_USER
. ;S @DATA@(II)=TTXT_"^"_$$GET1^DIQ(90507.01,IENS,.02,"I")_"^"_$$GET1^DIQ(90507.01,IENS,.03,"E")
. ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90507.01,IENS,.04,"I")=1:"YES",1:"NO")_"^"_$$GET1^DIQ(90507.01,IENS,.05,"E")
. ;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)
Q
;
SNOM ;EP - Get SNOMED subsets
;NEW BQILIST,BSN
S BQILIST=$NA(^TMP("BQISNLST",$J)) K @BQILIST
D SUBSET^BSTSAPIA(BQILIST,"36^1")
S BSN=0
F S BSN=$O(@BQILIST@(BSN)) Q:BSN="" D
. S II=II+1
. S @DATA@(II)=@BQILIST@(BSN)_"^"_@BQILIST@(BSN)_";BSTS^SNOMED Subset^NO^SNOMED Subset^YES^^NO"_$C(30)
K @BQILIST
Q
;
ENTRS(TAXV) ;EP - Find if any entries in a taxonomy
;
;Input
; TAXV - Taxonomy internal entry number
;
NEW IEN,GLOBAL
I TAXV="" Q 0
S IEN=$P(TAXV,";",1),GLOBAL="^"_$P(TAXV,";",2)_IEN_")"
I $O(@GLOBAL@(21,0))'="" Q 1
Q 0
;
GREF(VAL) ; EP - Returns the file number
NEW GL,FILN
S GL="^"_$P(VAL,";",2)_"0)"
S FILN=$P($G(@GL),U,2)
S FILN=$$STRIP^XLFSTR(FILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q FILN
BQITAXX ;PRXM/HC/ALA-Enter New Taxonomies ; 16 May 2006 10:27 AM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 QUIT
+4 ;
LST(DATA,REG) ; EP -- BQI GET TAXONOMY LIST
+1 ; Input
+2 ; REG - Retrieves taxonomies for a particular registry.
+3 ; If left blank, it retrieves taxonomies for iCare.
+4 ;
+5 ; Gets the list of taxonomies defined for iCare
+6 ;
+7 NEW UID,II,TIEN,TTXT,BQIH,TAXV,X,ID,USER,TXIEN,CAT,CN,PROC,TAXNM,SORT,TAX
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("BQITXLST",UID))
SET SORT=$NAME(^TMP("BQITXSRT",UID))
+10 KILL @DATA,@SORT
+11 ;
+12 SET REG=$GET(REG,"")
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER"
+15 ;
+16 SET @DATA@(II)="T00030TAXONOMY_NAME^T00015TAXONOMY_IEN^T00020TAX_CATEGORY^T00003TAX_SITE_DEFINED^T00030TAX_ID^T00003TAX_ITEMS^T00030REGISTER^T00003USER_EDITABLE"_$CHAR(30)
+17 ;
+18 IF REG'=""
Begin DoDot:1
+19 IF REG'?.N
SET REG=$$FIND1^DIC(90507,"","",REG,"B","","")
+20 DO RGS
End DoDot:1
+21 ;
+22 IF REG=""
Begin DoDot:1
+23 DO ALL^BQITAXX4
+24 DO ICARE
+25 DO CMET^BTPWTAX
+26 SET REG=0
+27 FOR
SET REG=$ORDER(^BQI(90507,REG))
IF 'REG
QUIT
Begin DoDot:2
+28 IF $PIECE(^BQI(90507,REG,0),U,8)=1
QUIT
+29 DO RGS
End DoDot:2
End DoDot:1
+30 ;
+31 SET II=0
SET TAX=""
+32 FOR
SET TAX=$ORDER(@SORT@(TAX))
IF TAX=""
QUIT
Begin DoDot:1
+33 SET CAT=""
FOR
SET CAT=$ORDER(@SORT@(TAX,CAT))
IF CAT=""
QUIT
Begin DoDot:2
+34 SET ID=""
FOR
SET ID=$ORDER(@SORT@(TAX,CAT,ID))
IF ID=""
QUIT
SET II=II+1
SET @DATA@(II)=@SORT@(TAX,CAT,ID)_$CHAR(30)
End DoDot:2
End DoDot:1
+35 ;
+36 DO SNOM
+37 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
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 ;
ICARE ; Get taxonomies for iCare
+1 QUIT
SET TTXT=""
SET BQIH=$$SPM^BQIGPUTL()
+2 FOR
SET TTXT=$ORDER(^BQI(90508,BQIH,10,"B",TTXT))
IF TTXT=""
QUIT
Begin DoDot:1
+3 SET TIEN=""
+4 FOR
SET TIEN=$ORDER(^BQI(90508,BQIH,10,"B",TTXT,TIEN))
IF TIEN=""
QUIT
Begin DoDot:2
+5 NEW DA,IENS
+6 SET DA(1)=BQIH
SET DA=TIEN
SET IENS=$$IENS^DILF(.DA)
+7 SET II=II+1
+8 SET ID=$$GET1^DIQ(90508.03,IENS,.05,"I")
+9 SET USER=$SELECT(ID="CM":"YES",1:"NO")
+10 IF ID="CM"
SET TXIEN=$ORDER(^ATXAX("B",TTXT,""))
SET USER="NO"
IF TXIEN'=""
SET USER=$SELECT(DUZ=$PIECE(^ATXAX(TXIEN,0),U,5):"YES",1:"NO")
+11 SET TAXN=$$GET1^DIQ(90508.03,IENS,.02,"I")
SET CAT=$$GET1^DIQ(90508.03,IENS,.03,"E")
+12 SET SITE=$SELECT($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")
SET ID=$$GET1^DIQ(90508.03,IENS,.05,"E")
+13 SET ITEM=$SELECT($$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")
+14 SET REGS=""
+15 SET @SORT@(TTXT,CAT,ID)=TTXT_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_REGS_U_USER
+16 ;S @DATA@(II)=TTXT_"^"_$$GET1^DIQ(90508.03,IENS,.02,"I")_"^"_$$GET1^DIQ(90508.03,IENS,.03,"E")
+17 ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90508.03,IENS,.04,"I")=1:"YES",1:"NO")_"^"_$$GET1^DIQ(90508.03,IENS,.05,"E")
+18 ;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)
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
RGS ; Get taxonomies for registers
+1 SET TIEN=0
+2 FOR
SET TIEN=$ORDER(^BQI(90507,REG,10,TIEN))
IF 'TIEN
QUIT
Begin DoDot:1
+3 NEW DA,IENS
+4 SET DA(1)=REG
SET DA=TIEN
SET IENS=$$IENS^DILF(.DA)
+5 SET ID=$$GET1^DIQ(90507.01,IENS,.05,"I")
SET TTXT=$$GET1^DIQ(90507.01,IENS,.01,"E")
+6 SET USER=$SELECT(ID="CM":"YES",1:"NO")
+7 IF ID="CM"
SET TXIEN=$ORDER(^ATXAX("B",TTXT,""))
IF TTXT'=""
SET USER=$SELECT(DUZ=$PIECE(^ATXAX(TXIEN,0),U,5):"YES",1:"NO")
+8 ;S BQITAX(TAXNM,CAT,ID)=TAXNM_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_U_USER
+9 SET TAXN=$$GET1^DIQ(90507.01,IENS,.02,"I")
SET CAT=$$GET1^DIQ(90507.01,IENS,.03,"E")
+10 SET SITE=$SELECT($$GET1^DIQ(90507.01,IENS,.04,"I")=1:"YES",1:"NO")
SET ID=$$GET1^DIQ(90507.01,IENS,.05,"E")
+11 SET ITEM=$SELECT($$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")
+12 SET REGS=$$GET1^DIQ(90507,REG_",",.01,"E")
+13 SET @SORT@(TTXT,CAT,ID)=TTXT_U_TAXN_U_CAT_U_SITE_U_ID_U_ITEM_U_REGS_U_USER
+14 ;S @DATA@(II)=TTXT_"^"_$$GET1^DIQ(90507.01,IENS,.02,"I")_"^"_$$GET1^DIQ(90507.01,IENS,.03,"E")
+15 ;S @DATA@(II)=@DATA@(II)_"^"_$S($$GET1^DIQ(90507.01,IENS,.04,"I")=1:"YES",1:"NO")_"^"_$$GET1^DIQ(90507.01,IENS,.05,"E")
+16 ;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)
End DoDot:1
+17 QUIT
+18 ;
SNOM ;EP - Get SNOMED subsets
+1 ;NEW BQILIST,BSN
+2 SET BQILIST=$NAME(^TMP("BQISNLST",$JOB))
KILL @BQILIST
+3 DO SUBSET^BSTSAPIA(BQILIST,"36^1")
+4 SET BSN=0
+5 FOR
SET BSN=$ORDER(@BQILIST@(BSN))
IF BSN=""
QUIT
Begin DoDot:1
+6 SET II=II+1
+7 SET @DATA@(II)=@BQILIST@(BSN)_"^"_@BQILIST@(BSN)_";BSTS^SNOMED Subset^NO^SNOMED Subset^YES^^NO"_$CHAR(30)
End DoDot:1
+8 KILL @BQILIST
+9 QUIT
+10 ;
ENTRS(TAXV) ;EP - Find if any entries in a taxonomy
+1 ;
+2 ;Input
+3 ; TAXV - Taxonomy internal entry number
+4 ;
+5 NEW IEN,GLOBAL
+6 IF TAXV=""
QUIT 0
+7 SET IEN=$PIECE(TAXV,";",1)
SET GLOBAL="^"_$PIECE(TAXV,";",2)_IEN_")"
+8 IF $ORDER(@GLOBAL@(21,0))'=""
QUIT 1
+9 QUIT 0
+10 ;
GREF(VAL) ; EP - Returns the file number
+1 NEW GL,FILN
+2 SET GL="^"_$PIECE(VAL,";",2)_"0)"
+3 SET FILN=$PIECE($GET(@GL),U,2)
+4 SET FILN=$$STRIP^XLFSTR(FILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+5 QUIT FILN
