BSTSDTS3 ;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
;
ACODE(RET,BSTSWS) ;Get list of '36' entries having auto-codable ICD-10s
;
NEW SLIST,DLIST,CNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR
;
S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
S DLIST=$NA(^TMP("BSTSCMCL",$J))
K @DLIST
;
;Retrieve Failover Variables
S MFAIL=$$FPARMS^BSTSVOFL()
S FWAIT=$P(MFAIL,U,2)
S MFAIL=$P(MFAIL,U)
;
;BSTS*1.0*8;Extra error handling
F TR=1:1:60 D I +STS Q
. ;Get List of ICD10 Autocodeables - 32777
. S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$ACODE^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"ACODE^BSTSDTS3 - Call to $$ACODE^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED TO ICD10 MAPPING LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Move results to second scratch global
S CNT=0 F S CNT=$O(@DLIST@(CNT)) Q:'CNT S @SLIST@(CNT)=@DLIST@(CNT)
M @SLIST@("DTS")=@DLIST@("DTS")
;
;Get List of ICD10 Autocodeable Predicates - 32779
K @DLIST
;BSTS*1.0*8;Extra error handling
F TR=1:1:60 D I +STS Q
.S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$ACODEP^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"ACODEP^BSTSDTS3 - Call to $$ACODEP^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED TO ICD10 PREDICATE MAPPING LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Merge results to second scratch global
S CNT=0 F S CNT=$O(@DLIST@(CNT)) Q:'CNT D
. NEW DTSID,LAST
. S DTSID=$P(@DLIST@(CNT),U) Q:DTSID=""
. I $D(@SLIST@("DTS",DTSID)) Q
. S LAST=$O(@SLIST@("A"),-1)+1
. S @SLIST@(LAST)=@DLIST@(CNT)
. S @SLIST@("DTS",DTSID)=LAST
;
;Get list of equivalency concepts
S STS=$$EQLST^BSTSDTS4(DLIST,ABORT,FCNT,STS,TRY,MFAIL,.BSTSWS,.ERSLT,CNT,SLIST,FWAIT)
;
;Get the list of concepts in subsets
S STS=$$SCODE^BSTSDTS4(.BSTSWS,1)
;
;Get last entry
S LENTRY=$O(@SLIST@("A"),-1)
;
;Now process each entry
S (ABORT,CNT)=0 F S CNT=$O(@SLIST@(CNT)) Q:'CNT D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. NEW DTSID,VAR,TRY,FCNT,CIEN,LMOD
. ;
. ;Get DTSId
. S DTSID=$P(@SLIST@(CNT),U) Q:DTSID=""
. ;
. ;Check last modified - skip if today
. S CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
. ;BSTS*1.0*4;Do not do date check
. I CIEN]"" S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I") ;I LMOD'<DT Q
. ;
. S ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
. ;Pull detail from DTS - Hang max of 12 times
. S (ABORT,FCNT)=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"ACODE^BSTSDTS3 - Getting Update for entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED TO ICD10 MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
... S FCNT=0
. ;
. ;Remove entry
. K @SLIST@(CNT)
;
Q STS
;
A9CODE(RET,BSTSWS) ;Get list of '36' entries having auto-codable ICD-9s
;
NEW SLIST,DLIST,CNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR
;
S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
S DLIST=$NA(^TMP("BSTSCMCL",$J))
K @DLIST
;
;Retrieve Failover Variables
S MFAIL=$$FPARMS^BSTSVOFL()
S FWAIT=$P(MFAIL,U,2)
S MFAIL=$P(MFAIL,U)
;
F TR=1:1:60 D I +STS Q
. S (FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$A9CODE^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"A9CODE^BSTSDTS3 - Call to A9CODE^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED TO ICD9 MAPPING LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Get last entry
S LENTRY=$O(@DLIST@(""),-1)
;
;Move results to second scratch global
S CNT=0 F S CNT=$O(@DLIST@(CNT)) Q:'CNT S @SLIST@(CNT)=@DLIST@(CNT)
;
;Now loop through and process each entry
S (ABORT,CNT)=0 F S CNT=$O(@SLIST@(CNT)) Q:'CNT D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. NEW DTSID,VAR,TRY,FCNT,CIEN,LMOD
. ;
. ;Get DTSId
. S DTSID=$P(@SLIST@(CNT),U) Q:DTSID=""
. ;
. ;Check last modified - skip if today
. S CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
. ;BSTS*1.0*4;Do not do date check
. I CIEN]"" S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I") ;I LMOD'<DT Q
. ;
. S ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
. ;Pull detail from DTS - Hang max of 12 times
. S FCNT=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"A9CODE^BSTSDTS3 - Getting Update for entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED TO ICD9 MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
... S FCNT=0
. ;
. ;Remove entry
. K @SLIST@(CNT)
;
;Remove override
K BSTSWS("ONLYLOAD")
;
Q STS
;
CSTMCDST(RET,BSTSWS) ;Get list of custom codeset entries
;
NEW SLIST,DLIST,CNT,NMID,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR
;
S NMID=$G(BSTSWS("NAMESPACEID")) Q:NMID="" 0
;
S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
S DLIST=$NA(^TMP("BSTSCMCL",$J))
K @DLIST
;
;Retrieve Failover Variables
S MFAIL=$$FPARMS^BSTSVOFL()
S FWAIT=$P(MFAIL,U,2)
S MFAIL=$P(MFAIL,U)
;
F TR=1:1:60 D I +STS Q
. S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$CSTMCDST^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Calling CSTMCDST^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Get last entry
S LENTRY=$O(@DLIST@(""),-1)
;
;Move results to second scratch global
S CNT=0 F S CNT=$O(@DLIST@(CNT)) Q:'CNT S @SLIST@(CNT)=@DLIST@(CNT)
;
;Now loop through and process each entry
S (ABORT,CNT)=0 F S CNT=$O(@SLIST@(CNT)) Q:'CNT D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. NEW DTSID,VAR,TRY,FCNT
. ;
. ;Get the DTSId
. S DTSID=$P($G(@SLIST@(CNT)),U) Q:DTSID=""
. ;
. S ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
. ;
. ;Pull detail from DTS - Hang max of 12 times
. S FCNT=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_NMID_"^^^^1") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Getting Update for entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
... S FCNT=0
. ;
. ;Remove entry
. K @SLIST@(CNT)
;
Q STS
;
SUPDATE(NMID,ROUT) ;EP-Add/Update Special Codeset Entries
;
;Special Codesets Only
I ($G(NMID)=5180)!($G(NMID)=1552)!($G(NMID)=36) 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 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 version
S CVRSN=$$GET1^DIQ(9002318.1,INMID_",",.04,"I")
;
;Handle retired concepts
I CONCDA]"",'$$RET(CONCDA,CVRSN,GL) Q 0
;
;None found - create new entry
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 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)=$$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))
;
;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)="L",DIC="^BSTS(9002318.4,"_DA(1)_",4,"
.. S X=$P($G(@GL@("SUB",SB)),U) Q:X=""
.. 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 Associations
;
;Clear out existing entries
D
. NEW AS
. S AS=0 F S AS=$O(^BSTS(9002318.4,CONCDA,9,AS)) Q:'AS D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=AS
.. S DIK="^BSTS(9002318.4,"_DA(1)_",9," D ^DIK
I $D(@GL@("ASC"))>1 D
. ;
. ;
. NEW AS
. S AS="" F S AS=$O(@GL@("ASC",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)_",9,"
.. S X=$P($G(@GL@("ASC",AS)),U) Q:X=""
.. S DLAYGO=9002318.49 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.49,IENS,".02")=$P($G(@GL@("ASC",AS)),U,2)
.. S BSTSC(9002318.49,IENS,".03")=$P($G(@GL@("ASC",AS)),U,3)
;
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
. ;
. ;Pull values
. S TERM=$G(@GL@("SYN",STYPE,TCNT,1)) Q:TERM=""
. ;
. ;Quit if already 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 one
. 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)
;
RET(CONCDA,CVRSN,GL) ;Handle retired concepts
;
;Input
; CONCDA - Pointer to concept file, if populated
; CVRSN - Current codeset version
; GL - Name of scratch global
;
;Output - 1 - Retired Concept
; 0 - Active Concept
;
NEW CURRENT,STATUS
;
S CURRENT=$G(@GL@("CURRENT"))
S STATUS=$G(@GL@("STS"))
;
I STATUS'="A" D Q 0
. ;
. ;Skip if not already defined
. I CONCDA="" Q
. ;
. ;Entry is defined - Mark as out of date
. NEW NROUT,BSTSC,ERR,NRIN,TIEN
. S NRIN=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("CONCEPTID")),U,2))
. S NROUT=$$DTS2FMDT^BSTSUTIL($P(CURRENT,U))
. ;
. ;Update the concept
. S BSTSC(9002318.4,CONCDA_",",.05)=NRIN
. S BSTSC(9002318.4,CONCDA_",",.06)=NROUT
. S BSTSC(9002318.4,CONCDA_",",.11)="N"
. S BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
. S BSTSC(9002318.4,CONCDA_",",.12)=DT
. D FILE^DIE("","BSTSC","ERR")
. ;
. ;Clear out existing subset 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
. ;
. ;Now mark the terms as out of date
. ;
. ;Set up FSN, Synonyms, Preferred
. S TIEN="" F S TIEN=$O(^BSTS(9002318.3,"C",NMID,CONCDA,TIEN),-1) Q:TIEN="" D
.. ;
.. ;Skip if not the same Concept Id
.. I CONCDA'=$$GET1^DIQ(9002318.3,TIEN_",",".03","I") Q
.. ;
.. NEW BSTST,ERR
.. ;
.. ;Save/update other fields
.. S BSTST(9002318.3,TIEN_",",.05)=CVRSN
.. S BSTST(9002318.3,TIEN_",",.06)=NRIN
.. S BSTST(9002318.3,TIEN_",",.07)=NROUT
.. S BSTST(9002318.3,TIEN_",",.1)=DT
.. S BSTST(9002318.3,TIEN_",",.11)="N"
.. D FILE^DIE("","BSTST","ERROR")
.. ;
.. ;Reindex - needed for custom indices
.. D
... NEW DIK,DA
... S DIK="^BSTS(9002318.3,",DA=TIEN
... D IX^DIK
;
Q 1
BSTSDTS3 ;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 ;
ACODE(RET,BSTSWS) ;Get list of '36' entries having auto-codable ICD-10s
+1 ;
+2 NEW SLIST,DLIST,CNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR
+3 ;
+4 ;Returned List
SET SLIST=$NAME(^XTMP("BSTSLCMP"))
+5 SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+6 KILL @DLIST
+7 ;
+8 ;Retrieve Failover Variables
+9 SET MFAIL=$$FPARMS^BSTSVOFL()
+10 SET FWAIT=$PIECE(MFAIL,U,2)
+11 SET MFAIL=$PIECE(MFAIL,U)
+12 ;
+13 ;BSTS*1.0*8;Extra error handling
+14 FOR TR=1:1:60
Begin DoDot:1
+15 ;Get List of ICD10 Autocodeables - 32777
+16 SET (ABORT,FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+17 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+18 SET STS=$$ACODE^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+19 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
HANG FWAIT
SET FCNT=0
+20 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+21 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"ACODE^BSTSDTS3 - Call to $$ACODE^BSTSCMCL")
+22 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED TO ICD10 MAPPING LOOKUP FAILED")
+23 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+24 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+25 ;
+26 ;Quit on failure
+27 IF +STS=0
QUIT 0
+28 ;
+29 ;Move results to second scratch global
+30 SET CNT=0
FOR
SET CNT=$ORDER(@DLIST@(CNT))
IF 'CNT
QUIT
SET @SLIST@(CNT)=@DLIST@(CNT)
+31 MERGE @SLIST@("DTS")=@DLIST@("DTS")
+32 ;
+33 ;Get List of ICD10 Autocodeable Predicates - 32779
+34 KILL @DLIST
+35 ;BSTS*1.0*8;Extra error handling
+36 FOR TR=1:1:60
Begin DoDot:1
+37 SET (ABORT,FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+38 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+39 SET STS=$$ACODEP^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+40 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
HANG FWAIT
SET FCNT=0
+41 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+42 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"ACODEP^BSTSDTS3 - Call to $$ACODEP^BSTSCMCL")
+43 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED TO ICD10 PREDICATE MAPPING LOOKUP FAILED")
+44 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+45 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+46 ;
+47 ;Quit on failure
+48 IF +STS=0
QUIT 0
+49 ;
+50 ;Merge results to second scratch global
+51 SET CNT=0
FOR
SET CNT=$ORDER(@DLIST@(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+52 NEW DTSID,LAST
+53 SET DTSID=$PIECE(@DLIST@(CNT),U)
IF DTSID=""
QUIT
+54 IF $DATA(@SLIST@("DTS",DTSID))
QUIT
+55 SET LAST=$ORDER(@SLIST@("A"),-1)+1
+56 SET @SLIST@(LAST)=@DLIST@(CNT)
+57 SET @SLIST@("DTS",DTSID)=LAST
End DoDot:1
+58 ;
+59 ;Get list of equivalency concepts
+60 SET STS=$$EQLST^BSTSDTS4(DLIST,ABORT,FCNT,STS,TRY,MFAIL,.BSTSWS,.ERSLT,CNT,SLIST,FWAIT)
+61 ;
+62 ;Get the list of concepts in subsets
+63 SET STS=$$SCODE^BSTSDTS4(.BSTSWS,1)
+64 ;
+65 ;Get last entry
+66 SET LENTRY=$ORDER(@SLIST@("A"),-1)
+67 ;
+68 ;Now process each entry
+69 SET (ABORT,CNT)=0
FOR
SET CNT=$ORDER(@SLIST@(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+70 NEW DTSID,VAR,TRY,FCNT,CIEN,LMOD
+71 ;
+72 ;Get DTSId
+73 SET DTSID=$PIECE(@SLIST@(CNT),U)
IF DTSID=""
QUIT
+74 ;
+75 ;Check last modified - skip if today
+76 SET CIEN=$ORDER(^BSTS(9002318.4,"D",36,DTSID,""))
+77 ;BSTS*1.0*4;Do not do date check
+78 ;I LMOD'<DT Q
IF CIEN]""
SET LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I")
+79 ;
+80 SET ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
+81 ;Pull detail from DTS - Hang max of 12 times
+82 SET (ABORT,FCNT)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+83 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+84 SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1")
IF +STS=2!(STS="0^")
QUIT
+85 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+86 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"ACODE^BSTSDTS3 - Getting Update for entry: "_DTSID)
+87 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED TO ICD10 MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
+88 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
QUIT
+89 ;
+90 ;Remove entry
+91 KILL @SLIST@(CNT)
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+92 ;
+93 QUIT STS
+94 ;
A9CODE(RET,BSTSWS) ;Get list of '36' entries having auto-codable ICD-9s
+1 ;
+2 NEW SLIST,DLIST,CNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR
+3 ;
+4 ;Returned List
SET SLIST=$NAME(^XTMP("BSTSLCMP"))
+5 SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+6 KILL @DLIST
+7 ;
+8 ;Retrieve Failover Variables
+9 SET MFAIL=$$FPARMS^BSTSVOFL()
+10 SET FWAIT=$PIECE(MFAIL,U,2)
+11 SET MFAIL=$PIECE(MFAIL,U)
+12 ;
+13 FOR TR=1:1:60
Begin DoDot:1
+14 SET (FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+15 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+16 SET STS=$$A9CODE^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+17 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+18 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"A9CODE^BSTSDTS3 - Call to A9CODE^BSTSCMCL")
+19 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED TO ICD9 MAPPING LOOKUP FAILED")
+20 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+21 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+22 ;
+23 ;Quit on failure
+24 IF +STS=0
QUIT 0
+25 ;
+26 ;Get last entry
+27 SET LENTRY=$ORDER(@DLIST@(""),-1)
+28 ;
+29 ;Move results to second scratch global
+30 SET CNT=0
FOR
SET CNT=$ORDER(@DLIST@(CNT))
IF 'CNT
QUIT
SET @SLIST@(CNT)=@DLIST@(CNT)
+31 ;
+32 ;Now loop through and process each entry
+33 SET (ABORT,CNT)=0
FOR
SET CNT=$ORDER(@SLIST@(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+34 NEW DTSID,VAR,TRY,FCNT,CIEN,LMOD
+35 ;
+36 ;Get DTSId
+37 SET DTSID=$PIECE(@SLIST@(CNT),U)
IF DTSID=""
QUIT
+38 ;
+39 ;Check last modified - skip if today
+40 SET CIEN=$ORDER(^BSTS(9002318.4,"D",36,DTSID,""))
+41 ;BSTS*1.0*4;Do not do date check
+42 ;I LMOD'<DT Q
IF CIEN]""
SET LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I")
+43 ;
+44 SET ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
+45 ;Pull detail from DTS - Hang max of 12 times
+46 SET FCNT=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+47 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+48 SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1")
IF +STS=2!(STS="0^")
QUIT
+49 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+50 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"A9CODE^BSTSDTS3 - Getting Update for entry: "_DTSID)
+51 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED TO ICD9 MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
+52 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
QUIT
+53 ;
+54 ;Remove entry
+55 KILL @SLIST@(CNT)
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+56 ;
+57 ;Remove override
+58 KILL BSTSWS("ONLYLOAD")
+59 ;
+60 QUIT STS
+61 ;
CSTMCDST(RET,BSTSWS) ;Get list of custom codeset entries
+1 ;
+2 NEW SLIST,DLIST,CNT,NMID,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR
+3 ;
+4 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
QUIT 0
+5 ;
+6 ;Returned List
SET SLIST=$NAME(^XTMP("BSTSLCMP"))
+7 SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+8 KILL @DLIST
+9 ;
+10 ;Retrieve Failover Variables
+11 SET MFAIL=$$FPARMS^BSTSVOFL()
+12 SET FWAIT=$PIECE(MFAIL,U,2)
+13 SET MFAIL=$PIECE(MFAIL,U)
+14 ;
+15 FOR TR=1:1:60
Begin DoDot:1
+16 SET (ABORT,FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+17 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+18 SET STS=$$CSTMCDST^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+19 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+20 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Calling CSTMCDST^BSTSCMCL")
+21 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING LOOKUP FAILED")
+22 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+23 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+24 ;
+25 ;Quit on failure
+26 IF +STS=0
QUIT 0
+27 ;
+28 ;Get last entry
+29 SET LENTRY=$ORDER(@DLIST@(""),-1)
+30 ;
+31 ;Move results to second scratch global
+32 SET CNT=0
FOR
SET CNT=$ORDER(@DLIST@(CNT))
IF 'CNT
QUIT
SET @SLIST@(CNT)=@DLIST@(CNT)
+33 ;
+34 ;Now loop through and process each entry
+35 SET (ABORT,CNT)=0
FOR
SET CNT=$ORDER(@SLIST@(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+36 NEW DTSID,VAR,TRY,FCNT
+37 ;
+38 ;Get the DTSId
+39 SET DTSID=$PIECE($GET(@SLIST@(CNT)),U)
IF DTSID=""
QUIT
+40 ;
+41 SET ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
+42 ;
+43 ;Pull detail from DTS - Hang max of 12 times
+44 SET FCNT=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+45 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+46 SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_NMID_"^^^^1")
IF +STS=2!(STS="0^")
QUIT
+47 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+48 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Getting Update for entry: "_DTSID)
+49 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
+50 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
QUIT
+51 ;
+52 ;Remove entry
+53 KILL @SLIST@(CNT)
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+54 ;
+55 QUIT STS
+56 ;
SUPDATE(NMID,ROUT) ;EP-Add/Update Special Codeset Entries
+1 ;
+2 ;Special Codesets Only
+3 IF ($GET(NMID)=5180)!($GET(NMID)=1552)!($GET(NMID)=36)
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 entry
+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 ;Handle retired concepts
+24 IF CONCDA]""
IF '$$RET(CONCDA,CVRSN,GL)
QUIT 0
+25 ;
+26 ;None found - create new entry
+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 concept fields
+36 ;Concept ID
SET BSTSC(9002318.4,CONCDA_",",.02)=$PIECE(@GL@("CONCEPTID"),U)
+37 ;DTS ID
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 ;Need to interim save because subsets look at .07
+48 IF $DATA(BSTSC)
DO FILE^DIE("","BSTSC","ERROR")
+49 ;
+50 ;Save Subsets
+51 ;
+52 ;Clear out existing entries
+53 Begin DoDot:1
+54 NEW SB
+55 SET SB=0
FOR
SET SB=$ORDER(^BSTS(9002318.4,CONCDA,4,SB))
IF 'SB
QUIT
Begin DoDot:2
+56 NEW DA,DIK
+57 SET DA(1)=CONCDA
SET DA=SB
+58 SET DIK="^BSTS(9002318.4,"_DA(1)_",4,"
DO ^DIK
End DoDot:2
End DoDot:1
+59 IF $DATA(@GL@("SUB"))>1
Begin DoDot:1
+60 ;
+61 NEW SB
+62 SET SB=""
FOR
SET SB=$ORDER(@GL@("SUB",SB))
IF SB=""
QUIT
Begin DoDot:2
+63 ;
+64 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+65 SET DA(1)=CONCDA
+66 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",4,"
+67 SET X=$PIECE($GET(@GL@("SUB",SB)),U)
IF X=""
QUIT
+68 SET DLAYGO=9002318.44
DO ^DIC
+69 IF +Y<0
QUIT
+70 SET DA=+Y
+71 SET IENS=$$IENS^DILF(.DA)
+72 SET BSTSC(9002318.44,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("SUB",SB)),U,2))
End DoDot:2
End DoDot:1
+73 ;
+74 ;Save Associations
+75 ;
+76 ;Clear out existing entries
+77 Begin DoDot:1
+78 NEW AS
+79 SET AS=0
FOR
SET AS=$ORDER(^BSTS(9002318.4,CONCDA,9,AS))
IF 'AS
QUIT
Begin DoDot:2
+80 NEW DA,DIK
+81 SET DA(1)=CONCDA
SET DA=AS
+82 SET DIK="^BSTS(9002318.4,"_DA(1)_",9,"
DO ^DIK
End DoDot:2
End DoDot:1
+83 IF $DATA(@GL@("ASC"))>1
Begin DoDot:1
+84 ;
+85 ;
+86 NEW AS
+87 SET AS=""
FOR
SET AS=$ORDER(@GL@("ASC",AS))
IF AS=""
QUIT
Begin DoDot:2
+88 ;
+89 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+90 SET DA(1)=CONCDA
+91 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",9,"
+92 SET X=$PIECE($GET(@GL@("ASC",AS)),U)
IF X=""
QUIT
+93 SET DLAYGO=9002318.49
DO ^DIC
+94 IF +Y<0
QUIT
+95 SET DA=+Y
+96 SET IENS=$$IENS^DILF(.DA)
+97 SET BSTSC(9002318.49,IENS,".02")=$PIECE($GET(@GL@("ASC",AS)),U,2)
+98 SET BSTSC(9002318.49,IENS,".03")=$PIECE($GET(@GL@("ASC",AS)),U,3)
End DoDot:2
End DoDot:1
+99 ;
+100 IF $DATA(BSTSC)
DO FILE^DIE("","BSTSC","ERROR")
+101 ;
+102 ;Now save Terminology entries
+103 ;
+104 ;Synonyms/Preferred/FSN
+105 ;
+106 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
+107 ;
+108 NEW TERM,TYPE,DESC,BSTST,ERROR,TMIEN,AIN
+109 ;
+110 ;Pull values
+111 SET TERM=$GET(@GL@("SYN",STYPE,TCNT,1))
IF TERM=""
QUIT
+112 ;
+113 ;Quit if already found
+114 IF $DATA(TLIST(TERM))
QUIT
+115 SET TLIST(TERM)=""
+116 ;
+117 SET TYPE=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,2)
+118 SET TYPE=$SELECT(TYPE=1:"P",1:"S")
+119 IF TERM=$GET(@GL@("FSN",1))
SET TYPE="F"
+120 SET DESC=$PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U)
IF DESC=""
QUIT
+121 SET AIN=$$EP2FMDT^BSTSUTIL($PIECE($GET(@GL@("SYN",STYPE,TCNT,0)),U,3))
+122 ;
+123 ;Look up entry
+124 SET TMIEN=$ORDER(^BSTS(9002318.3,"D",INMID,DESC,""))
+125 ;
+126 ;Entry not found - create new one
+127 IF TMIEN=""
SET TMIEN=$$NEWT^BSTSDTS0()
+128 IF TMIEN<0
QUIT
+129 ;
+130 ;Save/update other fields
+131 SET BSTST(9002318.3,TMIEN_",",.02)=DESC
+132 SET BSTST(9002318.3,TMIEN_",",.09)=TYPE
+133 SET BSTST(9002318.3,TMIEN_",",1)=TERM
+134 SET BSTST(9002318.3,TMIEN_",",.04)="N"
+135 SET BSTST(9002318.3,TMIEN_",",.05)=CVRSN
+136 SET BSTST(9002318.3,TMIEN_",",.08)=INMID
+137 SET BSTST(9002318.3,TMIEN_",",.03)=CONCDA
+138 SET BSTST(9002318.3,TMIEN_",",.06)=AIN
+139 SET BSTST(9002318.3,TMIEN_",",.1)=DT
+140 SET BSTST(9002318.3,TMIEN_",",.11)="N"
+141 DO FILE^DIE("","BSTST","ERROR")
+142 ;
+143 ;Reindex - needed for custom indices
+144 Begin DoDot:2
+145 NEW DIK,DA
+146 SET DIK="^BSTS(9002318.3,"
SET DA=TMIEN
+147 DO IX^DIK
End DoDot:2
End DoDot:1
+148 ;
+149 ;Need to check for retired concepts again since it may have just been added
+150 SET RTR=$$RET^BSTSDTS3(CONCDA,CVRSN,GL)
+151 ;
+152 QUIT $SELECT($DATA(ERROR):"0^Update Failed",1:1)
+153 ;
RET(CONCDA,CVRSN,GL) ;Handle retired concepts
+1 ;
+2 ;Input
+3 ; CONCDA - Pointer to concept file, if populated
+4 ; CVRSN - Current codeset version
+5 ; GL - Name of scratch global
+6 ;
+7 ;Output - 1 - Retired Concept
+8 ; 0 - Active Concept
+9 ;
+10 NEW CURRENT,STATUS
+11 ;
+12 SET CURRENT=$GET(@GL@("CURRENT"))
+13 SET STATUS=$GET(@GL@("STS"))
+14 ;
+15 IF STATUS'="A"
Begin DoDot:1
+16 ;
+17 ;Skip if not already defined
+18 IF CONCDA=""
QUIT
+19 ;
+20 ;Entry is defined - Mark as out of date
+21 NEW NROUT,BSTSC,ERR,NRIN,TIEN
+22 SET NRIN=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("CONCEPTID")),U,2))
+23 SET NROUT=$$DTS2FMDT^BSTSUTIL($PIECE(CURRENT,U))
+24 ;
+25 ;Update the concept
+26 SET BSTSC(9002318.4,CONCDA_",",.05)=NRIN
+27 SET BSTSC(9002318.4,CONCDA_",",.06)=NROUT
+28 SET BSTSC(9002318.4,CONCDA_",",.11)="N"
+29 SET BSTSC(9002318.4,CONCDA_",",.04)=CVRSN
+30 SET BSTSC(9002318.4,CONCDA_",",.12)=DT
+31 DO FILE^DIE("","BSTSC","ERR")
+32 ;
+33 ;Clear out existing subset entries
+34 Begin DoDot:2
+35 NEW SB
+36 SET SB=0
FOR
SET SB=$ORDER(^BSTS(9002318.4,CONCDA,4,SB))
IF 'SB
QUIT
Begin DoDot:3
+37 NEW DA,DIK
+38 SET DA(1)=CONCDA
SET DA=SB
+39 SET DIK="^BSTS(9002318.4,"_DA(1)_",4,"
DO ^DIK
End DoDot:3
End DoDot:2
+40 ;
+41 ;Now mark the terms as out of date
+42 ;
+43 ;Set up FSN, Synonyms, Preferred
+44 SET TIEN=""
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"C",NMID,CONCDA,TIEN),-1)
IF TIEN=""
QUIT
Begin DoDot:2
+45 ;
+46 ;Skip if not the same Concept Id
+47 IF CONCDA'=$$GET1^DIQ(9002318.3,TIEN_",",".03","I")
QUIT
+48 ;
+49 NEW BSTST,ERR
+50 ;
+51 ;Save/update other fields
+52 SET BSTST(9002318.3,TIEN_",",.05)=CVRSN
+53 SET BSTST(9002318.3,TIEN_",",.06)=NRIN
+54 SET BSTST(9002318.3,TIEN_",",.07)=NROUT
+55 SET BSTST(9002318.3,TIEN_",",.1)=DT
+56 SET BSTST(9002318.3,TIEN_",",.11)="N"
+57 DO FILE^DIE("","BSTST","ERROR")
+58 ;
+59 ;Reindex - needed for custom indices
+60 Begin DoDot:3
+61 NEW DIK,DA
+62 SET DIK="^BSTS(9002318.3,"
SET DA=TIEN
+63 DO IX^DIK
End DoDot:3
End DoDot:2
End DoDot:1
QUIT 0
+64 ;
+65 QUIT 1
