BSTSDTS2.m

BSTSDTS2 ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012  9:53 AM

 ;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36

 ;

 Q

 ;

SEARCH(OUT,BSTSWS) ;EP - DTS4 Search Call

 ;

 N II,STS,SEARCH,STYPE,WORD,MAX,DTSID,NMID

 N BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,DUPLST

 ;

 S SEARCH=$G(BSTSWS("SEARCH"))

 S STYPE=$G(BSTSWS("STYPE"))

 S SLIST=$NA(^TMP("BSTSSLST",$J)) ;Sorted List

 S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List

 K @SLIST,@DLIST,@OUT

 ;

 ;Determine maximum 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")) S:NMID="" NMID=36 S:NMID=30 NMID=36

 ;

 ;Loop through each word

 S BSTSWS("SEARCH")=SEARCH

 ;

 ;Perform DTS Search

 I STYPE="S" S STS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS

 ;

 ;Perform DTS concept search

 I STYPE="F" S STS=$$CONSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS

 ;

 ;Loop through results and retrieve detail

 M @SLIST=@DLIST

 ;

 I $O(@SLIST@(""))]"" S II="",CNT=0 F  S II=$O(@SLIST@(II)) Q:II=""  D

 . NEW STATUS,CONC,ROUT,ERSLT,DSCID

 . ;

 . S DTSID=$P(@SLIST@(II),U) Q:DTSID=""

 . S DSCID=$P(@SLIST@(II),U,2) I STYPE="S",DSCID="" Q

 . ;

 . I $G(BSTSWS("DEBUG")) W !,"DTSID: ",DTSID

 . ;

 . ;Check for batch count

 . I $G(RCNT)'<BSCNT Q

 . ;

 . ;Check for maximum

 . I $G(RCNT)'<MAX Q

 . ;

 . ;Look for detail stored locally

 . ;

 . S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 . I CONC]"" D  Q

 .. S CNT=CNT+1 I CNT<BSTRT Q  ;Check for starting point

 .. S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID_U_DSCID

 . ;

 . ;Not Found or in need of update

 . 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 STATUS: ",STATUS

 . ;

 . ;File the Detail

 . S STATUS=$$UPDATE^BSTSDTS0(NMID)

 . ;

 . I $G(BSTSWS("DEBUG")) W !!,"UPDATE STATUS: ",STATUS

 . ;

 . ;Look again to see if concept now logged

 . S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 . I $G(BSTSWS("DEBUG")) W !!,"CONC: ",CONC

 . I CONC]"" D  Q

 .. S CNT=CNT+1 I CNT<BSTRT Q  ;Check for start point

 .. S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID_U_DSCID

 K @DLIST,@SLIST

 ;

 Q STS

 ;

ICD2SMD(OUT,BSTSWS) ;EP - DTS4 ICD9 to SNOMED mapping retrieval

 ;

 N II,STS,SEARCH,STYPE,WORD,MAX,DTSID,NMID

 N BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,DUPLST

 ;

 S SEARCH=$G(BSTSWS("SEARCH"))

 S STYPE=$G(BSTSWS("STYPE"))

 S SLIST=$NA(^TMP("BSTSPDET",$J)) ;Sorted List

 S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List

 K @SLIST,@DLIST,@OUT

 ;

 ;Determine maximum 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")) S:NMID="" NMID=36 S:NMID=30 NMID=36

 ;

 ;Loop through each word

 S BSTSWS("SEARCH")=SEARCH

 ;

 ;Perform DTS Call

 S STS=$$ICD2SMD^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS

 ;

 ;Loop through results and retrieve detail

 M @SLIST=@DLIST

 I $O(@SLIST@(""))]"" S II="",CNT=0 F  S II=$O(@SLIST@(II)) Q:II=""  D

 . NEW STATUS,CONC,ROUT,ERSLT,DSCID

 . S DTSID=$P(@SLIST@(II),U) Q:DTSID=""

 . S DSCID=$P(@SLIST@(II),U,2) I STYPE="S",DSCID="" Q

 . ;

 . I $G(BSTSWS("DEBUG")) W !,"DTSID: ",DTSID

 . ;

 . ;Check for maximum

 . I $G(RCNT)'<MAX Q

 . ;

 . ;Look for detail stored locally

 . ;

 . S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 . I CONC]"" D  Q

 .. S CNT=CNT+1 I CNT<BSTRT Q  ;Check for starting point

 .. S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID_U_DSCID

 . ;

 . ;Not Found or in need of update

 . 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 STATUS: ",STATUS

 . ;

 . ;File the Detail

 . S STATUS=$$UPDATE^BSTSDTS0(NMID)

 . ;

 . I $G(BSTSWS("DEBUG")) W !!,"UPDATE STATUS: ",STATUS

 . ;

 . ;Look again to see if concept now logged

 . S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 . I $G(BSTSWS("DEBUG")) W !!,"CONC: ",CONC

 . I CONC]"" D  Q

 .. S CNT=CNT+1 I CNT<BSTRT Q  ;Check for start point

 .. S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID_U_DSCID

 K @DLIST,@SLIST

 ;

 Q STS

 ;

