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 ;
+22 ;Get new entry
+23 SET DA=$$NEWM(CONCDA)
IF 'DA
QUIT
+24 SET DA(1)=CONCDA
+25 SET IENS=$$IENS^DILF(.DA)
+26 ;
+27 ;Map Group
+28 SET MGND=$GET(@GL@("ICD10A",IMCNT,"mapGroup"))
+29 SET MG=$PIECE(MGND,U)
+30 SET MGRIN=$PIECE(MGND,U,2)
+31 SET MGROUT=$PIECE(MGND,U,3)
+32 IF MG]""
Begin DoDot:3
+33 SET BSTSICD(9002318.42,IENS,.02)=MG
+34 SET BSTSICD(9002318.42,IENS,.03)=$$EP2FMDT^BSTSUTIL(MGRIN)
+35 SET BSTSICD(9002318.42,IENS,.04)=$$EP2FMDT^BSTSUTIL(MGROUT)
End DoDot:3
+36 ;
+37 ;Map Priority
+38 SET MPND=$GET(@GL@("ICD10A",IMCNT,"mapPriority"))
+39 SET MP=$PIECE(MPND,U)
+40 SET MPRIN=$PIECE(MPND,U,2)
+41 SET MPROUT=$PIECE(MPND,U,3)
+42 IF MP]""
Begin DoDot:3
+43 SET BSTSICD(9002318.42,IENS,.05)=MP
+44 SET BSTSICD(9002318.42,IENS,.06)=$$EP2FMDT^BSTSUTIL(MPRIN)
+45 SET BSTSICD(9002318.42,IENS,.07)=$$EP2FMDT^BSTSUTIL(MPROUT)
End DoDot:3
+46 ;
+47 ;Map Target
+48 SET MTND=$GET(@GL@("ICD10A",IMCNT,"mapTarget"))
+49 SET MT=$PIECE(MTND,U)
+50 SET MTRIN=$PIECE(MTND,U,2)
+51 SET MTROUT=$PIECE(MTND,U,3)
+52 IF MTND]""
Begin DoDot:3
+53 SET BSTSICD(9002318.42,IENS,.08)=MT
+54 SET BSTSICD(9002318.42,IENS,.09)=$$EP2FMDT^BSTSUTIL(MTRIN)
+55 SET BSTSICD(9002318.42,IENS,.1)=$$EP2FMDT^BSTSUTIL(MTROUT)
End DoDot:3
+56 ;
+57 ;Map Target Name
+58 SET MTN=""
IF $PIECE(MTND,U)]""
Begin DoDot:3
+59 ;
+60 NEW CIEN,NIEN,DA,MIENS
+61 SET CIEN=$ORDER(^ICD9("AB",$PIECE(MTND,U)_" ",""))
IF CIEN=""
QUIT
+62 SET MTNRIN=$ORDER(^ICD9(CIEN,67,"B",""),-1)
IF MTNRIN=""
QUIT
+63 SET NIEN=$ORDER(^ICD9(CIEN,67,"B",MTNRIN,""),-1)
IF NIEN=""
QUIT
+64 SET DA(1)=CIEN
SET DA=NIEN
SET MIENS=$$IENS^DILF(.DA)
+65 SET MTN=$$GET1^DIQ(80.067,MIENS,1,"E")
+66 IF MTN]""
Begin DoDot:4
+67 NEW TXT,VAR
+68 DO WRAP^BSTSUTIL(.TXT,MTN,220)
+69 SET VAR="TXT"
+70 DO WP^DIE(9002318.42,IENS,2,"",VAR)
+71 SET BSTSICD(9002318.42,IENS,5.05)=MTNRIN
+72 SET BSTSICD(9002318.42,IENS,5.06)="@"
End DoDot:4
End DoDot:3
+73 ;
+74 ;Map Advice
+75 SET MAND=$GET(@GL@("ICD10A",IMCNT,"mapAdvice"))
+76 SET MA=$PIECE(MAND,U)
+77 ;
+78 ;Special variable handling/conversion
+79 FOR VR="Initial;First/New episode","Subsequent;Ongoing episode"
IF MA[$PIECE(VR,";")
Begin DoDot:3
+80 NEW PC,NMA
+81 SET NMA=""
FOR PC=1:1:$LENGTH(MA,$PIECE(VR,";"))
SET NMA=NMA_$PIECE(MA,$PIECE(VR,";"),PC)_$SELECT(PC=$LENGTH(MA,$PIECE(VR,";")):"",1:$PIECE(VR,";",2))
+82 SET MA=NMA
End DoDot:3
+83 ;
+84 SET MATRIN=$PIECE(MAND,U,2)
+85 SET MATROUT=$PIECE(MAND,U,3)
+86 IF MA]""
Begin DoDot:3
+87 ;
+88 ;Append ICD Description
+89 IF MTN]""
SET MA=MA_" ["_MTN_"]"
+90 NEW TXT,VAR
+91 DO WRAP^BSTSUTIL(.TXT,MA,220)
+92 SET VAR="TXT"
+93 DO WP^DIE(9002318.42,IENS,1,"",VAR)
+94 SET BSTSICD(9002318.42,IENS,5.01)=$$EP2FMDT^BSTSUTIL(MATRIN)
+95 SET BSTSICD(9002318.42,IENS,5.02)=$$EP2FMDT^BSTSUTIL(MATROUT)
End DoDot:3
+96 ;
+97 ;Map Rule
+98 SET MRND=$GET(@GL@("ICD10A",IMCNT,"mapRule"))
+99 SET MR=$PIECE(MRND,U)
+100 SET MRRIN=$PIECE(MRND,U,2)
+101 SET MRROUT=$PIECE(MRND,U,3)
+102 IF MR]""
Begin DoDot:3
+103 NEW TXT,VAR
+104 DO WRAP^BSTSUTIL(.TXT,MR,220)
+105 SET VAR="TXT"
+106 DO WP^DIE(9002318.42,IENS,3,"",VAR)
+107 SET BSTSICD(9002318.42,IENS,5.03)=$$EP2FMDT^BSTSUTIL(MRRIN)
+108 SET BSTSICD(9002318.42,IENS,5.04)=$$EP2FMDT^BSTSUTIL(MRROUT)
End DoDot:3
+109 ;
+110 ;Map Category Value
+111 SET MCVND=$GET(@GL@("ICD10A",IMCNT,"mapCategoryValue"))
+112 SET MCV=$PIECE(MCVND,U)
+113 SET MCVRIN=$PIECE(MCVND,U,2)
+114 SET MCVROUT=$PIECE(MCVND,U,3)
+115 IF MCV]""
Begin DoDot:3
+116 NEW TXT,VAR
+117 DO WRAP^BSTSUTIL(.TXT,MCV,220)
+118 SET VAR="TXT"
+119 DO WP^DIE(9002318.42,IENS,4,"",VAR)
+120 SET BSTSICD(9002318.42,IENS,5.07)=$$EP2FMDT^BSTSUTIL(MCVRIN)
+121 SET BSTSICD(9002318.42,IENS,5.08)=$$EP2FMDT^BSTSUTIL(MCVROUT)
End DoDot:3
+122 ;
+123 ;File information
+124 IF $DATA(BSTSICD)
DO FILE^DIE("","BSTSICD","ERROR")
End DoDot:2
End DoDot:1
+125 ;
+126 QUIT 1
+127 ;
NEWM(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)_",2,"
+4 LOCK +^BSTS(9002318.4,CIEN,2,0):1
IF '$TEST
QUIT ""
+5 SET X=$PIECE($GET(^BSTS(9002318.4,CIEN,2,0)),U,3)+1
+6 SET DLAYGO=9002318.42
DO ^DIC
+7 LOCK -^BSTS(9002318.4,CIEN,2,0)
+8 QUIT +Y
+9 ;
+10 ;
SUBLST(DLIST,BSTSWS) ;EP - Perform a Web Service Subset Listing
+1 ;
+2 NEW II,STS,SEARCH,STYPE,MAX,DTSID,NMID
+3 NEW BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,ST,ABORT
+4 ;
+5 SET SEARCH=$GET(BSTSWS("SEARCH"))
+6 SET STYPE=$GET(BSTSWS("STYPE"))
+7 ;
+8 ;Determine maximum to return
+9 SET MAX=$GET(BSTSWS("MAXRECS"))
IF MAX=""
SET MAX=25
+10 SET BSTRT=+$GET(BSTSWS("BCTCHRC"))
IF BSTRT=0
SET BSTRT=1
+11 SET BSCNT=+$GET(BSTSWS("BCTCHCT"))
IF BSCNT=0
SET BSCNT=MAX
+12 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+13 ;
+14 ;Perform Lookup on Subset
+15 ;
+16 ;Foreground call
+17 IF $GET(BSTSWS("BSTSBPRC"))=""
Begin DoDot:1
+18 SET STS=$$SUBLST^BSTSCMCL(.BSTSWS,.RES)
IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
End DoDot:1
+19 ;
+20 ;Background call try until completed - Hang max of 12 times
+21 IF $GET(BSTSWS("BSTSBPRC"))=1
Begin DoDot:1
+22 NEW FCNT,MFAIL,FWAIT,TRY
+23 ;
+24 ;Retrieve Failover Variables
+25 SET MFAIL=$$FPARMS^BSTSVOFL()
+26 SET FWAIT=$PIECE(MFAIL,U,2)
+27 SET MFAIL=$PIECE(MFAIL,U)
+28 ;
+29 SET FCNT=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+30 ;Make sure the link is on
DO RESET^BSTSWSV1
+31 SET STS=$$SUBLST^BSTSCMCL(.BSTSWS,.RES)
IF +STS!(STS="0^")
QUIT
+32 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+33 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUBLST^BSTSDTS2 - Retrieving subset: "_$GET(BSTSWS("SUBSET")))
+34 IF ABORT=1
SET STS="0^"
DO ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON SUBSET LOOKUP: "_$GET(BSTSWS("SUBSET")))
+35 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
QUIT
End DoDot:1
+36 ;
+37 QUIT STS
+38 ;
DSCSRCH(OUT,BSTSWS) ;EP - DTS4 Search Call - Description Id Lookup
+1 ;
+2 NEW II,STS,SEARCH,STYPE,MAX,DTSID,NMID
+3 NEW BSTRT,BSCNT,SLIST,DLIST,RES,RCNT,CNT,ST
+4 ;
+5 SET SEARCH=$GET(BSTSWS("SEARCH"))
+6 SET STYPE=$GET(BSTSWS("STYPE"))
+7 ;Sorted List
SET SLIST=$NAME(^TMP("BSTSPDET",$JOB))
+8 ;DTS Return List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+9 KILL @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 ;Perform Lookup on Concept Id
+18 SET STS=$$DSCSRCH^BSTSCMCL(.BSTSWS,.RES)
IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
+19 ;
+20 SET DTSID=$PIECE($GET(@DLIST@(1)),U)
IF DTSID
Begin DoDot:1
+21 ;
+22 ;Loop through results and retrieve detail
+23 ;
+24 NEW STATUS,CONC,ERSLT
+25 ;
+26 ;Update entry
+27 SET BSTSWS("DTSID")=DTSID
+28 ;
+29 ;Clear result file
+30 KILL @DLIST
+31 ;
+32 ;Get Detail for concept
+33 SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
+34 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"Detail Call Status: ",STATUS
+35 ;
+36 ;File the Detail
+37 SET STATUS=$$UPDATE^BSTSDTS0(NMID)
+38 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"Update Call Status: ",STATUS
+39 ;
+40 ;Look to see if concept now logged
+41 SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS,1,1)
+42 IF CONC]""
Begin DoDot:2
+43 SET RCNT=$GET(RCNT)+1
SET @OUT@(RCNT)=CONC_U_DTSID_U_SEARCH
End DoDot:2
QUIT
End DoDot:1
+44 ;
+45 QUIT STS
+46 ;
SUBSET(OUT,BSTSWS) ;EP - DTS4 Get subset list
+1 ;
+2 NEW PRESULT,STS,II,SLIST
+3 ;
+4 ;Set up scratch global
+5 SET SLIST=$NAME(^TMP("BSTSCMCL",$JOB))
KILL @SLIST
+6 ;
+7 ;Call DTS
+8 SET STS=$$SUBSET^BSTSCMCL(.BSTSWS,.PRESULT)
+9 ;
+10 SET II=""
FOR
SET II=$ORDER(@SLIST@(II))
IF II=""
QUIT
SET @OUT@(II)=@SLIST@(II)
+11 KILL @SLIST
+12 ;
+13 QUIT STS
