BSTSDTS0 ;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
;
CNCSR(OUT,BSTSWS) ;EP - DTS4 Search Call - Concept 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("BSTSPDET",$J)) ;Sort List
S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Ret List
K @SLIST,@DLIST,@OUT
;
;Determine max to ret
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
;
;Perform Lookup on Conc Id
S STS=$$CNCSR^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS
;
;Sort results (should only be one)
S DTSID="" F S DTSID=$O(@DLIST@(DTSID)) Q:DTSID="" S @SLIST@(@DLIST@(DTSID),DTSID)=""
;
;Loop through results and retrieve det
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,SNAPDT
.. ;
.. ;Update entry
.. S BSTSWS("DTSID")=DTSID
.. ;
.. ;Change snapshot date
.. S SNAPDT=$$DTCHG^BSTSUTIL(DT,2)_".0001"
.. S SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
.. S BSTSWS("SNAPDT")=SNAPDT
.. ;
.. ;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(NMID)
.. I $G(BSTSWS("DEBUG")) W !!,"Update Call Status: ",STATUS
.. ;
.. ;Look again to see if concept logged
.. S CONC=$$CONC(DTSID,.BSTSWS,1,1)
.. I CONC]"" D Q
... I CONC'=BSTSWS("SEARCH") Q
... S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID
;
Q STS
;
UPDATE(NMID,ROUT) ;EP - Add/Update Concept and Term(s)
;
;Update UNII
I $G(NMID)=5180 Q $$UUPDATE^BSTSDTS1(NMID,$G(ROUT))
;
;Update RxNorm
I $G(NMID)=1552 Q $$RUPDATE^BSTSDTS1(NMID,$G(ROUT))
;
;This update section only applies to SNOMED
I $G(NMID)'=36 Q $$SUPDATE^BSTSDTS3(NMID,$G(ROUT))
;
N GL,CONCDA,BSTSC,INMID,ERROR,TCNT,I,CVRSN,ST,NROUT,TLIST,STYPE,RTR,SVOUT
;
S GL=$NA(^TMP("BSTSCMCL",$J,1))
S ROUT=$G(ROUT,"")
;
;Look for Conc Id
I $P($G(@GL@("CONCEPTID")),U)="" Q 0
;
;Look for existing entry
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 ver
S CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
;
;BSTS*1.0*8;Save Replacement
D REPL^BSTSRPT(CONCDA,GL)
;
;Handle retired concepts
I CONCDA]"",'$$RET^BSTSDTS3(CONCDA,CVRSN,GL) Q 0
;
;None found - create new entry
I CONCDA="" S CONCDA=$$NEWC()
;
;Verify entry found/created
I +CONCDA<0 Q 0
;
;Pull internal Code Set ID
S INMID=$O(^BSTS(9002318.1,"B",NMID,"")) Q:INMID="" "0"
;
;Pull current version
S CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
;
;Get Rev Out
S NROUT=$P(@GL@("CONCEPTID"),U,3) S:NROUT="" NROUT=ROUT
S SVOUT=NROUT S SVOUT=$S(SVOUT]"":$$DTS2FMDT^BSTSUTIL(NROUT,1),1:"@")
;
;Set up top level concept fields
S BSTSC(9002318.4,CONCDA_",",.02)=$P(@GL@("CONCEPTID"),U) ;Concept ID
S BSTSC(9002318.4,CONCDA_",",.08)=@GL@("DTSID") ;DTS ID
S BSTSC(9002318.4,CONCDA_",",.07)=INMID ;Code Set
S BSTSC(9002318.4,CONCDA_",",.03)="N"
S BSTSC(9002318.4,CONCDA_",",.05)=$$DTS2FMDT^BSTSUTIL($P(@GL@("CONCEPTID"),U,2),1)
S BSTSC(9002318.4,CONCDA_",",.06)=SVOUT
S BSTSC(9002318.4,CONCDA_",",.11)="N"
S BSTSC(9002318.4,CONCDA_",",.13)="N"
S BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
S BSTSC(9002318.4,CONCDA_",",.12)=DT
;BSTS*1.0*8;Reset new field
S BSTSC(9002318.4,CONCDA_",",.15)="@"
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 entry
.. ;
.. ;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 to concept file
.. I DAISA="" S DAISA=$$NEWC()
.. 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 conc 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")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("ISA",ISACT,1,0)),U,2))
;
;Save Children (subconcepts)
I $D(@GL@("SUBC"))>1 D
. ;
. N SUBCCT
. S SUBCCT="" F S SUBCCT=$O(@GL@("SUBC",SUBCCT)) Q:SUBCCT="" D
.. ;
.. ;Save/update each SubConcept entry
.. ;
.. ;First see if Subconcept code saved
.. N DASUBC,DA,IENS,DTSID,SUBCCD,NEWSUBC,DIC,Y,X,DLAYGO
.. S SUBCCD=$P($G(@GL@("SUBC",SUBCCT,0)),U) Q:SUBCCD=""
.. S (NEWSUBC,DASUBC)=$O(^BSTS(9002318.4,"D",NMID,SUBCCD,""))
.. ;
.. ;Not found - add partial entry to conc file
.. I DASUBC="" S DASUBC=$$NEWC()
.. S BSTSC(9002318.4,DASUBC_",",.08)=$G(SUBCCD)
.. I NEWSUBC="" S BSTSC(9002318.4,DASUBC_",",.03)="P"
.. S BSTSC(9002318.4,DASUBC_",",.07)=INMID ;Code Set
.. S BSTSC(9002318.4,DASUBC_",",.04)=CVRSN ;Version
.. S BSTSC(9002318.4,DASUBC_",",.11)="N" ;Up to Date
.. S BSTSC(9002318.4,DASUBC_",",.12)=DT ;Update Date
.. S BSTSC(9002318.4,DASUBC_",",1)=$G(@GL@("SUBC",SUBCCT,1))
.. ;
.. ;Now add SUBC pointer in current conc entry
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",6,",X=DASUBC
.. S DLAYGO=9002318.46 D ^DIC I +Y<0 Q
.. ;
.. ;Save additional SUBC fields
.. S DA(1)=CONCDA,DA=+Y,IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.46,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("SUB",SUBCCT,1,0)),U,2))
;
;Need to interim save because subsets look at .07
I $D(BSTSC) D FILE^DIE("","BSTSC","ERROR")
;
;Save Subsets
;
;Clear out existing entries
D
. NEW SB
. S SB=0 F S SB=$O(^BSTS(9002318.4,CONCDA,4,SB)) Q:'SB D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=SB
.. S DIK="^BSTS(9002318.4,"_DA(1)_",4," D ^DIK
I $D(@GL@("SUB"))>1 D
. ;
. NEW SB
. S SB="" F S SB=$O(@GL@("SUB",SB)) Q:SB="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",4,"
.. S X=$P($G(@GL@("SUB",SB)),U) Q:X=""
.. ;BSTS*1.0*8;Log ALL SNOMED
.. I X="IHS PROBLEM ALL SNOMED" S BSTSC(9002318.4,CONCDA_",",.15)="Y"
.. S DLAYGO=9002318.44 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.44,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("SUB",SB)),U,2))
;
;Save ICD Mapping
;
;Clear out existing
D
. NEW IC
. S IC=0 F S IC=$O(^BSTS(9002318.4,CONCDA,3,IC)) Q:'IC D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=IC
.. S DIK="^BSTS(9002318.4,"_DA(1)_",3," D ^DIK
;
;Save ICD9 first
I $D(@GL@("ICD9"))>1 D
. N ICD
. S ICD="" F S ICD=$O(@GL@("ICD9",ICD)) Q:ICD="" D
.. N DA,IENS,ICDCD
.. ;
.. ;Look up entry
.. S DA(1)=CONCDA
.. S ICDCD=$P($G(@GL@("ICD9",ICD)),U) Q:ICDCD=""
.. S DA=$O(^BSTS(9002318.4,DA(1),3,"C",ICDCD,""))
.. ;
.. ;Create new
.. I DA="" S DA=$$NEWI(CONCDA)
.. Q:DA<0
.. ;
.. ;Add in additional fields
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.43,IENS,".02")=ICDCD
.. S BSTSC(9002318.43,IENS,".03")="IC9"
.. S BSTSC(9002318.43,IENS,".04")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("ICD9",ICD)),U,2))
.. S BSTSC(9002318.43,IENS,".05")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("ICD9",ICD)),U,3))
;
;Save ICD10 Mapping Next
I $D(@GL@("A10"))>1 D
. N ICD
. S ICD="" F S ICD=$O(@GL@("A10",ICD)) Q:ICD="" D
.. N DA,IENS,ICDCD
.. ;
.. ;Look up
.. S DA(1)=CONCDA
.. S ICDCD=$P($G(@GL@("A10",ICD)),U) Q:ICDCD=""
.. S DA=$O(^BSTS(9002318.4,DA(1),3,"C",ICDCD,""))
.. ;
.. ;Create new
.. I DA="" S DA=$$NEWI(CONCDA)
.. Q:DA<0
.. ;
.. ;Add in additional fields
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.43,IENS,".02")=ICDCD
.. S BSTSC(9002318.43,IENS,".03")="10D"
.. S BSTSC(9002318.43,IENS,".04")=$$DTS2FMDT^BSTSUTIL($P($P($G(@GL@("A10",ICD)),U,5)," "))
.. S BSTSC(9002318.43,IENS,".05")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("A10",ICD)),U,6))
;
;Save ICD9 to SNOMED Mapping
;
;Clear out existing entries
D
. NEW SB
. S SB=0 F S SB=$O(^BSTS(9002318.4,CONCDA,13,SB)) Q:'SB D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=SB
.. S DIK="^BSTS(9002318.4,"_DA(1)_",13," D ^DIK
;
;Now save mappings
I $D(@GL@("RICD9"))>1 D
. ;
. NEW SB
. S SB="" F S SB=$O(@GL@("RICD9",SB)) Q:SB="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",13,"
.. S X=$P($G(@GL@("RICD9",SB)),U) Q:X=""
.. S DLAYGO=9002318.413 D ^DIC
;
;BSTS*1.0*6;Update Condition mappings
;Save Conditional Mappings
D SAVEMAP^BSTSMAP1(CONCDA,.BSTSC,GL)
;
;BSTS*1.0*7;Update Equivalency Concepts
D EQLAT^BSTSDTS4(CONCDA,.BSTSC,GL)
;
I $D(BSTSC) D FILE^DIE("","BSTSC","ERROR")
;
;Now 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,AOUT
. ;
. ;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=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("SYN",STYPE,TCNT,0)),U,3))
. S AOUT=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("SYN",STYPE,TCNT,0)),U,4))
. S:AOUT="" AOUT="@"
. ;
. ;Look up entry
. S TMIEN=$O(^BSTS(9002318.3,"D",INMID,DESC,""))
. ;
. ;Entry not found - create new
. I TMIEN="" S TMIEN=$$NEWT()
. 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_",",.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_",",.07)=AOUT
. S BSTST(9002318.3,TMIEN_",",.1)=DT
. S BSTST(9002318.3,TMIEN_",",.11)="N"
. S BSTST(9002318.3,TMIEN_",",1)=TERM
. D FILE^DIE("","BSTST","ERROR")
. ;
. ;Reindex - needed for custom indices
. D
.. NEW DIK,DA
.. S DIK="^BSTS(9002318.3,",DA=TMIEN
.. D IX^DIK
;
;Save ICD Mapping information
I '$D(ERROR) S STS=$$ICDMAP^BSTSDTS2(CONCDA,GL)
;
;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)
;
CONC(DTSID,BSTSWS,SKPOD,SKPDT) ;EP - Determine if Code on File (and up to date)
;
NEW CONC,CIEN,CONC,SNAPDT,NMID,BEGDT,ENDDT
;
S SKPOD=$G(SKPOD) ;Set to 1 to skip out of date checking
S SKPDT=$G(SKPDT) ;Set to 1 to skip date checking
;
;Get namespace
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
;
;Pull the conc IEN
S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTSID,"")) Q:CIEN="" ""
;
;Quit if out of date
I 'SKPOD,$$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" Q ""
;
;Look in date range
S SNAPDT=$G(BSTSWS("SNAPDT")) S:SNAPDT]"" SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
S:SNAPDT="" SNAPDT=DT
;
I 'SKPDT S BEGDT=$$GET1^DIQ(9002318.4,CIEN_",",".05","I") I BEGDT]"",SNAPDT<BEGDT Q ""
I 'SKPDT S ENDDT=$$GET1^DIQ(9002318.4,CIEN_",",".06","I") I ENDDT]"",SNAPDT>ENDDT Q ""
;
S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E")
;
Q CONC
;
GCDSDTS4(BSTSWS) ;EP - DTS4 update codeset
;
N RESULT,STS,II,BSTSUP,ERROR
;
S STS=$$GCDSDTS4^BSTSCMCL(.BSTSWS,.RESULT)
;
;Update Local BSTS CODESET file (9002318.1)
S II="" F S II=$O(RESULT(II),-1) Q:II="" D
. ;
. N DIC,X,Y,DLAYGO,DIC
. S X=$G(RESULT(II,"NAMESPACE","ID")) Q:'X
. S DIC(0)="XL",DIC="^BSTS(9002318.1,",DLAYGO=9002318.1 D ^DIC
. I +Y<0 Q
. S BSTSUP(9002318.1,+Y_",",.02)=$G(RESULT(II,"NAMESPACE","CODE"))
. S BSTSUP(9002318.1,+Y_",",.03)=$G(RESULT(II,"NAMESPACE","NAME"))
I $D(BSTSUP) D FILE^DIE("","BSTSUP","ERROR")
;
Q STS
;
GVRDTS4(BSTSWS) ;EP - DTS4 update versions
;
NEW RESULT,STS
;
;Reset Scratch global and make call to DTS
S RESULT=$NA(^TMP("BSTSCMCL",$J))
K @RESULT
S STS=$$GVRDTS4^BSTSCMCL(.BSTSWS)
;
;Update file with results
I STS D
. NEW NMID,NMIEN,VDT,CNT,VRID,CVID,BSTS,ERR
. S NMID=$G(BSTSWS("NAMESPACEID"))
. S NMIEN=$O(^BSTS(9002318.1,"B",NMID,""),-1) Q:NMIEN=""
. S (VRID,CNT)="" F S CNT=$O(@RESULT@(CNT),-1) Q:'CNT D
.. S VDT="" F S VDT=$O(@RESULT@(CNT,"VERSION",VDT)) Q:VDT="" D
... NEW RDT,NAME,DA,IENS,BSTSUP,ERROR
... S RDT=$G(@RESULT@(CNT,"VERSION",VDT,"RELEASEDATE"))
... S NAME=$G(@RESULT@(CNT,"VERSION",VDT,"NAME"))
... ;
... ;Look for existing entry
... S DA=$O(^BSTS(9002318.1,NMIEN,1,"B",VDT,""))
... ;
... ;Create new record
... S:DA="" DA=$$NEWV(NMIEN,VDT)
... I +DA<0 Q
... S VRID=VDT
... S DA(1)=NMIEN,IENS=$$IENS^DILF(.DA)
... ;
... ;Add/Update remaining fields
... S BSTSUP(9002318.11,IENS,".02")=NAME
... ;BSTS*1.0*6;Fixed date issue
... ;S BSTSUP(9002318.11,IENS,".03")=RDT
... S BSTSUP(9002318.11,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P(RDT,"."))
... D FILE^DIE("","BSTSUP","ERROR")
. ;
Q STS
;
NEWV(NMIEN,VDT) ;Create new ICD Mapping entry
N DIC,X,Y,DA,DLAYGO
S DIC(0)="L",DA(1)=NMIEN
S DLAYGO=9002318.11,DIC="^BSTS(9002318.1,"_DA(1)_",1,"
S X=VDT
D ^DIC
Q +Y
;
;
NEWC() ;Create new concept entry
N DIC,X,Y,DLAYGO
S DIC(0)="L",DIC=9002318.4
L +^BSTS(9002318.4,0):1 E Q ""
S X=$P($G(^BSTS(9002318.4,0)),U,3)+1
S DLAYGO=9002318.4 D ^DIC
L -^BSTS(9002318.4,0)
Q +Y
;
NEWT() ;Create new terminology entry
N DIC,X,Y,DLAYGO
S DIC(0)="L",DIC=9002318.3
L +^BSTS(9002318.3,0):1 E Q ""
S X=$P($G(^BSTS(9002318.3,0)),U,3)+1
S DLAYGO=9002318.3 D ^DIC
L -^BSTS(9002318.3,0)
Q +Y
;
NEWI(CIEN) ;Create new ICD Mapping entry
N DIC,X,Y,DA,DLAYGO
S DIC(0)="L",DA(1)=CIEN
S DIC="^BSTS(9002318.4,"_DA(1)_",3,"
L +^BSTS(9002318.4,CIEN,3,0):1 E Q ""
S X=$P($G(^BSTS(9002318.4,CIEN,3,0)),U,3)+1
S DLAYGO=9002318.43 D ^DIC
L -^BSTS(9002318.4,CIEN,3,0)
Q +Y
BSTSDTS0 ;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 ;
CNCSR(OUT,BSTSWS) ;EP - DTS4 Search Call - Concept 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 ;Sort List
SET SLIST=$NAME(^TMP("BSTSPDET",$JOB))
+8 ;DTS Ret List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+9 KILL @SLIST,@DLIST,@OUT
+10 ;
+11 ;Determine max to ret
+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"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+16 ;
+17 ;Perform Lookup on Conc Id
+18 SET STS=$$CNCSR^BSTSCMCL(.BSTSWS,.RES)
IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
+19 ;
+20 ;Sort results (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 det
+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,SNAPDT
+28 ;
+29 ;Update entry
+30 SET BSTSWS("DTSID")=DTSID
+31 ;
+32 ;Change snapshot date
+33 SET SNAPDT=$$DTCHG^BSTSUTIL(DT,2)_".0001"
+34 SET SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
+35 SET BSTSWS("SNAPDT")=SNAPDT
+36 ;
+37 ;Clear result file
+38 KILL @DLIST
+39 ;
+40 ;Get Detail for concept
+41 SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
+42 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"Detail Call Status: ",STATUS
+43 ;
+44 ;File Detail
+45 SET STATUS=$$UPDATE(NMID)
+46 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"Update Call Status: ",STATUS
+47 ;
+48 ;Look again to see if concept logged
+49 SET CONC=$$CONC(DTSID,.BSTSWS,1,1)
+50 IF CONC]""
Begin DoDot:3
+51 IF CONC'=BSTSWS("SEARCH")
QUIT
+52 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
+53 ;
+54 QUIT STS
+55 ;
UPDATE(NMID,ROUT) ;EP - Add/Update Concept and Term(s)
+1 ;
+2 ;Update UNII
+3 IF $GET(NMID)=5180
QUIT $$UUPDATE^BSTSDTS1(NMID,$GET(ROUT))
+4 ;
+5 ;Update RxNorm
+6 IF $GET(NMID)=1552
QUIT $$RUPDATE^BSTSDTS1(NMID,$GET(ROUT))
+7 ;
+8 ;This update section only applies to SNOMED
+9 IF $GET(NMID)'=36
QUIT $$SUPDATE^BSTSDTS3(NMID,$GET(ROUT))
+10 ;
+11 NEW GL,CONCDA,BSTSC,INMID,ERROR,TCNT,I,CVRSN,ST,NROUT,TLIST,STYPE,RTR,SVOUT
+12 ;
+13 SET GL=$NAME(^TMP("BSTSCMCL",$JOB,1))
+14 SET ROUT=$GET(ROUT,"")
+15 ;
+16 ;Look for Conc Id
+17 IF $PIECE($GET(@GL@("CONCEPTID")),U)=""
QUIT 0
+18 ;
+19 ;Look for existing entry
+20 IF $GET(@GL@("DTSID"))=""
QUIT 0
+21 SET CONCDA=$ORDER(^BSTS(9002318.4,"D",NMID,@GL@("DTSID"),""))
+22 ;
+23 ;Pull internal Code Set ID
+24 SET INMID=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF INMID=""
QUIT "0"
+25 ;
+26 ;Pull the current ver
+27 SET CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
+28 ;
+29 ;BSTS*1.0*8;Save Replacement
+30 DO REPL^BSTSRPT(CONCDA,GL)
+31 ;
+32 ;Handle retired concepts
+33 IF CONCDA]""
IF '$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
QUIT 0
+34 ;
+35 ;None found - create new entry
+36 IF CONCDA=""
SET CONCDA=$$NEWC()
+37 ;
+38 ;Verify entry found/created
+39 IF +CONCDA<0
QUIT 0
+40 ;
+41 ;Pull internal Code Set ID
+42 SET INMID=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF INMID=""
QUIT "0"
+43 ;
+44 ;Pull current version
+45 SET CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
+46 ;
+47 ;Get Rev Out
+48 SET NROUT=$PIECE(@GL@("CONCEPTID"),U,3)
IF NROUT=""
SET NROUT=ROUT
+49 SET SVOUT=NROUT
SET SVOUT=$SELECT(SVOUT]"":$$DTS2FMDT^BSTSUTIL(NROUT,1),1:"@")
+50 ;
+51 ;Set up top level concept fields
+52 ;Concept ID
SET BSTSC(9002318.4,CONCDA_",",.02)=$PIECE(@GL@("CONCEPTID"),U)
+53 ;DTS ID
SET BSTSC(9002318.4,CONCDA_",",.08)=@GL@("DTSID")
+54 ;Code Set
SET BSTSC(9002318.4,CONCDA_",",.07)=INMID
+55 SET BSTSC(9002318.4,CONCDA_",",.03)="N"
+56 SET BSTSC(9002318.4,CONCDA_",",.05)=$$DTS2FMDT^BSTSUTIL($PIECE(@GL@("CONCEPTID"),U,2),1)
+57 SET BSTSC(9002318.4,CONCDA_",",.06)=SVOUT
+58 SET BSTSC(9002318.4,CONCDA_",",.11)="N"
+59 SET BSTSC(9002318.4,CONCDA_",",.13)="N"
+60 SET BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
+61 SET BSTSC(9002318.4,CONCDA_",",.12)=DT
+62 ;BSTS*1.0*8;Reset new field
+63 SET BSTSC(9002318.4,CONCDA_",",.15)="@"
+64 SET BSTSC(9002318.4,CONCDA_",",1)=$GET(@GL@("FSN",1))
+65 ;
+66 ;Save ISA
+67 IF $DATA(@GL@("ISA"))>1
Begin DoDot:1
+68 ;
+69 NEW ISACT
+70 SET ISACT=""
FOR
SET ISACT=$ORDER(@GL@("ISA",ISACT))
IF ISACT=""
QUIT
Begin DoDot:2
+71 ;
+72 ;Save/update each ISA entry
+73 ;
+74 ;First see if IsA code saved
+75 NEW DAISA,DA,IENS,DTSID,ISACD,NEWISA,DIC,Y,X,DLAYGO
+76 SET ISACD=$PIECE($GET(@GL@("ISA",ISACT,0)),U)
IF ISACD=""
QUIT
+77 SET (NEWISA,DAISA)=$ORDER(^BSTS(9002318.4,"D",NMID,ISACD,""))
+78 ;
+79 ;Not found - add partial entry to concept file
+80 IF DAISA=""
SET DAISA=$$NEWC()
+81 SET BSTSC(9002318.4,DAISA_",",.08)=$GET(ISACD)
+82 IF NEWISA=""
SET BSTSC(9002318.4,DAISA_",",.03)="P"
+83 ;Code Set
SET BSTSC(9002318.4,DAISA_",",.07)=INMID
+84 ;Version
SET BSTSC(9002318.4,DAISA_",",.04)=CVRSN
+85 ;Up to Date
SET BSTSC(9002318.4,DAISA_",",.11)="N"
+86 ;Update date
SET BSTSC(9002318.4,DAISA_",",.12)=DT
+87 SET BSTSC(9002318.4,DAISA_",",1)=$GET(@GL@("ISA",ISACT,1))
+88 ;
+89 ;Now add IsA pointer in current conc entry
+90 SET DA(1)=CONCDA
+91 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",5,"
SET X=DAISA
+92 SET DLAYGO=9002318.45
DO ^DIC
IF +Y<0
QUIT
+93 ;
+94 ;Save additional IsA fields
+95 SET DA(1)=CONCDA
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+96 SET BSTSC(9002318.45,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("ISA",ISACT,1,0)),U,2))
End DoDot:2
End DoDot:1
+97 ;
+98 ;Save Children (subconcepts)
+99 IF $DATA(@GL@("SUBC"))>1
Begin DoDot:1
+100 ;
+101 NEW SUBCCT
+102 SET SUBCCT=""
FOR
SET SUBCCT=$ORDER(@GL@("SUBC",SUBCCT))
IF SUBCCT=""
QUIT
Begin DoDot:2
+103 ;
+104 ;Save/update each SubConcept entry
+105 ;
+106 ;First see if Subconcept code saved
+107 NEW DASUBC,DA,IENS,DTSID,SUBCCD,NEWSUBC,DIC,Y,X,DLAYGO
+108 SET SUBCCD=$PIECE($GET(@GL@("SUBC",SUBCCT,0)),U)
IF SUBCCD=""
QUIT
+109 SET (NEWSUBC,DASUBC)=$ORDER(^BSTS(9002318.4,"D",NMID,SUBCCD,""))
+110 ;
+111 ;Not found - add partial entry to conc file
+112 IF DASUBC=""
SET DASUBC=$$NEWC()
+113 SET BSTSC(9002318.4,DASUBC_",",.08)=$GET(SUBCCD)
+114 IF NEWSUBC=""
SET BSTSC(9002318.4,DASUBC_",",.03)="P"
+115 ;Code Set
SET BSTSC(9002318.4,DASUBC_",",.07)=INMID
+116 ;Version
SET BSTSC(9002318.4,DASUBC_",",.04)=CVRSN
+117 ;Up to Date
SET BSTSC(9002318.4,DASUBC_",",.11)="N"
+118 ;Update Date
SET BSTSC(9002318.4,DASUBC_",",.12)=DT
+119 SET BSTSC(9002318.4,DASUBC_",",1)=$GET(@GL@("SUBC",SUBCCT,1))
+120 ;
+121 ;Now add SUBC pointer in current conc entry
+122 SET DA(1)=CONCDA
+123 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",6,"
SET X=DASUBC
+124 SET DLAYGO=9002318.46
DO ^DIC
IF +Y<0
QUIT
+125 ;
+126 ;Save additional SUBC fields
+127 SET DA(1)=CONCDA
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+128 SET BSTSC(9002318.46,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("SUB",SUBCCT,1,0)),U,2))
End DoDot:2
End DoDot:1
+129 ;
+130 ;Need to interim save because subsets look at .07
+131 IF $DATA(BSTSC)
DO FILE^DIE("","BSTSC","ERROR")
+132 ;
+133 ;Save Subsets
+134 ;
+135 ;Clear out existing entries
+136 Begin DoDot:1
+137 NEW SB
+138 SET SB=0
FOR
SET SB=$ORDER(^BSTS(9002318.4,CONCDA,4,SB))
IF 'SB
QUIT
Begin DoDot:2
+139 NEW DA,DIK
+140 SET DA(1)=CONCDA
SET DA=SB
+141 SET DIK="^BSTS(9002318.4,"_DA(1)_",4,"
DO ^DIK
End DoDot:2
End DoDot:1
+142 IF $DATA(@GL@("SUB"))>1
Begin DoDot:1
+143 ;
+144 NEW SB
+145 SET SB=""
FOR
SET SB=$ORDER(@GL@("SUB",SB))
IF SB=""
QUIT
Begin DoDot:2
+146 ;
+147 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+148 SET DA(1)=CONCDA
+149 SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(1)_",4,"
+150 SET X=$PIECE($GET(@GL@("SUB",SB)),U)
IF X=""
QUIT
+151 ;BSTS*1.0*8;Log ALL SNOMED
+152 IF X="IHS PROBLEM ALL SNOMED"
SET BSTSC(9002318.4,CONCDA_",",.15)="Y"
+153 SET DLAYGO=9002318.44
DO ^DIC
+154 IF +Y<0
QUIT
+155 SET DA=+Y
+156 SET IENS=$$IENS^DILF(.DA)
+157 SET BSTSC(9002318.44,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("SUB",SB)),U,2))
End DoDot:2
End DoDot:1
+158 ;
+159 ;Save ICD Mapping
+160 ;
+161 ;Clear out existing
+162 Begin DoDot:1
+163 NEW IC
+164 SET IC=0
FOR
SET IC=$ORDER(^BSTS(9002318.4,CONCDA,3,IC))
IF 'IC
QUIT
Begin DoDot:2
+165 NEW DA,DIK
+166 SET DA(1)=CONCDA
SET DA=IC
+167 SET DIK="^BSTS(9002318.4,"_DA(1)_",3,"
DO ^DIK
End DoDot:2
End DoDot:1
+168 ;
+169 ;Save ICD9 first
+170 IF $DATA(@GL@("ICD9"))>1
Begin DoDot:1
+171 NEW ICD
+172 SET ICD=""
FOR
SET ICD=$ORDER(@GL@("ICD9",ICD))
IF ICD=""
QUIT
Begin DoDot:2
+173 NEW DA,IENS,ICDCD
+174 ;
+175 ;Look up entry
+176 SET DA(1)=CONCDA
+177 SET ICDCD=$PIECE($GET(@GL@("ICD9",ICD)),U)
IF ICDCD=""
QUIT
+178 SET DA=$ORDER(^BSTS(9002318.4,DA(1),3,"C",ICDCD,""))
+179 ;
+180 ;Create new
+181 IF DA=""
SET DA=$$NEWI(CONCDA)
+182 IF DA<0
QUIT
+183 ;
+184 ;Add in additional fields
+185 SET IENS=$$IENS^DILF(.DA)
+186 SET BSTSC(9002318.43,IENS,".02")=ICDCD
+187 SET BSTSC(9002318.43,IENS,".03")="IC9"
+188 SET BSTSC(9002318.43,IENS,".04")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("ICD9",ICD)),U,2))
+189 SET BSTSC(9002318.43,IENS,".05")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("ICD9",ICD)),U,3))
End DoDot:2
End DoDot:1
+190 ;
+191 ;Save ICD10 Mapping Next
+192 IF $DATA(@GL@("A10"))>1
Begin DoDot:1
+193 NEW ICD
+194 SET ICD=""
FOR
SET ICD=$ORDER(@GL@("A10",ICD))
IF ICD=""
QUIT
Begin DoDot:2
+195 NEW DA,IENS,ICDCD
+196 ;
+197 ;Look up
+198 SET DA(1)=CONCDA
+199 SET ICDCD=$PIECE($GET(@GL@("A10",ICD)),U)
IF ICDCD=""
QUIT
+200 SET DA=$ORDER(^BSTS(9002318.4,DA(1),3,"C",ICDCD,""))
+201 ;
+202 ;Create new
+203 IF DA=""
SET DA=$$NEWI(CONCDA)
+204 IF DA<0
QUIT
+205 ;
+206 ;Add in additional fields
+207 SET IENS=$$IENS^DILF(.DA)
+208 SET BSTSC(9002318.43,IENS,".02")=ICDCD
+209 SET BSTSC(9002318.43,IENS,".03")="10D"
+210 SET BSTSC(9002318.43,IENS,".04")=$$DTS2FMDT^BSTSUTIL($PIECE($PIECE($GET(@GL@("A10",ICD)),U,5)," "))
+211 SET BSTSC(9002318.43,IENS,".05")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("A10",ICD)),U,6))
End DoDot:2
End DoDot:1
+212 ;
+213 ;Save ICD9 to SNOMED Mapping
+214 ;
+215 ;Clear out existing entries
+216 Begin DoDot:1
+217 NEW SB
+218 SET SB=0
FOR
SET SB=$ORDER(^BSTS(9002318.4,CONCDA,13,SB))
IF 'SB
QUIT
Begin DoDot:2
+219 NEW DA,DIK
+220 SET DA(1)=CONCDA
SET DA=SB
+221 SET DIK="^BSTS(9002318.4,"_DA(1)_",13,"
DO ^DIK
End DoDot:2
End DoDot:1
+222 ;
+223 ;Now save mappings
+224 IF $DATA(@GL@("RICD9"))>1
Begin DoDot:1
+225 ;
+226 NEW SB
+227 SET SB=""
FOR
SET SB=$ORDER(@GL@("RICD9",SB))
IF SB=""
QUIT
Begin DoDot:2
+228 ;
+229 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+230 SET DA(1)=CONCDA
+231 SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(1)_",13,"
+232 SET X=$PIECE($GET(@GL@("RICD9",SB)),U)
IF X=""
QUIT
+233 SET DLAYGO=9002318.413
DO ^DIC
End DoDot:2
End DoDot:1
+234 ;
+235 ;BSTS*1.0*6;Update Condition mappings
+236 ;Save Conditional Mappings
+237 DO SAVEMAP^BSTSMAP1(CONCDA,.BSTSC,GL)
+238 ;
+239 ;BSTS*1.0*7;Update Equivalency Concepts
+240 DO EQLAT^BSTSDTS4(CONCDA,.BSTSC,GL)
+241 ;
+242 IF $DATA(BSTSC)
DO FILE^DIE("","BSTSC","ERROR")
+243 ;
+244 ;Now save Terminology entries
+245 ;
+246 ;Synonyms/Preferred/FSN
+247 ;
+248 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
+249 ;
+250 NEW TERM,TYPE,DESC,BSTST,ERROR,TMIEN,AIN,AOUT
+251 ;
+252 ;Pull values
+253 SET TERM=$GET(@GL@("SYN",STYPE,TCNT,1))
IF TERM=""
QUIT
+254 ;
+255 ;Quit if found
+256 IF $DATA(TLIST(TERM))
QUIT
+257 SET TLIST(TERM)=""
+258 ;
+259 SET TYPE=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,2)
+260 SET TYPE=$SELECT(TYPE=1:"P",1:"S")
+261 IF TERM=$GET(@GL@("FSN",1))
SET TYPE="F"
+262 SET DESC=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U)
IF DESC=""
QUIT
+263 SET AIN=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,3))
+264 SET AOUT=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,4))
+265 IF AOUT=""
SET AOUT="@"
+266 ;
+267 ;Look up entry
+268 SET TMIEN=$ORDER(^BSTS(9002318.3,"D",INMID,DESC,""))
+269 ;
+270 ;Entry not found - create new
+271 IF TMIEN=""
SET TMIEN=$$NEWT()
+272 IF TMIEN<0
QUIT
+273 ;
+274 ;Save/update other fields
+275 SET BSTST(9002318.3,TMIEN_",",.02)=DESC
+276 SET BSTST(9002318.3,TMIEN_",",.09)=TYPE
+277 SET BSTST(9002318.3,TMIEN_",",.04)="N"
+278 SET BSTST(9002318.3,TMIEN_",",.05)=CVRSN
+279 SET BSTST(9002318.3,TMIEN_",",.08)=INMID
+280 SET BSTST(9002318.3,TMIEN_",",.03)=CONCDA
+281 SET BSTST(9002318.3,TMIEN_",",.06)=AIN
+282 SET BSTST(9002318.3,TMIEN_",",.07)=AOUT
+283 SET BSTST(9002318.3,TMIEN_",",.1)=DT
+284 SET BSTST(9002318.3,TMIEN_",",.11)="N"
+285 SET BSTST(9002318.3,TMIEN_",",1)=TERM
+286 DO FILE^DIE("","BSTST","ERROR")
+287 ;
+288 ;Reindex - needed for custom indices
+289 Begin DoDot:2
+290 NEW DIK,DA
+291 SET DIK="^BSTS(9002318.3,"
SET DA=TMIEN
+292 DO IX^DIK
End DoDot:2
End DoDot:1
+293 ;
+294 ;Save ICD Mapping information
+295 IF '$DATA(ERROR)
SET STS=$$ICDMAP^BSTSDTS2(CONCDA,GL)
+296 ;
+297 ;Need to check for retired concepts again since it may have just been added
+298 SET RTR=$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
+299 ;
+300 QUIT $SELECT($DATA(ERROR):"0^Update Failed",1:1)
+301 ;
CONC(DTSID,BSTSWS,SKPOD,SKPDT) ;EP - Determine if Code on File (and up to date)
+1 ;
+2 NEW CONC,CIEN,CONC,SNAPDT,NMID,BEGDT,ENDDT
+3 ;
+4 ;Set to 1 to skip out of date checking
SET SKPOD=$GET(SKPOD)
+5 ;Set to 1 to skip date checking
SET SKPDT=$GET(SKPDT)
+6 ;
+7 ;Get namespace
+8 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+9 ;
+10 ;Pull the conc IEN
+11 SET CIEN=$ORDER(^BSTS(9002318.4,"D",NMID,DTSID,""))
IF CIEN=""
QUIT ""
+12 ;
+13 ;Quit if out of date
+14 IF 'SKPOD
IF $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y"
QUIT ""
+15 ;
+16 ;Look in date range
+17 SET SNAPDT=$GET(BSTSWS("SNAPDT"))
IF SNAPDT]""
SET SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
+18 IF SNAPDT=""
SET SNAPDT=DT
+19 ;
+20 IF 'SKPDT
SET BEGDT=$$GET1^DIQ(9002318.4,CIEN_",",".05","I")
IF BEGDT]""
IF SNAPDT<BEGDT
QUIT ""
+21 IF 'SKPDT
SET ENDDT=$$GET1^DIQ(9002318.4,CIEN_",",".06","I")
IF ENDDT]""
IF SNAPDT>ENDDT
QUIT ""
+22 ;
+23 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E")
+24 ;
+25 QUIT CONC
+26 ;
GCDSDTS4(BSTSWS) ;EP - DTS4 update codeset
+1 ;
+2 NEW RESULT,STS,II,BSTSUP,ERROR
+3 ;
+4 SET STS=$$GCDSDTS4^BSTSCMCL(.BSTSWS,.RESULT)
+5 ;
+6 ;Update Local BSTS CODESET file (9002318.1)
+7 SET II=""
FOR
SET II=$ORDER(RESULT(II),-1)
IF II=""
QUIT
Begin DoDot:1
+8 ;
+9 NEW DIC,X,Y,DLAYGO,DIC
+10 SET X=$GET(RESULT(II,"NAMESPACE","ID"))
IF 'X
QUIT
+11 SET DIC(0)="XL"
SET DIC="^BSTS(9002318.1,"
SET DLAYGO=9002318.1
DO ^DIC
+12 IF +Y<0
QUIT
+13 SET BSTSUP(9002318.1,+Y_",",.02)=$GET(RESULT(II,"NAMESPACE","CODE"))
+14 SET BSTSUP(9002318.1,+Y_",",.03)=$GET(RESULT(II,"NAMESPACE","NAME"))
End DoDot:1
+15 IF $DATA(BSTSUP)
DO FILE^DIE("","BSTSUP","ERROR")
+16 ;
+17 QUIT STS
+18 ;
GVRDTS4(BSTSWS) ;EP - DTS4 update versions
+1 ;
+2 NEW RESULT,STS
+3 ;
+4 ;Reset Scratch global and make call to DTS
+5 SET RESULT=$NAME(^TMP("BSTSCMCL",$JOB))
+6 KILL @RESULT
+7 SET STS=$$GVRDTS4^BSTSCMCL(.BSTSWS)
+8 ;
+9 ;Update file with results
+10 IF STS
Begin DoDot:1
+11 NEW NMID,NMIEN,VDT,CNT,VRID,CVID,BSTS,ERR
+12 SET NMID=$GET(BSTSWS("NAMESPACEID"))
+13 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""),-1)
IF NMIEN=""
QUIT
+14 SET (VRID,CNT)=""
FOR
SET CNT=$ORDER(@RESULT@(CNT),-1)
IF 'CNT
QUIT
Begin DoDot:2
+15 SET VDT=""
FOR
SET VDT=$ORDER(@RESULT@(CNT,"VERSION",VDT))
IF VDT=""
QUIT
Begin DoDot:3
+16 NEW RDT,NAME,DA,IENS,BSTSUP,ERROR
+17 SET RDT=$GET(@RESULT@(CNT,"VERSION",VDT,"RELEASEDATE"))
+18 SET NAME=$GET(@RESULT@(CNT,"VERSION",VDT,"NAME"))
+19 ;
+20 ;Look for existing entry
+21 SET DA=$ORDER(^BSTS(9002318.1,NMIEN,1,"B",VDT,""))
+22 ;
+23 ;Create new record
+24 IF DA=""
SET DA=$$NEWV(NMIEN,VDT)
+25 IF +DA<0
QUIT
+26 SET VRID=VDT
+27 SET DA(1)=NMIEN
SET IENS=$$IENS^DILF(.DA)
+28 ;
+29 ;Add/Update remaining fields
+30 SET BSTSUP(9002318.11,IENS,".02")=NAME
+31 ;BSTS*1.0*6;Fixed date issue
+32 ;S BSTSUP(9002318.11,IENS,".03")=RDT
+33 SET BSTSUP(9002318.11,IENS,".03")=$$DTS2FMDT^BSTSUTIL($PIECE(RDT,"."))
+34 DO FILE^DIE("","BSTSUP","ERROR")
End DoDot:3
End DoDot:2
+35 ;
End DoDot:1
+36 QUIT STS
+37 ;
NEWV(NMIEN,VDT) ;Create new ICD Mapping entry
+1 NEW DIC,X,Y,DA,DLAYGO
+2 SET DIC(0)="L"
SET DA(1)=NMIEN
+3 SET DLAYGO=9002318.11
SET DIC="^BSTS(9002318.1,"_DA(1)_",1,"
+4 SET X=VDT
+5 DO ^DIC
+6 QUIT +Y
+7 ;
+8 ;
NEWC() ;Create new concept entry
+1 NEW DIC,X,Y,DLAYGO
+2 SET DIC(0)="L"
SET DIC=9002318.4
+3 LOCK +^BSTS(9002318.4,0):1
IF '$TEST
QUIT ""
+4 SET X=$PIECE($GET(^BSTS(9002318.4,0)),U,3)+1
+5 SET DLAYGO=9002318.4
DO ^DIC
+6 LOCK -^BSTS(9002318.4,0)
+7 QUIT +Y
+8 ;
NEWT() ;Create new terminology entry
+1 NEW DIC,X,Y,DLAYGO
+2 SET DIC(0)="L"
SET DIC=9002318.3
+3 LOCK +^BSTS(9002318.3,0):1
IF '$TEST
QUIT ""
+4 SET X=$PIECE($GET(^BSTS(9002318.3,0)),U,3)+1
+5 SET DLAYGO=9002318.3
DO ^DIC
+6 LOCK -^BSTS(9002318.3,0)
+7 QUIT +Y
+8 ;
NEWI(CIEN) ;Create new ICD Mapping entry
+1 NEW DIC,X,Y,DA,DLAYGO
+2 SET DIC(0)="L"
SET DA(1)=CIEN
+3 SET DIC="^BSTS(9002318.4,"_DA(1)_",3,"
+4 LOCK +^BSTS(9002318.4,CIEN,3,0):1
IF '$TEST
QUIT ""
+5 SET X=$PIECE($GET(^BSTS(9002318.4,CIEN,3,0)),U,3)+1
+6 SET DLAYGO=9002318.43
DO ^DIC
+7 LOCK -^BSTS(9002318.4,CIEN,3,0)
+8 QUIT +Y