ICDMAP(CONCDA,GL) ;EP - Save ICD Mapping information

 ;

 ;BSTS*2.0*1;Switched from using ICD9 mapping advice to ICD10

 NEW DA,DIK,II

 ;

 ;Clear existing entries

 S DA(1)=CONCDA

 S II=0 F  S II=$O(^BSTS(9002318.4,DA(1),2,II)) Q:'II  S DA=II,DIK="^BSTS(9002318.4,"_DA(1)_",2," D ^DIK

 ;

 ;Save ICD Mapping Information

 I $D(@GL@("ICD10A"))>1 D

 . NEW IMCNT

 . S IMCNT="" F  S IMCNT=$O(@GL@("ICD10A",IMCNT)) Q:IMCNT=""  D

 .. NEW DA,IENS,MATND,MAT,MATRIN,MATROUT,BSTSICD

 .. NEW MAND,MA,MARIN,MAROUT

 .. NEW MCVND,MCV,MCVRIN,MCVROUT

 .. NEW MGND,MG,MGRIN,MGROUT

 .. NEW MRND,MR,MRRIN,MRROUT

 .. NEW MTND,MT,MTRIN,MTROUT

 .. NEW MTNND,MTN,MTNRIN,MTNROUT

 .. NEW MPND,MP,MPRIN,MPROUT,VR

 .. ;

 .. ;Get new entry

 .. S DA=$$NEWM(CONCDA) I 'DA Q

 .. S DA(1)=CONCDA

 .. S IENS=$$IENS^DILF(.DA)

 .. ;

 .. ;Map Group

 .. S MGND=$G(@GL@("ICD10A",IMCNT,"mapGroup"))

 .. S MG=$P(MGND,U)

 .. S MGRIN=$P(MGND,U,2)

 .. S MGROUT=$P(MGND,U,3)

 .. I MG]"" D

 ... S BSTSICD(9002318.42,IENS,.02)=MG

 ... S BSTSICD(9002318.42,IENS,.03)=$$EP2FMDT^BSTSUTIL(MGRIN)

 ... S BSTSICD(9002318.42,IENS,.04)=$$EP2FMDT^BSTSUTIL(MGROUT)

 .. ;

 .. ;Map Priority

 .. S MPND=$G(@GL@("ICD10A",IMCNT,"mapPriority"))

 .. S MP=$P(MPND,U)

 .. S MPRIN=$P(MPND,U,2)

 .. S MPROUT=$P(MPND,U,3)

 .. I MP]"" D

 ... S BSTSICD(9002318.42,IENS,.05)=MP

 ... S BSTSICD(9002318.42,IENS,.06)=$$EP2FMDT^BSTSUTIL(MPRIN)

 ... S BSTSICD(9002318.42,IENS,.07)=$$EP2FMDT^BSTSUTIL(MPROUT)

 .. ;

 .. ;Map Target

 .. S MTND=$G(@GL@("ICD10A",IMCNT,"mapTarget"))

 .. S MT=$P(MTND,U)

 .. S MTRIN=$P(MTND,U,2)

 .. S MTROUT=$P(MTND,U,3)

 .. I MTND]"" D

 ... S BSTSICD(9002318.42,IENS,.08)=MT

 ... S BSTSICD(9002318.42,IENS,.09)=$$EP2FMDT^BSTSUTIL(MTRIN)

 ... S BSTSICD(9002318.42,IENS,.1)=$$EP2FMDT^BSTSUTIL(MTROUT)

 .. ;

 .. ;Map Target Name

 .. S MTN="" I $P(MTND,U)]"" D

 ... ;

 ... NEW CIEN,NIEN,DA,MIENS

 ... S CIEN=$O(^ICD9("AB",$P(MTND,U)_" ","")) Q:CIEN=""

 ... S MTNRIN=$O(^ICD9(CIEN,67,"B",""),-1) Q:MTNRIN=""

 ... S NIEN=$O(^ICD9(CIEN,67,"B",MTNRIN,""),-1) Q:NIEN=""

 ... S DA(1)=CIEN,DA=NIEN S MIENS=$$IENS^DILF(.DA)

 ... S MTN=$$GET1^DIQ(80.067,MIENS,1,"E")

 ... I MTN]"" D

 .... N TXT,VAR

 .... D WRAP^BSTSUTIL(.TXT,MTN,220)

 .... S VAR="TXT"

 .... D WP^DIE(9002318.42,IENS,2,"",VAR)

 .... S BSTSICD(9002318.42,IENS,5.05)=MTNRIN

 .... S BSTSICD(9002318.42,IENS,5.06)="@"

 .. ;

 .. ;Map Advice

 .. S MAND=$G(@GL@("ICD10A",IMCNT,"mapAdvice"))

 .. S MA=$P(MAND,U)

 .. ;

 .. ;Special variable handling/conversion

 .. F VR="Initial;First/New episode","Subsequent;Ongoing episode" I MA[$P(VR,";") D

 ... NEW PC,NMA

 ... S NMA="" F PC=1:1:$L(MA,$P(VR,";")) S NMA=NMA_$P(MA,$P(VR,";"),PC)_$S(PC=$L(MA,$P(VR,";")):"",1:$P(VR,";",2))

 ... S MA=NMA

 .. ;

 .. S MATRIN=$P(MAND,U,2)

 .. S MATROUT=$P(MAND,U,3)

 .. I MA]"" D

 ... ;

 ... ;Append ICD Description

 ... I MTN]"" S MA=MA_" ["_MTN_"]"

 ... N TXT,VAR

 ... D WRAP^BSTSUTIL(.TXT,MA,220)

 ... S VAR="TXT"

 ... D WP^DIE(9002318.42,IENS,1,"",VAR)

 ... S BSTSICD(9002318.42,IENS,5.01)=$$EP2FMDT^BSTSUTIL(MATRIN)

 ... S BSTSICD(9002318.42,IENS,5.02)=$$EP2FMDT^BSTSUTIL(MATROUT)

 .. ;

 .. ;Map Rule

 .. S MRND=$G(@GL@("ICD10A",IMCNT,"mapRule"))

 .. S MR=$P(MRND,U)

 .. S MRRIN=$P(MRND,U,2)

 .. S MRROUT=$P(MRND,U,3)

 .. I MR]"" D

 ... N TXT,VAR

 ... D WRAP^BSTSUTIL(.TXT,MR,220)

 ... S VAR="TXT"

 ... D WP^DIE(9002318.42,IENS,3,"",VAR)

 ... S BSTSICD(9002318.42,IENS,5.03)=$$EP2FMDT^BSTSUTIL(MRRIN)

 ... S BSTSICD(9002318.42,IENS,5.04)=$$EP2FMDT^BSTSUTIL(MRROUT)

 .. ;

 .. ;Map Category Value

 .. S MCVND=$G(@GL@("ICD10A",IMCNT,"mapCategoryValue"))

 .. S MCV=$P(MCVND,U)

 .. S MCVRIN=$P(MCVND,U,2)

 .. S MCVROUT=$P(MCVND,U,3)

 .. I MCV]"" D

 ... N TXT,VAR

 ... D WRAP^BSTSUTIL(.TXT,MCV,220)

 ... S VAR="TXT"

 ... D WP^DIE(9002318.42,IENS,4,"",VAR)

 ... S BSTSICD(9002318.42,IENS,5.07)=$$EP2FMDT^BSTSUTIL(MCVRIN)

 ... S BSTSICD(9002318.42,IENS,5.08)=$$EP2FMDT^BSTSUTIL(MCVROUT)

 .. ;

 .. ;File information

 .. I $D(BSTSICD) D FILE^DIE("","BSTSICD","ERROR")

 ;

 Q 1

 ;

