BSTSDTS1 ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
DTSSR(OUT,BSTSWS) ;EP-DTS Id Lookup
;
N STYPE,DLIST,NMID,DTSID,STATUS,STS,CONC,RSLT,ERSLT,SKIP
;
S STYPE=$G(BSTSWS("STYPE"))
;
S DLIST=$NA(^TMP("BSTSCMCL",$J))
K @DLIST
;
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
;
S DTSID=$G(BSTSWS("SEARCH"))
;
S BSTSWS("DTSID")=DTSID
;
;Get detail
S STS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
I $G(BSTSWS("DEBUG")) W !!,STS
;
;Skip Check
S SKIP=0
I $G(BSTSWS("ONLYLOAD"))]"" D
. NEW SUB
. S SKIP=1
. S SUB="" F S SUB=$O(@DLIST@(1,"SUB",SUB)) Q:SUB="" I BSTSWS("ONLYLOAD")=$P($G(@DLIST@(1,"SUB",SUB)),U) S SKIP=0
;
;Update anyway if loaded (Skip partials)
I $D(^BSTS(9002318.4,"D",36,DTSID)) D
. NEW CIEN
. S CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,"")) Q:CIEN=""
. I $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P" Q
. S SKIP=0
;
;File
I 'SKIP S STATUS=$$UPDATE^BSTSDTS0(NMID)
;
;Look if now logged
S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)
I CONC]"" S @OUT@(1)=CONC_U_DTSID
;
Q STS
;
TSRCH(OUT,BSTSWS) ;EP-Test Search
;
N II,STS,SEARCH,STYPE,WORD,MAX,DTSID,NMID,CSTS
N BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,TIME,ERR
;
S SEARCH=$G(BSTSWS("SEARCH"))
S STYPE=$G(BSTSWS("STYPE"))
S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
K @DLIST
;
S MAX=$G(BSTSWS("MAXRECS")) S:MAX="" MAX=25
S BSTRT=+$G(BSTSWS("BCTCHRC")) S:BSTRT=0 BSTRT=1
S BSCNT=+$G(BSTSWS("BCTCHCT")) S:BSCNT=0 BSCNT=MAX
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
S BSTSWS("SNAPDT")=$$FMTE^BSTSUTIL(DT_".2400")
;
;Search
S TIME=0,ERR=0,STS=""
;
S BSTSWS("SEARCH")=SEARCH
;
;FSN
S CSTS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES)
;
I $P(CSTS,U,2)]"" S ERR=1
S $P(STS,U)=$P(CSTS,U)
S $P(STS,U,2)=$P(CSTS,U,2)
S $P(STS,U,3)=$P(STS,U,3)+$P(CSTS,U,3)
;
Q STS
;
UUPDATE(NMID,ROUT) ;EP-Add/Update UNII
;
;UNII Only
I $G(NMID)'=5180 Q 1
;
N GL,CONCDA,BSTSC,INMID,ERROR,TCNT,I,CVRSN,ST,NROUT,TLIST,STYPE,RTR
;
S GL=$NA(^TMP("BSTSCMCL",$J,1))
S ROUT=$G(ROUT,"")
;
;Find Concept
I $P($G(@GL@("CONCEPTID")),U)="" Q 0
;
;Existing?
I $G(@GL@("DTSID"))="" Q 0
S CONCDA=$O(^BSTS(9002318.4,"D",NMID,@GL@("DTSID"),""))
;
S INMID=$O(^BSTS(9002318.1,"B",NMID,"")) Q:INMID="" "0"
;
S CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
;
;Retired?
I CONCDA]"",'$$RET^BSTSDTS3(CONCDA,CVRSN,GL) Q 0
;
;None found - create new
I CONCDA="" S CONCDA=$$NEWC^BSTSDTS0()
;
I +CONCDA<0 Q 0
;
S NROUT=$P(@GL@("CONCEPTID"),U,3) S:NROUT="" NROUT=ROUT
;
;Set up top level
S BSTSC(9002318.4,CONCDA_",",.02)=$P(@GL@("CONCEPTID"),U) ;Conc ID
S BSTSC(9002318.4,CONCDA_",",.08)=@GL@("DTSID") ;DTSID
S BSTSC(9002318.4,CONCDA_",",.07)=INMID ;Code Set
S BSTSC(9002318.4,CONCDA_",",.03)="N"
S BSTSC(9002318.4,CONCDA_",",.05)=$$EP2FMDT^BSTSUTIL($P(@GL@("CONCEPTID"),U,2),1)
S BSTSC(9002318.4,CONCDA_",",.06)=$$EP2FMDT^BSTSUTIL(NROUT,1)
S BSTSC(9002318.4,CONCDA_",",.11)="N"
S BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
S BSTSC(9002318.4,CONCDA_",",.12)=DT
S BSTSC(9002318.4,CONCDA_",",1)=$G(@GL@("FSN",1))
;
;Save ISA
I $D(@GL@("ISA"))>1 D
. ;
. N ISACT
. S ISACT="" F S ISACT=$O(@GL@("ISA",ISACT)) Q:ISACT="" D
.. ;
.. ;Save/update each ISA
.. ;
.. ;Already there?
.. N DAISA,DA,IENS,DTSID,ISACD,NEWISA,DIC,Y,X,DLAYGO
.. S ISACD=$P($G(@GL@("ISA",ISACT,0)),U) Q:ISACD=""
.. S (NEWISA,DAISA)=$O(^BSTS(9002318.4,"D",NMID,ISACD,""))
.. ;
.. ;Not found - add partial entry
.. I DAISA="" S DAISA=$$NEWC^BSTSDTS0()
.. S BSTSC(9002318.4,DAISA_",",.08)=$G(ISACD)
.. I NEWISA="" S BSTSC(9002318.4,DAISA_",",.03)="P"
.. S BSTSC(9002318.4,DAISA_",",.07)=INMID ;Code Set
.. S BSTSC(9002318.4,DAISA_",",.04)=CVRSN ;Version
.. S BSTSC(9002318.4,DAISA_",",.11)="N" ;Up to Date
.. S BSTSC(9002318.4,DAISA_",",.12)=DT ;Update Date
.. S BSTSC(9002318.4,DAISA_",",1)=$G(@GL@("ISA",ISACT,1))
.. ;
.. ;Now add IsA pointer
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",5,",X=DAISA
.. S DLAYGO=9002318.45 D ^DIC I +Y<0 Q
.. ;
.. ;Save IsA fields
.. S DA(1)=CONCDA,DA=+Y,IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.45,IENS,".02")=$$EP2FMDT^BSTSUTIL($P($G(@GL@("ISA",ISACT,1,0)),U,2))
;
I $D(BSTSC) D FILE^DIE("","BSTSC","ERROR")
;
;Save Terminology entries
;
;Synonyms/Preferred/FSN
;
S STYPE="" F S STYPE=$O(@GL@("SYN",STYPE)) Q:STYPE="" S TCNT="" F S TCNT=$O(@GL@("SYN",STYPE,TCNT)) Q:TCNT="" D
. ;
. N TERM,TYPE,DESC,BSTST,ERROR,TMIEN,AIN
. ;
. ;Pull values
. S TERM=$G(@GL@("SYN",STYPE,TCNT,1)) Q:TERM=""
. ;
. ;Quit if found
. I $D(TLIST(TERM)) Q
. S TLIST(TERM)=""
. ;
. S TYPE=$P($G(@GL@("SYN",STYPE,TCNT,0)),U,2)
. S TYPE=$S(TYPE=1:"P",1:"S")
. I TERM=$G(@GL@("FSN",1)) S TYPE="F"
. S DESC=$P($G(@GL@("SYN",STYPE,TCNT,0)),U) Q:DESC=""
. S AIN=$$EP2FMDT^BSTSUTIL($P($G(@GL@("SYN",STYPE,TCNT,0)),U,3))
. ;
. ;Look up
. S TMIEN=$O(^BSTS(9002318.3,"D",INMID,DESC,""))
. ;
. ;No entry - create new
. I TMIEN="" S TMIEN=$$NEWT^BSTSDTS0()
. I TMIEN<0 Q
. ;
. ;Save/update fields
. S BSTST(9002318.3,TMIEN_",",.02)=DESC
. S BSTST(9002318.3,TMIEN_",",.09)=TYPE
. S BSTST(9002318.3,TMIEN_",",1)=TERM
. S BSTST(9002318.3,TMIEN_",",.04)="N"
. S BSTST(9002318.3,TMIEN_",",.05)=CVRSN
. S BSTST(9002318.3,TMIEN_",",.08)=INMID
. S BSTST(9002318.3,TMIEN_",",.03)=CONCDA
. S BSTST(9002318.3,TMIEN_",",.06)=AIN
. S BSTST(9002318.3,TMIEN_",",.1)=DT
. S BSTST(9002318.3,TMIEN_",",.11)="N"
. D FILE^DIE("","BSTST","ERROR")
. ;
. ;Reindex - needed for custom indices
. D
.. NEW DIK,DA
.. S DIK="^BSTS(9002318.3,",DA=TMIEN
.. D IX^DIK
;
;Need to check for retired concepts again since it may have just been added
S RTR=$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
;
Q $S($D(ERROR):"0^Update Failed",1:1)
;
RUPDATE(NMID,ROUT) ;EP-Add/Update RXNORM
;
;RXNORM Only
I $G(NMID)'=1552 Q 1
;
N GL,CONCDA,BSTSC,INMID,ERROR,TCNT,I,CVRSN,ST,NROUT,TLIST,STYPE,RTR
;
S GL=$NA(^TMP("BSTSCMCL",$J,1))
S ROUT=$G(ROUT,"")
;
;Look for Concept Id
I $P($G(@GL@("CONCEPTID")),U)="" Q 0
;
;Look for existing
I $G(@GL@("DTSID"))="" Q 0
S CONCDA=$O(^BSTS(9002318.4,"D",NMID,@GL@("DTSID"),""))
;
;Pull internal Code Set ID
S INMID=$O(^BSTS(9002318.1,"B",NMID,"")) Q:INMID="" "0"
;
;Pull the current version
S CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
;
;Retired?
I CONCDA]"",'$$RET^BSTSDTS3(CONCDA,CVRSN,GL) Q 0
;
;None found - create new
I CONCDA="" S CONCDA=$$NEWC^BSTSDTS0()
;
;Verify entry found/created
I +CONCDA<0 Q 0
;
;Get Revision Out
S NROUT=$P(@GL@("CONCEPTID"),U,3) S:NROUT="" NROUT=ROUT
;
;Set up top level
S BSTSC(9002318.4,CONCDA_",",.02)=$P(@GL@("CONCEPTID"),U) ;Conc ID
S BSTSC(9002318.4,CONCDA_",",.08)=@GL@("DTSID") ;DTSID
S BSTSC(9002318.4,CONCDA_",",.07)=INMID ;Code Set
S BSTSC(9002318.4,CONCDA_",",.03)="N"
S BSTSC(9002318.4,CONCDA_",",.05)=$$EP2FMDT^BSTSUTIL($P(@GL@("CONCEPTID"),U,2),1)
S BSTSC(9002318.4,CONCDA_",",.06)=$$EP2FMDT^BSTSUTIL(NROUT,1)
S BSTSC(9002318.4,CONCDA_",",.11)="N"
S BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
S BSTSC(9002318.4,CONCDA_",",.12)=DT
S BSTSC(9002318.4,CONCDA_",",1)=$G(@GL@("FSN",1))
;
;Save ISA
I $D(@GL@("ISA"))>1 D
. ;
. N ISACT
. S ISACT="" F S ISACT=$O(@GL@("ISA",ISACT)) Q:ISACT="" D
.. ;
.. ;Save/update each ISA
.. ;
.. ;First see if IsA code saved
.. N DAISA,DA,IENS,DTSID,ISACD,NEWISA,DIC,Y,X,DLAYGO
.. S ISACD=$P($G(@GL@("ISA",ISACT,0)),U) Q:ISACD=""
.. S (NEWISA,DAISA)=$O(^BSTS(9002318.4,"D",NMID,ISACD,""))
.. ;
.. ;Not found - add partial entry
.. I DAISA="" S DAISA=$$NEWC^BSTSDTS0()
.. S BSTSC(9002318.4,DAISA_",",.08)=$G(ISACD)
.. I NEWISA="" S BSTSC(9002318.4,DAISA_",",.03)="P"
.. S BSTSC(9002318.4,DAISA_",",.07)=INMID ;Code Set
.. S BSTSC(9002318.4,DAISA_",",.04)=CVRSN ;Version
.. S BSTSC(9002318.4,DAISA_",",.11)="N" ;Up to Date
.. S BSTSC(9002318.4,DAISA_",",.12)=DT ;Update Date
.. S BSTSC(9002318.4,DAISA_",",1)=$G(@GL@("ISA",ISACT,1))
.. ;
.. ;Now add IsA pointer in current concept entry
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",5,",X=DAISA
.. S DLAYGO=9002318.45 D ^DIC I +Y<0 Q
.. ;
.. ;Save additional IsA fields
.. S DA(1)=CONCDA,DA=+Y,IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.45,IENS,".02")=$$EP2FMDT^BSTSUTIL($P($G(@GL@("ISA",ISACT,1,0)),U,2))
;
;Save Inverse Associations
;
;Clear out existing entries
D
. NEW AS
. S AS=0 F S AS=$O(^BSTS(9002318.4,CONCDA,11,AS)) Q:'AS D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=AS
.. S DIK="^BSTS(9002318.4,"_DA(1)_",11," D ^DIK
I $D(@GL@("IAS"))>1 D
. ;
. ;
. NEW AS
. S AS="" F S AS=$O(@GL@("IAS",AS)) Q:AS="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",11,"
.. S X=$P($G(@GL@("IAS",AS)),U) Q:X=""
.. S DLAYGO=9002318.411 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.411,IENS,".02")=$P($G(@GL@("IAS",AS)),U,2)
.. S BSTSC(9002318.411,IENS,".03")=$P($G(@GL@("IAS",AS)),U,3)
.. S BSTSC(9002318.411,IENS,".04")=$P($G(@GL@("IAS",AS)),U,4)
;
;Update additional RxNorm fields
D UPRSUB^BSTSDTS5(GL,CONCDA,.BSTSC)
;
;Save the entry
I $D(BSTSC) D FILE^DIE("","BSTSC","ERROR")
;
;Reindex - needed for custom indices
D
. NEW DIK,DA
. S DIK="^BSTS(9002318.4,",DA=CONCDA
. D IX^DIK
;
;Save Terminology entries
;
;Synonyms/Preferred/FSN
;
S STYPE="" F S STYPE=$O(@GL@("SYN",STYPE)) Q:STYPE="" S TCNT="" F S TCNT=$O(@GL@("SYN",STYPE,TCNT)) Q:TCNT="" D
. ;
. N TERM,TYPE,DESC,BSTST,ERROR,TMIEN,AIN
. ;
. ;Pull values
. S TERM=$G(@GL@("SYN",STYPE,TCNT,1)) Q:TERM=""
. ;
. ;Limit to 244
. S TERM=$E(TERM,1,244)
. ;
. ;Quit if found
. I $D(TLIST(TERM)) Q
. S TLIST(TERM)=""
. ;
. S TYPE=$P($G(@GL@("SYN",STYPE,TCNT,0)),U,2)
. S TYPE=$S(TYPE=1:"P",1:"S")
. I TERM=$G(@GL@("FSN",1)) S TYPE="F"
. S DESC=$P($G(@GL@("SYN",STYPE,TCNT,0)),U) Q:DESC=""
. S AIN=$$EP2FMDT^BSTSUTIL($P($G(@GL@("SYN",STYPE,TCNT,0)),U,3))
. ;
. ;Look up entry
. S TMIEN=$O(^BSTS(9002318.3,"D",INMID,DESC,""))
. ;
. ;Entry not found - create new
. I TMIEN="" S TMIEN=$$NEWT^BSTSDTS0()
. I TMIEN<0 Q
. ;
. ;Save/update other fields
. S BSTST(9002318.3,TMIEN_",",.02)=DESC
. S BSTST(9002318.3,TMIEN_",",.09)=TYPE
. S BSTST(9002318.3,TMIEN_",",1)=TERM
. S BSTST(9002318.3,TMIEN_",",.04)="N"
. S BSTST(9002318.3,TMIEN_",",.05)=CVRSN
. S BSTST(9002318.3,TMIEN_",",.08)=INMID
. S BSTST(9002318.3,TMIEN_",",.03)=CONCDA
. S BSTST(9002318.3,TMIEN_",",.06)=AIN
. S BSTST(9002318.3,TMIEN_",",.1)=DT
. S BSTST(9002318.3,TMIEN_",",.11)="N"
. D FILE^DIE("","BSTST","ERROR")
. ;
. ;Reindex - needed for custom indices
. D
.. NEW DIK,DA
.. S DIK="^BSTS(9002318.3,",DA=TMIEN
.. D IX^DIK
;
;Need to check for retired concepts again since it may have just been added
S RTR=$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
;
Q $S($D(ERROR):"0^Update Failed",1:1)
;
DILKP(OUT,BSTSWS) ;EP - DTS4 Search Call - Drug Ingredient Lookup
;
N II,STS,SEARCH,STYPE,MAX,DTSID,NMID
N BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,ST
;
S SEARCH=$G(BSTSWS("SEARCH"))
S STYPE=$G(BSTSWS("STYPE"))
S SLIST=$NA(^TMP("BSTSDET",$J)) ;Sorted List
S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
K @SLIST,@DLIST,@OUT
;
;Determine max to return
S MAX=$G(BSTSWS("MAXRECS")) S:MAX="" MAX=25
S BSTRT=+$G(BSTSWS("BCTCHRC")) S:BSTRT=0 BSTRT=1
S BSCNT=+$G(BSTSWS("BCTCHCT")) S:BSCNT=0 BSCNT=MAX
S NMID=$G(BSTSWS("NAMESPACEID"))
;
;Perform Lookup on Concept Id
S STS=$$PTYDTS4^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS
;
;Sort results (though there should only be one)
S DTSID="" F S DTSID=$O(@DLIST@(DTSID)) Q:DTSID="" S @SLIST@(@DLIST@(DTSID),DTSID)=""
;
;Loop through results and retrieve detail
S II="",RCNT=0 F S II=$O(@SLIST@(II),-1) Q:II="" D Q:RCNT
. S DTSID="" F S DTSID=$O(@SLIST@(II,DTSID)) Q:DTSID="" D Q:RCNT
.. ;
.. N STATUS,CONC,ERSLT
.. ;
.. ;Update entry
.. S BSTSWS("DTSID")=DTSID
.. ;
.. ;Clear result file
.. K @DLIST
.. ;
.. ;Get Detail for concept
.. S STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
.. I $G(BSTSWS("DEBUG")) W !!,"Detail Call Status: ",STATUS
.. ;
.. ;File Detail
.. S STATUS=$$UPDATE^BSTSDTS0(NMID)
.. I $G(BSTSWS("DEBUG")) W !!,"Update Call Status: ",STATUS
.. ;
.. ;Look to see if concept logged
.. S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS,1,1)
.. I CONC]"" D Q
... S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID
;
Q STS
BSTSDTS1 ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
DTSSR(OUT,BSTSWS) ;EP-DTS Id Lookup
+1 ;
+2 NEW STYPE,DLIST,NMID,DTSID,STATUS,STS,CONC,RSLT,ERSLT,SKIP
+3 ;
+4 SET STYPE=$GET(BSTSWS("STYPE"))
+5 ;
+6 SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+7 KILL @DLIST
+8 ;
+9 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+10 ;
+11 SET DTSID=$GET(BSTSWS("SEARCH"))
+12 ;
+13 SET BSTSWS("DTSID")=DTSID
+14 ;
+15 ;Get detail
+16 SET STS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
+17 IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
+18 ;
+19 ;Skip Check
+20 SET SKIP=0
+21 IF $GET(BSTSWS("ONLYLOAD"))]""
Begin DoDot:1
+22 NEW SUB
+23 SET SKIP=1
+24 SET SUB=""
FOR
SET SUB=$ORDER(@DLIST@(1,"SUB",SUB))
IF SUB=""
QUIT
IF BSTSWS("ONLYLOAD")=$PIECE($GET(@DLIST@(1,"SUB",SUB)),U)
SET SKIP=0
End DoDot:1
+25 ;
+26 ;Update anyway if loaded (Skip partials)
+27 IF $DATA(^BSTS(9002318.4,"D",36,DTSID))
Begin DoDot:1
+28 NEW CIEN
+29 SET CIEN=$ORDER(^BSTS(9002318.4,"D",36,DTSID,""))
IF CIEN=""
QUIT
+30 IF $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P"
QUIT
+31 SET SKIP=0
End DoDot:1
+32 ;
+33 ;File
+34 IF 'SKIP
SET STATUS=$$UPDATE^BSTSDTS0(NMID)
+35 ;
+36 ;Look if now logged
+37 SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)
+38 IF CONC]""
SET @OUT@(1)=CONC_U_DTSID
+39 ;
+40 QUIT STS
+41 ;
TSRCH(OUT,BSTSWS) ;EP-Test Search
+1 ;
+2 NEW II,STS,SEARCH,STYPE,WORD,MAX,DTSID,NMID,CSTS
+3 NEW BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,TIME,ERR
+4 ;
+5 SET SEARCH=$GET(BSTSWS("SEARCH"))
+6 SET STYPE=$GET(BSTSWS("STYPE"))
+7 ;DTS Return List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+8 KILL @DLIST
+9 ;
+10 SET MAX=$GET(BSTSWS("MAXRECS"))
IF MAX=""
SET MAX=25
+11 SET BSTRT=+$GET(BSTSWS("BCTCHRC"))
IF BSTRT=0
SET BSTRT=1
+12 SET BSCNT=+$GET(BSTSWS("BCTCHCT"))
IF BSCNT=0
SET BSCNT=MAX
+13 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+14 SET BSTSWS("SNAPDT")=$$FMTE^BSTSUTIL(DT_".2400")
+15 ;
+16 ;Search
+17 SET TIME=0
SET ERR=0
SET STS=""
+18 ;
+19 SET BSTSWS("SEARCH")=SEARCH
+20 ;
+21 ;FSN
+22 SET CSTS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES)
+23 ;
+24 IF $PIECE(CSTS,U,2)]""
SET ERR=1
+25 SET $PIECE(STS,U)=$PIECE(CSTS,U)
+26 SET $PIECE(STS,U,2)=$PIECE(CSTS,U,2)
+27 SET $PIECE(STS,U,3)=$PIECE(STS,U,3)+$PIECE(CSTS,U,3)
+28 ;
+29 QUIT STS
+30 ;
UUPDATE(NMID,ROUT) ;EP-Add/Update UNII
+1 ;
+2 ;UNII Only
+3 IF $GET(NMID)'=5180
QUIT 1
+4 ;
+5 NEW GL,CONCDA,BSTSC,INMID,ERROR,TCNT,I,CVRSN,ST,NROUT,TLIST,STYPE,RTR
+6 ;
+7 SET GL=$NAME(^TMP("BSTSCMCL",$JOB,1))
+8 SET ROUT=$GET(ROUT,"")
+9 ;
+10 ;Find Concept
+11 IF $PIECE($GET(@GL@("CONCEPTID")),U)=""
QUIT 0
+12 ;
+13 ;Existing?
+14 IF $GET(@GL@("DTSID"))=""
QUIT 0
+15 SET CONCDA=$ORDER(^BSTS(9002318.4,"D",NMID,@GL@("DTSID"),""))
+16 ;
+17 SET INMID=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF INMID=""
QUIT "0"
+18 ;
+19 SET CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
+20 ;
+21 ;Retired?
+22 IF CONCDA]""
IF '$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
QUIT 0
+23 ;
+24 ;None found - create new
+25 IF CONCDA=""
SET CONCDA=$$NEWC^BSTSDTS0()
+26 ;
+27 IF +CONCDA<0
QUIT 0
+28 ;
+29 SET NROUT=$PIECE(@GL@("CONCEPTID"),U,3)
IF NROUT=""
SET NROUT=ROUT
+30 ;
+31 ;Set up top level
+32 ;Conc ID
SET BSTSC(9002318.4,CONCDA_",",.02)=$PIECE(@GL@("CONCEPTID"),U)
+33 ;DTSID
SET BSTSC(9002318.4,CONCDA_",",.08)=@GL@("DTSID")
+34 ;Code Set
SET BSTSC(9002318.4,CONCDA_",",.07)=INMID
+35 SET BSTSC(9002318.4,CONCDA_",",.03)="N"
+36 SET BSTSC(9002318.4,CONCDA_",",.05)=$$EP2FMDT^BSTSUTIL($PIECE(@GL@("CONCEPTID"),U,2),1)
+37 SET BSTSC(9002318.4,CONCDA_",",.06)=$$EP2FMDT^BSTSUTIL(NROUT,1)
+38 SET BSTSC(9002318.4,CONCDA_",",.11)="N"
+39 SET BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
+40 SET BSTSC(9002318.4,CONCDA_",",.12)=DT
+41 SET BSTSC(9002318.4,CONCDA_",",1)=$GET(@GL@("FSN",1))
+42 ;
+43 ;Save ISA
+44 IF $DATA(@GL@("ISA"))>1
Begin DoDot:1
+45 ;
+46 NEW ISACT
+47 SET ISACT=""
FOR
SET ISACT=$ORDER(@GL@("ISA",ISACT))
IF ISACT=""
QUIT
Begin DoDot:2
+48 ;
+49 ;Save/update each ISA
+50 ;
+51 ;Already there?
+52 NEW DAISA,DA,IENS,DTSID,ISACD,NEWISA,DIC,Y,X,DLAYGO
+53 SET ISACD=$PIECE($GET(@GL@("ISA",ISACT,0)),U)
IF ISACD=""
QUIT
+54 SET (NEWISA,DAISA)=$ORDER(^BSTS(9002318.4,"D",NMID,ISACD,""))
+55 ;
+56 ;Not found - add partial entry
+57 IF DAISA=""
SET DAISA=$$NEWC^BSTSDTS0()
+58 SET BSTSC(9002318.4,DAISA_",",.08)=$GET(ISACD)
+59 IF NEWISA=""
SET BSTSC(9002318.4,DAISA_",",.03)="P"
+60 ;Code Set
SET BSTSC(9002318.4,DAISA_",",.07)=INMID
+61 ;Version
SET BSTSC(9002318.4,DAISA_",",.04)=CVRSN
+62 ;Up to Date
SET BSTSC(9002318.4,DAISA_",",.11)="N"
+63 ;Update Date
SET BSTSC(9002318.4,DAISA_",",.12)=DT
+64 SET BSTSC(9002318.4,DAISA_",",1)=$GET(@GL@("ISA",ISACT,1))
+65 ;
+66 ;Now add IsA pointer
+67 SET DA(1)=CONCDA
+68 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",5,"
SET X=DAISA
+69 SET DLAYGO=9002318.45
DO ^DIC
IF +Y<0
QUIT
+70 ;
+71 ;Save IsA fields
+72 SET DA(1)=CONCDA
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+73 SET BSTSC(9002318.45,IENS,".02")=$$EP2FMDT^BSTSUTIL($PIECE($GET(@GL@("ISA",ISACT,1,0)),U,2))
End DoDot:2
End DoDot:1
+74 ;
+75 IF $DATA(BSTSC)
DO FILE^DIE("","BSTSC","ERROR")
+76 ;
+77 ;Save Terminology entries
+78 ;
+79 ;Synonyms/Preferred/FSN
+80 ;
+81 SET STYPE=""
FOR
SET STYPE=$ORDER(@GL@("SYN",STYPE))
IF STYPE=""
QUIT
SET TCNT=""
FOR
SET TCNT=$ORDER(@GL@("SYN",STYPE,TCNT))
IF TCNT=""
QUIT
Begin DoDot:1
+82 ;
+83 NEW TERM,TYPE,DESC,BSTST,ERROR,TMIEN,AIN
+84 ;
+85 ;Pull values
+86 SET TERM=$GET(@GL@("SYN",STYPE,TCNT,1))
IF TERM=""
QUIT
+87 ;
+88 ;Quit if found
+89 IF $DATA(TLIST(TERM))
QUIT
+90 SET TLIST(TERM)=""
+91 ;
+92 SET TYPE=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,2)
+93 SET TYPE=$SELECT(TYPE=1:"P",1:"S")
+94 IF TERM=$GET(@GL@("FSN",1))
SET TYPE="F"
+95 SET DESC=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U)
IF DESC=""
QUIT
+96 SET AIN=$$EP2FMDT^BSTSUTIL($PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,3))
+97 ;
+98 ;Look up
+99 SET TMIEN=$ORDER(^BSTS(9002318.3,"D",INMID,DESC,""))
+100 ;
+101 ;No entry - create new
+102 IF TMIEN=""
SET TMIEN=$$NEWT^BSTSDTS0()
+103 IF TMIEN<0
QUIT
+104 ;
+105 ;Save/update fields
+106 SET BSTST(9002318.3,TMIEN_",",.02)=DESC
+107 SET BSTST(9002318.3,TMIEN_",",.09)=TYPE
+108 SET BSTST(9002318.3,TMIEN_",",1)=TERM
+109 SET BSTST(9002318.3,TMIEN_",",.04)="N"
+110 SET BSTST(9002318.3,TMIEN_",",.05)=CVRSN
+111 SET BSTST(9002318.3,TMIEN_",",.08)=INMID
+112 SET BSTST(9002318.3,TMIEN_",",.03)=CONCDA
+113 SET BSTST(9002318.3,TMIEN_",",.06)=AIN
+114 SET BSTST(9002318.3,TMIEN_",",.1)=DT
+115 SET BSTST(9002318.3,TMIEN_",",.11)="N"
+116 DO FILE^DIE("","BSTST","ERROR")
+117 ;
+118 ;Reindex - needed for custom indices
+119 Begin DoDot:2
+120 NEW DIK,DA
+121 SET DIK="^BSTS(9002318.3,"
SET DA=TMIEN
+122 DO IX^DIK
End DoDot:2
End DoDot:1
+123 ;
+124 ;Need to check for retired concepts again since it may have just been added
+125 SET RTR=$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
+126 ;
+127 QUIT $SELECT($DATA(ERROR):"0^Update Failed",1:1)
+128 ;
RUPDATE(NMID,ROUT) ;EP-Add/Update RXNORM
+1 ;
+2 ;RXNORM Only
+3 IF $GET(NMID)'=1552
QUIT 1
+4 ;
+5 NEW GL,CONCDA,BSTSC,INMID,ERROR,TCNT,I,CVRSN,ST,NROUT,TLIST,STYPE,RTR
+6 ;
+7 SET GL=$NAME(^TMP("BSTSCMCL",$JOB,1))
+8 SET ROUT=$GET(ROUT,"")
+9 ;
+10 ;Look for Concept Id
+11 IF $PIECE($GET(@GL@("CONCEPTID")),U)=""
QUIT 0
+12 ;
+13 ;Look for existing
+14 IF $GET(@GL@("DTSID"))=""
QUIT 0
+15 SET CONCDA=$ORDER(^BSTS(9002318.4,"D",NMID,@GL@("DTSID"),""))
+16 ;
+17 ;Pull internal Code Set ID
+18 SET INMID=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF INMID=""
QUIT "0"
+19 ;
+20 ;Pull the current version
+21 SET CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
+22 ;
+23 ;Retired?
+24 IF CONCDA]""
IF '$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
QUIT 0
+25 ;
+26 ;None found - create new
+27 IF CONCDA=""
SET CONCDA=$$NEWC^BSTSDTS0()
+28 ;
+29 ;Verify entry found/created
+30 IF +CONCDA<0
QUIT 0
+31 ;
+32 ;Get Revision Out
+33 SET NROUT=$PIECE(@GL@("CONCEPTID"),U,3)
IF NROUT=""
SET NROUT=ROUT
+34 ;
+35 ;Set up top level
+36 ;Conc ID
SET BSTSC(9002318.4,CONCDA_",",.02)=$PIECE(@GL@("CONCEPTID"),U)
+37 ;DTSID
SET BSTSC(9002318.4,CONCDA_",",.08)=@GL@("DTSID")
+38 ;Code Set
SET BSTSC(9002318.4,CONCDA_",",.07)=INMID
+39 SET BSTSC(9002318.4,CONCDA_",",.03)="N"
+40 SET BSTSC(9002318.4,CONCDA_",",.05)=$$EP2FMDT^BSTSUTIL($PIECE(@GL@("CONCEPTID"),U,2),1)
+41 SET BSTSC(9002318.4,CONCDA_",",.06)=$$EP2FMDT^BSTSUTIL(NROUT,1)
+42 SET BSTSC(9002318.4,CONCDA_",",.11)="N"
+43 SET BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
+44 SET BSTSC(9002318.4,CONCDA_",",.12)=DT
+45 SET BSTSC(9002318.4,CONCDA_",",1)=$GET(@GL@("FSN",1))
+46 ;
+47 ;Save ISA
+48 IF $DATA(@GL@("ISA"))>1
Begin DoDot:1
+49 ;
+50 NEW ISACT
+51 SET ISACT=""
FOR
SET ISACT=$ORDER(@GL@("ISA",ISACT))
IF ISACT=""
QUIT
Begin DoDot:2
+52 ;
+53 ;Save/update each ISA
+54 ;
+55 ;First see if IsA code saved
+56 NEW DAISA,DA,IENS,DTSID,ISACD,NEWISA,DIC,Y,X,DLAYGO
+57 SET ISACD=$PIECE($GET(@GL@("ISA",ISACT,0)),U)
IF ISACD=""
QUIT
+58 SET (NEWISA,DAISA)=$ORDER(^BSTS(9002318.4,"D",NMID,ISACD,""))
+59 ;
+60 ;Not found - add partial entry
+61 IF DAISA=""
SET DAISA=$$NEWC^BSTSDTS0()
+62 SET BSTSC(9002318.4,DAISA_",",.08)=$GET(ISACD)
+63 IF NEWISA=""
SET BSTSC(9002318.4,DAISA_",",.03)="P"
+64 ;Code Set
SET BSTSC(9002318.4,DAISA_",",.07)=INMID
+65 ;Version
SET BSTSC(9002318.4,DAISA_",",.04)=CVRSN
+66 ;Up to Date
SET BSTSC(9002318.4,DAISA_",",.11)="N"
+67 ;Update Date
SET BSTSC(9002318.4,DAISA_",",.12)=DT
+68 SET BSTSC(9002318.4,DAISA_",",1)=$GET(@GL@("ISA",ISACT,1))
+69 ;
+70 ;Now add IsA pointer in current concept entry
+71 SET DA(1)=CONCDA
+72 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",5,"
SET X=DAISA
+73 SET DLAYGO=9002318.45
DO ^DIC
IF +Y<0
QUIT
+74 ;
+75 ;Save additional IsA fields
+76 SET DA(1)=CONCDA
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+77 SET BSTSC(9002318.45,IENS,".02")=$$EP2FMDT^BSTSUTIL($PIECE($GET(@GL@("ISA",ISACT,1,0)),U,2))
End DoDot:2
End DoDot:1
+78 ;
+79 ;Save Inverse Associations
+80 ;
+81 ;Clear out existing entries
+82 Begin DoDot:1
+83 NEW AS
+84 SET AS=0
FOR
SET AS=$ORDER(^BSTS(9002318.4,CONCDA,11,AS))
IF 'AS
QUIT
Begin DoDot:2
+85 NEW DA,DIK
+86 SET DA(1)=CONCDA
SET DA=AS
+87 SET DIK="^BSTS(9002318.4,"_DA(1)_",11,"
DO ^DIK
End DoDot:2
End DoDot:1
+88 IF $DATA(@GL@("IAS"))>1
Begin DoDot:1
+89 ;
+90 ;
+91 NEW AS
+92 SET AS=""
FOR
SET AS=$ORDER(@GL@("IAS",AS))
IF AS=""
QUIT
Begin DoDot:2
+93 ;
+94 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+95 SET DA(1)=CONCDA
+96 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",11,"
+97 SET X=$PIECE($GET(@GL@("IAS",AS)),U)
IF X=""
QUIT
+98 SET DLAYGO=9002318.411
DO ^DIC
+99 IF +Y<0
QUIT
+100 SET DA=+Y
+101 SET IENS=$$IENS^DILF(.DA)
+102 SET BSTSC(9002318.411,IENS,".02")=$PIECE($GET(@GL@("IAS",AS)),U,2)
+103 SET BSTSC(9002318.411,IENS,".03")=$PIECE($GET(@GL@("IAS",AS)),U,3)
+104 SET BSTSC(9002318.411,IENS,".04")=$PIECE($GET(@GL@("IAS",AS)),U,4)
End DoDot:2
End DoDot:1
+105 ;
+106 ;Update additional RxNorm fields
+107 DO UPRSUB^BSTSDTS5(GL,CONCDA,.BSTSC)
+108 ;
+109 ;Save the entry
+110 IF $DATA(BSTSC)
DO FILE^DIE("","BSTSC","ERROR")
+111 ;
+112 ;Reindex - needed for custom indices
+113 Begin DoDot:1
+114 NEW DIK,DA
+115 SET DIK="^BSTS(9002318.4,"
SET DA=CONCDA
+116 DO IX^DIK
End DoDot:1
+117 ;
+118 ;Save Terminology entries
+119 ;
+120 ;Synonyms/Preferred/FSN
+121 ;
+122 SET STYPE=""
FOR
SET STYPE=$ORDER(@GL@("SYN",STYPE))
IF STYPE=""
QUIT
SET TCNT=""
FOR
SET TCNT=$ORDER(@GL@("SYN",STYPE,TCNT))
IF TCNT=""
QUIT
Begin DoDot:1
+123 ;
+124 NEW TERM,TYPE,DESC,BSTST,ERROR,TMIEN,AIN
+125 ;
+126 ;Pull values
+127 SET TERM=$GET(@GL@("SYN",STYPE,TCNT,1))
IF TERM=""
QUIT
+128 ;
+129 ;Limit to 244
+130 SET TERM=$EXTRACT(TERM,1,244)
+131 ;
+132 ;Quit if found
+133 IF $DATA(TLIST(TERM))
QUIT
+134 SET TLIST(TERM)=""
+135 ;
+136 SET TYPE=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,2)
+137 SET TYPE=$SELECT(TYPE=1:"P",1:"S")
+138 IF TERM=$GET(@GL@("FSN",1))
SET TYPE="F"
+139 SET DESC=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U)
IF DESC=""
QUIT
+140 SET AIN=$$EP2FMDT^BSTSUTIL($PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,3))
+141 ;
+142 ;Look up entry
+143 SET TMIEN=$ORDER(^BSTS(9002318.3,"D",INMID,DESC,""))
+144 ;
+145 ;Entry not found - create new
+146 IF TMIEN=""
SET TMIEN=$$NEWT^BSTSDTS0()
+147 IF TMIEN<0
QUIT
+148 ;
+149 ;Save/update other fields
+150 SET BSTST(9002318.3,TMIEN_",",.02)=DESC
+151 SET BSTST(9002318.3,TMIEN_",",.09)=TYPE
+152 SET BSTST(9002318.3,TMIEN_",",1)=TERM
+153 SET BSTST(9002318.3,TMIEN_",",.04)="N"
+154 SET BSTST(9002318.3,TMIEN_",",.05)=CVRSN
+155 SET BSTST(9002318.3,TMIEN_",",.08)=INMID
+156 SET BSTST(9002318.3,TMIEN_",",.03)=CONCDA
+157 SET BSTST(9002318.3,TMIEN_",",.06)=AIN
+158 SET BSTST(9002318.3,TMIEN_",",.1)=DT
+159 SET BSTST(9002318.3,TMIEN_",",.11)="N"
+160 DO FILE^DIE("","BSTST","ERROR")
+161 ;
+162 ;Reindex - needed for custom indices
+163 Begin DoDot:2
+164 NEW DIK,DA
+165 SET DIK="^BSTS(9002318.3,"
SET DA=TMIEN
+166 DO IX^DIK
End DoDot:2
End DoDot:1
+167 ;
+168 ;Need to check for retired concepts again since it may have just been added
+169 SET RTR=$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
+170 ;
+171 QUIT $SELECT($DATA(ERROR):"0^Update Failed",1:1)
+172 ;
DILKP(OUT,BSTSWS) ;EP - DTS4 Search Call - Drug Ingredient Lookup
+1 ;
+2 NEW II,STS,SEARCH,STYPE,MAX,DTSID,NMID
+3 NEW BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,ST
+4 ;
+5 SET SEARCH=$GET(BSTSWS("SEARCH"))
+6 SET STYPE=$GET(BSTSWS("STYPE"))
+7 ;Sorted List
SET SLIST=$NAME(^TMP("BSTSDET",$JOB))
+8 ;DTS Return List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+9 KILL @SLIST,@DLIST,@OUT
+10 ;
+11 ;Determine max to return
+12 SET MAX=$GET(BSTSWS("MAXRECS"))
IF MAX=""
SET MAX=25
+13 SET BSTRT=+$GET(BSTSWS("BCTCHRC"))
IF BSTRT=0
SET BSTRT=1
+14 SET BSCNT=+$GET(BSTSWS("BCTCHCT"))
IF BSCNT=0
SET BSCNT=MAX
+15 SET NMID=$GET(BSTSWS("NAMESPACEID"))
+16 ;
+17 ;Perform Lookup on Concept Id
+18 SET STS=$$PTYDTS4^BSTSCMCL(.BSTSWS,.RES)
IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
+19 ;
+20 ;Sort results (though there should only be one)
+21 SET DTSID=""
FOR
SET DTSID=$ORDER(@DLIST@(DTSID))
IF DTSID=""
QUIT
SET @SLIST@(@DLIST@(DTSID),DTSID)=""
+22 ;
+23 ;Loop through results and retrieve detail
+24 SET II=""
SET RCNT=0
FOR
SET II=$ORDER(@SLIST@(II),-1)
IF II=""
QUIT
Begin DoDot:1
+25 SET DTSID=""
FOR
SET DTSID=$ORDER(@SLIST@(II,DTSID))
IF DTSID=""
QUIT
Begin DoDot:2
+26 ;
+27 NEW STATUS,CONC,ERSLT
+28 ;
+29 ;Update entry
+30 SET BSTSWS("DTSID")=DTSID
+31 ;
+32 ;Clear result file
+33 KILL @DLIST
+34 ;
+35 ;Get Detail for concept
+36 SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
+37 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"Detail Call Status: ",STATUS
+38 ;
+39 ;File Detail
+40 SET STATUS=$$UPDATE^BSTSDTS0(NMID)
+41 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"Update Call Status: ",STATUS
+42 ;
+43 ;Look to see if concept logged
+44 SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS,1,1)
+45 IF CONC]""
Begin DoDot:3
+46 SET RCNT=$GET(RCNT)+1
SET @OUT@(RCNT)=CONC_U_DTSID
End DoDot:3
QUIT
End DoDot:2
IF RCNT
QUIT
End DoDot:1
IF RCNT
QUIT
+47 ;
+48 QUIT STS
