BSTSDTS1.m

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=""