NEWM(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)_",2,"

 L +^BSTS(9002318.4,CIEN,2,0):1 E  Q ""

 S X=$P($G(^BSTS(9002318.4,CIEN,2,0)),U,3)+1

 S DLAYGO=9002318.42 D ^DIC

 L -^BSTS(9002318.4,CIEN,2,0)

 Q +Y

 ;

 ;

SUBLST(DLIST,BSTSWS) ;EP - Perform a Web Service Subset Listing

 ;

 N II,STS,SEARCH,STYPE,MAX,DTSID,NMID

 N BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,ST,ABORT

 ;

 S SEARCH=$G(BSTSWS("SEARCH"))

 S STYPE=$G(BSTSWS("STYPE"))

 ;

 ;Determine maximum 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")) S:NMID="" NMID=36 S:NMID=30 NMID=36

 ;

 ;Perform Lookup on Subset

 ;

 ;Foreground call

 I $G(BSTSWS("BSTSBPRC"))="" D

 . S STS=$$SUBLST^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS

 ;

 ;Background call try until completed - Hang max of 12 times

 I $G(BSTSWS("BSTSBPRC"))=1 D

 . NEW FCNT,MFAIL,FWAIT,TRY

 . ;

 . ;Retrieve Failover Variables

 . S MFAIL=$$FPARMS^BSTSVOFL()

 . S FWAIT=$P(MFAIL,U,2)

 . S MFAIL=$P(MFAIL,U)

 . ;

 . S FCNT=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") Q

 .. D RESET^BSTSWSV1 ;Make sure the link is on

 .. S STS=$$SUBLST^BSTSCMCL(.BSTSWS,.RES) I +STS!(STS="0^") Q

 .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling

 ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUBLST^BSTSDTS2 - Retrieving subset: "_$G(BSTSWS("SUBSET")))

 ... I ABORT=1 S STS="0^" D ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON SUBSET LOOKUP: "_$G(BSTSWS("SUBSET")))

 ... S FCNT=0

 ;

 Q STS

 ;

