BQISNOMS ;GDHS/HCSD/ALA-SNOMED Subsets ; 19 Dec 2016 1:28 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;;
;
SN ;EP - Count entries in each subset
K ^XTMP("BQISUBS")
S ^XTMP("BQISUBS",0)=$$FMADD^XLFDT(DT,10)_U_DT_U_"List of SNOMED Subsets"
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 BQISBST=$NA(^TMP("BQISNSB",$J)) K @BQISBST
. S BQISUB=$P(@BQILIST@(BSN),"^",1)
. S OK=$$SUBLST^BSTSAPI(BQISBST,BQISUB_"^36^1")
. S BQSN=0,CNT=0
. F S BQSN=$O(@BQISBST@(BQSN)) Q:BQSN="" S CNT=CNT+1
. S ^XTMP("BQISUBS",BQISUB)=CNT
Q
;
LST(DATA,FAKE) ;EP - BQI GET SNOMED SUBSETS
NEW UID,II,BSN,BQILIST,NUM
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQISNLST",UID))
K @DATA
;
S II=0
S HDR="T00075SUBSET^T00010NUM_ITEMS",@DATA@(II)=HDR_$C(30)
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S BQILIST=$NA(^TMP("BQISLST",UID)) K @BQILIST
D SUBSET^BSTSAPIA(BQILIST,"36^1")
S BSN=0
F S BSN=$O(@BQILIST@(BSN)) Q:BSN="" D
. S NAME=@BQILIST@(BSN)
. S NUM=$G(^XTMP("BQISUBS",NAME)) I NUM'<5000 Q
. I NUM="" Q
. S II=II+1,@DATA@(II)=NAME_U_" ["_NUM_"]"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ITM(DATA,BQISUB) ;EP - BQI GET SNOMED SUBSET ITEMS
NEW UID,II,BQISBST
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQISNLST",UID))
K @DATA
;
S II=0
S HDR="T00100ID^T00245NAME"
S @DATA@(II)=HDR_$C(30)
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S BQISBST=$NA(^TMP("BQISNSB",UID)) K @BQISBST
S OK=$$SUBLST^BSTSAPI(BQISBST,BQISUB_"^36^1")
S BQSN=0,CNT=0
F S BQSN=$O(@BQISBST@(BQSN)) Q:BQSN="" D
. S CDATA=@BQISBST@(BQSN)
. S CID=$P(CDATA,"^",1),TXT=$P(CDATA,"^",3)
. I '$D(^AUPNPROB("ASCT",CID)) S CID="@"_CID
. S II=II+1,@DATA@(II)=CID_"^"_TXT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
BQISNOMS ;GDHS/HCSD/ALA-SNOMED Subsets ; 19 Dec 2016 1:28 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;;
+3 ;
SN ;EP - Count entries in each subset
+1 KILL ^XTMP("BQISUBS")
+2 SET ^XTMP("BQISUBS",0)=$$FMADD^XLFDT(DT,10)_U_DT_U_"List of SNOMED Subsets"
+3 SET BQILIST=$NAME(^TMP("BQISNLST",$JOB))
KILL @BQILIST
+4 DO SUBSET^BSTSAPIA(BQILIST,"36^1")
+5 SET BSN=0
+6 FOR
SET BSN=$ORDER(@BQILIST@(BSN))
IF BSN=""
QUIT
Begin DoDot:1
+7 SET BQISBST=$NAME(^TMP("BQISNSB",$JOB))
KILL @BQISBST
+8 SET BQISUB=$PIECE(@BQILIST@(BSN),"^",1)
+9 SET OK=$$SUBLST^BSTSAPI(BQISBST,BQISUB_"^36^1")
+10 SET BQSN=0
SET CNT=0
+11 FOR
SET BQSN=$ORDER(@BQISBST@(BQSN))
IF BQSN=""
QUIT
SET CNT=CNT+1
+12 SET ^XTMP("BQISUBS",BQISUB)=CNT
End DoDot:1
+13 QUIT
+14 ;
LST(DATA,FAKE) ;EP - BQI GET SNOMED SUBSETS
+1 NEW UID,II,BSN,BQILIST,NUM
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQISNLST",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 SET HDR="T00075SUBSET^T00010NUM_ITEMS"
SET @DATA@(II)=HDR_$CHAR(30)
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER"
+9 SET BQILIST=$NAME(^TMP("BQISLST",UID))
KILL @BQILIST
+10 DO SUBSET^BSTSAPIA(BQILIST,"36^1")
+11 SET BSN=0
+12 FOR
SET BSN=$ORDER(@BQILIST@(BSN))
IF BSN=""
QUIT
Begin DoDot:1
+13 SET NAME=@BQILIST@(BSN)
+14 SET NUM=$GET(^XTMP("BQISUBS",NAME))
IF NUM'<5000
QUIT
+15 IF NUM=""
QUIT
+16 SET II=II+1
SET @DATA@(II)=NAME_U_" ["_NUM_"]"_$CHAR(30)
End DoDot:1
+17 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+18 QUIT
+19 ;
ITM(DATA,BQISUB) ;EP - BQI GET SNOMED SUBSET ITEMS
+1 NEW UID,II,BQISBST
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQISNLST",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 SET HDR="T00100ID^T00245NAME"
+8 SET @DATA@(II)=HDR_$CHAR(30)
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITAXX D UNWIND^%ZTER"
+10 SET BQISBST=$NAME(^TMP("BQISNSB",UID))
KILL @BQISBST
+11 SET OK=$$SUBLST^BSTSAPI(BQISBST,BQISUB_"^36^1")
+12 SET BQSN=0
SET CNT=0
+13 FOR
SET BQSN=$ORDER(@BQISBST@(BQSN))
IF BQSN=""
QUIT
Begin DoDot:1
+14 SET CDATA=@BQISBST@(BQSN)
+15 SET CID=$PIECE(CDATA,"^",1)
SET TXT=$PIECE(CDATA,"^",3)
+16 IF '$DATA(^AUPNPROB("ASCT",CID))
SET CID="@"_CID
+17 SET II=II+1
SET @DATA@(II)=CID_"^"_TXT_$CHAR(30)
End DoDot:1
+18 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+19 QUIT