DSCSRCH(OUT,BSTSWS) ;EP - DTS4 Search Call - Description Id 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)) ;Sorted List

 S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List

 K @DLIST,@OUT

 ;

 ;Determine maximum 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")) S:NMID="" NMID=36 S:NMID=30 NMID=36

 ;

 ;Perform Lookup on Concept Id

 S STS=$$DSCSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS

 ;

 S DTSID=$P($G(@DLIST@(1)),U) I DTSID D

 . ;

 . ;Loop through results and retrieve detail

 . ;

 . 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 the Detail

 . S STATUS=$$UPDATE^BSTSDTS0(NMID)

 . I $G(BSTSWS("DEBUG")) W !!,"Update Call Status: ",STATUS

 . ;

 . ;Look to see if concept now logged

 . S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS,1,1)

 . I CONC]"" D  Q

 .. S RCNT=$G(RCNT)+1,@OUT@(RCNT)=CONC_U_DTSID_U_SEARCH

 ;

 Q STS

 ;

SUBSET(OUT,BSTSWS) ;EP - DTS4 Get subset list

 ;

 NEW PRESULT,STS,II,SLIST

 ;

 ;Set up scratch global

 S SLIST=$NA(^TMP("BSTSCMCL",$J)) K @SLIST

 ;

 ;Call DTS

 S STS=$$SUBSET^BSTSCMCL(.BSTSWS,.PRESULT)

 ;

 S II="" F  S II=$O(@SLIST@(II)) Q:II=""  S @OUT@(II)=@SLIST@(II)

 K @SLIST

 ;

 Q STS

BSTSDTS2  ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012  9:53 AM

 +1       ;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36

 +2       ;

 +3        QUIT 

 +4       ;

SEARCH(OUT,BSTSWS) ;EP - DTS4 Search Call

 +1       ;

 +2        NEW II,STS,SEARCH,STYPE,WORD,MAX,DTSID,NMID

 +3        NEW BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,DUPLST

 +4       ;

 +5        SET SEARCH=$GET(BSTSWS("SEARCH"))

 +6        SET STYPE=$GET(BSTSWS("STYPE"))

 +7       ;Sorted List

           SET SLIST=$NAME(^TMP("BSTSSLST",$JOB))

 +8       ;DTS Return List

           SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))

 +9        KILL @SLIST,@DLIST,@OUT

 +10      ;

 +11      ;Determine maximum 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"))

           IF NMID=""

               SET NMID=36

           IF NMID=30

               SET NMID=36

 +16      ;

 +17      ;Loop through each word

 +18       SET BSTSWS("SEARCH")=SEARCH

 +19      ;

 +20      ;Perform DTS Search

 +21       IF STYPE="S"

               SET STS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES)

               IF $GET(BSTSWS("DEBUG"))

                   WRITE !!,STS

 +22      ;

 +23      ;Perform DTS concept search

 +24       IF STYPE="F"

               SET STS=$$CONSRCH^BSTSCMCL(.BSTSWS,.RES)

               IF $GET(BSTSWS("DEBUG"))

                   WRITE !!,STS

 +25      ;

 +26      ;Loop through results and retrieve detail

 +27       MERGE @SLIST=@DLIST

 +28      ;

 +29       IF $ORDER(@SLIST@(""))]""

               SET II=""

               SET CNT=0

               FOR 

                   SET II=$ORDER(@SLIST@(II))

                   IF II=""

                       QUIT 

                   Begin DoDot:1

 +30                   NEW STATUS,CONC,ROUT,ERSLT,DSCID

 +31      ;

 +32                   SET DTSID=$PIECE(@SLIST@(II),U)

                       IF DTSID=""

                           QUIT 

 +33                   SET DSCID=$PIECE(@SLIST@(II),U,2)

                       IF STYPE="S"

                           IF DSCID=""

                               QUIT 

 +34      ;

 +35                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !,"DTSID: ",DTSID

 +36      ;

 +37      ;Check for batch count

 +38                   IF $GET(RCNT)'<BSCNT

                           QUIT 

 +39      ;

 +40      ;Check for maximum

 +41                   IF $GET(RCNT)'<MAX

                           QUIT 

 +42      ;

 +43      ;Look for detail stored locally

 +44      ;

 +45                   SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 +46                   IF CONC]""

                           Begin DoDot:2

 +47      ;Check for starting point

                               SET CNT=CNT+1

                               IF CNT<BSTRT

                                   QUIT 

 +48                           SET RCNT=$GET(RCNT)+1

                               SET @OUT@(RCNT)=CONC_U_DTSID_U_DSCID

                           End DoDot:2

                           QUIT 

 +49      ;

 +50      ;Not Found or in need of update

 +51                   SET BSTSWS("DTSID")=DTSID

 +52      ;

 +53      ;Clear result file

 +54                   KILL @DLIST

 +55      ;

 +56      ;Get Detail for concept

 +57                   SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)

 +58      ;

 +59                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !!,"DETAIL STATUS: ",STATUS

 +60      ;

 +61      ;File the Detail

 +62                   SET STATUS=$$UPDATE^BSTSDTS0(NMID)

 +63      ;

 +64                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !!,"UPDATE STATUS: ",STATUS

 +65      ;

 +66      ;Look again to see if concept now logged

 +67                   SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 +68                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !!,"CONC: ",CONC

 +69                   IF CONC]""

                           Begin DoDot:2

 +70      ;Check for start point

                               SET CNT=CNT+1

                               IF CNT<BSTRT

                                   QUIT 

 +71                           SET RCNT=$GET(RCNT)+1

                               SET @OUT@(RCNT)=CONC_U_DTSID_U_DSCID

                           End DoDot:2

                           QUIT 

                   End DoDot:1

 +72       KILL @DLIST,@SLIST

 +73      ;

 +74       QUIT STS

 +75      ;

ICD2SMD(OUT,BSTSWS) ;EP - DTS4 ICD9 to SNOMED mapping retrieval

 +1       ;

 +2        NEW II,STS,SEARCH,STYPE,WORD,MAX,DTSID,NMID

 +3        NEW BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,DUPLST

 +4       ;

 +5        SET SEARCH=$GET(BSTSWS("SEARCH"))

 +6        SET STYPE=$GET(BSTSWS("STYPE"))

 +7       ;Sorted List

           SET SLIST=$NAME(^TMP("BSTSPDET",$JOB))

 +8       ;DTS Return List

           SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))

 +9        KILL @SLIST,@DLIST,@OUT

 +10      ;

 +11      ;Determine maximum 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"))

           IF NMID=""

               SET NMID=36

           IF NMID=30

               SET NMID=36

 +16      ;

 +17      ;Loop through each word

 +18       SET BSTSWS("SEARCH")=SEARCH

 +19      ;

 +20      ;Perform DTS Call

 +21       SET STS=$$ICD2SMD^BSTSCMCL(.BSTSWS,.RES)

           IF $GET(BSTSWS("DEBUG"))

               WRITE !!,STS

 +22      ;

 +23      ;Loop through results and retrieve detail

 +24       MERGE @SLIST=@DLIST

 +25       IF $ORDER(@SLIST@(""))]""

               SET II=""

               SET CNT=0

               FOR 

                   SET II=$ORDER(@SLIST@(II))

                   IF II=""

                       QUIT 

                   Begin DoDot:1

 +26                   NEW STATUS,CONC,ROUT,ERSLT,DSCID

 +27                   SET DTSID=$PIECE(@SLIST@(II),U)

                       IF DTSID=""

                           QUIT 

 +28                   SET DSCID=$PIECE(@SLIST@(II),U,2)

                       IF STYPE="S"

                           IF DSCID=""

                               QUIT 

 +29      ;

 +30                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !,"DTSID: ",DTSID

 +31      ;

 +32      ;Check for maximum

 +33                   IF $GET(RCNT)'<MAX

                           QUIT 

 +34      ;

 +35      ;Look for detail stored locally

 +36      ;

 +37                   SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 +38                   IF CONC]""

                           Begin DoDot:2

 +39      ;Check for starting point

                               SET CNT=CNT+1

                               IF CNT<BSTRT

                                   QUIT 

 +40                           SET RCNT=$GET(RCNT)+1

                               SET @OUT@(RCNT)=CONC_U_DTSID_U_DSCID

                           End DoDot:2

                           QUIT 

 +41      ;

 +42      ;Not Found or in need of update

 +43                   SET BSTSWS("DTSID")=DTSID

 +44      ;

 +45      ;Clear result file

 +46                   KILL @DLIST

 +47      ;

 +48      ;Get Detail for concept

 +49                   SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)

 +50      ;

 +51                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !!,"DETAIL STATUS: ",STATUS

 +52      ;

 +53      ;File the Detail

 +54                   SET STATUS=$$UPDATE^BSTSDTS0(NMID)

 +55      ;

 +56                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !!,"UPDATE STATUS: ",STATUS

 +57      ;

 +58      ;Look again to see if concept now logged

 +59                   SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)

 +60                   IF $GET(BSTSWS("DEBUG"))

                           WRITE !!,"CONC: ",CONC

 +61                   IF CONC]""

                           Begin DoDot:2

 +62      ;Check for start point

                               SET CNT=CNT+1

                               IF CNT<BSTRT

                                   QUIT 

 +63                           SET RCNT=$GET(RCNT)+1

                               SET @OUT@(RCNT)=CONC_U_DTSID_U_DSCID

                           End DoDot:2

                           QUIT 

                   End DoDot:1

 +64       KILL @DLIST,@SLIST

 +65      ;

 +66       QUIT STS

 +67      ;

ICDMAP(CONCDA,GL) ;EP - Save ICD Mapping information

 +1       ;

 +2       ;BSTS*2.0*1;Switched from using ICD9 mapping advice to ICD10

 +3        NEW DA,DIK,II

 +4       ;

 +5       ;Clear existing entries

 +6        SET DA(1)=CONCDA

 +7        SET II=0

           FOR 

               SET II=$ORDER(^BSTS(9002318.4,DA(1),2,II))

               IF 'II

                   QUIT 

               SET DA=II

               SET DIK="^BSTS(9002318.4,"_DA(1)_",2,"

               DO ^DIK

 +8       ;

 +9       ;Save ICD Mapping Information

 +10       IF $DATA(@GL@("ICD10A"))>1

               Begin DoDot:1

 +11               NEW IMCNT

 +12               SET IMCNT=""

                   FOR 

                       SET IMCNT=$ORDER(@GL@("ICD10A",IMCNT))

                       IF IMCNT=""

                           QUIT 

                       Begin DoDot:2

 +13                       NEW DA,IENS,MATND,MAT,MATRIN,MATROUT,BSTSICD

 +14                       NEW MAND,MA,MARIN,MAROUT

 +15                       NEW MCVND,MCV,MCVRIN,MCVROUT

 +16                       NEW MGND,MG,MGRIN,MGROUT

 +17                       NEW MRND,MR,MRRIN,MRROUT

 +18                       NEW MTND,MT,MTRIN,MTROUT

 +19                       NEW MTNND,MTN,MTNRIN,MTNROUT

 +20                       NEW MPND,MP,MPRIN,MPROUT,VR

 +21      ;