BSTSRPT ;GDIT/HS/BEE-Handle retired concepts/terms ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
EN ;EP - Main entry point
;
NEW DIR,X,Y,FIX,CT,BST,TYPE,NMID,RCMP
;
;Determine whether concept or term review
W !!
K BST
S BST(1)="This utility will loop through locally cached BSTS concepts and terms and for any that"
S BST(2)="have been retired, it will attempt to find replacement concepts/terms"
D EN^DDIOL(.BST)
S DIR(0)="S^C:Check for retired concepts;T:Check for retired terms;Q:Quit"
D ^DIR
I Y'="C",Y'="T" G XEN
S TYPE=Y
;
;Determine whether SNOMED or RxNorm
K BST
S BST(1)=" "
S BST(2)="Choose the codeset to report on"
D EN^DDIOL(.BST)
S DIR(0)="S^S:SNOMED;R:RxNorm (Out of Order);Q:Quit"
D ^DIR
I Y'="S" G XEN
;I Y'="S",Y'="R" G XEN
S NMID=$S(Y="S":36,1:1552)
;
;Process concepts
I TYPE="C" D PRINT("CONC^BSTSRPT",NMID) G XEN
;
I TYPE="T" D PRINT("TERM^BSTSRPT",NMID) G XEN
;
XEN Q
;
CONC ;Find list of retired concepts
;
;Validate input
I $G(NMID)="" Q
;
NEW OCONC
;
;Loop through Concept ID index
W !,"Original",?18,"Replacement",?36,"Type",?42,"Desc ID",?54,"Preferred Term"
S OCONC="" F S OCONC=$O(^BSTS(9002318.4,"C",NMID,OCONC)) Q:OCONC="" D
. NEW CIEN
. S CIEN=0 F S CIEN=$O(^BSTS(9002318.4,"C",NMID,OCONC,CIEN)) Q:'CIEN D
.. NEW RETR,RCONC
.. ;
.. ;Quit if not retired or retired after current date
.. S RETR=$$GET1^DIQ(9002318.4,CIEN_",",.06,"I")
.. I (RETR="") Q ;No retired date
.. I (RETR>DT) Q ;Retired date is in the future
.. ;
.. ;Look for replacements
.. W !,OCONC
.. D RCONC(OCONC,NMID,.RCONC)
.. ;
.. ;Handle Same As/Replaced By
.. I $G(RCONC)]"" D Q
... W ?17,"*"
... W ?18,$P(RCONC,U),?36,$P(RCONC,U,4),?42,$P(RCONC,U,3),?54,$E($P(RCONC,U,2),1,80)
.. ;
.. ;Handle Multiple Results
.. I $G(RCONC)="",$O(RCONC(""))]"" D Q
... NEW II
... S II="" F S II=$O(RCONC(II)) Q:II="" D
.... NEW RES
.... W:II'=1 ! W ?18,$P(RCONC(II),U),?36,$P(RCONC(II),U,4),?42,$P(RCONC(II),U,3),?54,$E($P(RCONC(II),U,2),1,80)
.. ;
.. ;No Match
.. W ?18,"No Matches"
;
;Close the device
I $D(IO("Q")) D ^%ZISC
;
Q
;
TERM ;Find list of retired terms
;
;Validate input
I $G(NMID)="" Q
;
NEW ODSCID,NMIEN
;
;Get internal codeset IEN
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
;
;Reset scratch global
K ^TMP("BSTSRPT",$J)
;
;Loop through Description ID index
W !,"Original Desc ID",?18,"Replacement Desc ID",?36,"Type",?42,"Conc ID",?54,"Term"
S ODSCID="" F S ODSCID=$O(^BSTS(9002318.3,"D",NMIEN,ODSCID)) Q:ODSCID="" D
. NEW TIEN
. S TIEN=0 F S TIEN=$O(^BSTS(9002318.3,"D",NMIEN,ODSCID,TIEN)) Q:'TIEN D
.. NEW RETR,RTERM
.. ;
.. ;Quit if not retired or retired after current date
.. S RETR=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
.. I (RETR="") Q ;No retired date
.. I (RETR>DT) Q ;Retired date is in the future
.. ;
.. ;Look for replacements
.. W !,ODSCID
.. D RTERM(ODSCID,NMID,.RTERM)
.. ;
.. ;Handle Exact Replacement
.. I $G(RTERM)]"" D Q
... W ?17,"*"
... W ?18,$P(RTERM,U),?42,$P(RTERM,U,3),?54,$E($P(RTERM,U,2),1,80)
.. ;
.. ;Handle Multiple Results
.. I $G(RTERM)="",$O(RTERM(""))]"" D Q
... NEW II
... S II="" F S II=$O(RTERM(II)) Q:II="" D
.... NEW RES
.... W:II'=1 ! W ?18,$P(RTERM(II),U),?36,$P(RTERM(II),U,4),?42,$P(RTERM(II),U,3),?54,$E($P(RTERM(II),U,2),1,80)
.. ;
.. ;No Match
.. W ?18,"No Matches"
;
;Close the device
I $D(IO("Q")) D ^%ZISC
;
Q
;
RCONC(CONC,NMID,BSTSRET) ;PEP - Return replacement concept(s) for a concept
;
;This routine accepts a concept and namespace ID and returns a list
;of possible replacement concepts if it is retired.
;
;Input:
;CONC - Concept ID
;NMID (Optional) - Namespace ID (36-SNOMED/1552-RxNorm) - Default is 36
;BSTSRET - Return variable array
;
;Output:
;
;If concept still active
;BSTSRET=Passed in Concept ID [1]^Preferred Term of Passed in Concept ID [2]
; ^Preferred Desc ID of Passed in Concept ID [3]
;
;If exact match:
;BSTSRET=Exact Match (EM) Concept ID [1]^EM Preferred Term [2]^EM Preferred Desc ID [3]
; ^EM Type, where: EM Type = R - Replaced By, S - Same As [4]
;
;If no single exact match but possible match(es) available:
;BSTSRET=""
;BSTSRET(#)=Possible Replacement (PR) Concept ID [1]^PR Preferred Term [2]^PR Preferred Desc ID [3]
; ^PR Type, where: PR Type = R - Replaced By, S - Same As, M - May be a [4]
;
;If inactive and no matches available
;BSTSRET=""
;
;Sample call:
;
;>D RCONC^BSTSAPI(495003,36,.RET) ZW RET
;RET="715052003^Disease caused by Capripoxvirus^3301304017^R"
;
NEW STS,DTSID,CIEN,RIEN,MEXCT,BSTSCNT,ICNT,RETR,VAR,TRY,MOD,OOD,LOC
;
;Reset output
S BSTSRET="" S ICNT="" F S ICNT=$O(BSTSRET(ICNT)) Q:ICNT="" K BSTSRET(ICNT)
;
;Quit if no concept or namespace ID passed in
I $G(CONC)="" Q
S:$G(NMID)="" NMID=36
;
;Get the CIEN and DTSID
S CIEN=$O(^BSTS(9002318.4,"C",NMID,CONC,"")) Q:CIEN=""
S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I") Q:DTSID=""
;
;Make sure the concept is up to date
S OOD=$$GET1^DIQ(9002318.4,CIEN_",",".11","I")
S MOD=$$GET1^DIQ(9002318.4,CIEN_",",".12","I")
S LOC=1 I (MOD="")!(OOD="Y") S LOC=""
F TRY=1:1:20 S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_U_NMID_U_U_LOC) Q:(+STS=2) I LOC=1,+STS=1 Q
I '+STS Q
;
;Check for active concept
S RETR=$G(VAR(1,"XRDT"))
I (RETR="")!(RETR>DT) S BSTSRET=$G(VAR(1,"CON"))_U_$G(VAR(1,"PRE","TRM"))_U_$G(VAR(1,"PRE","DSC")) Q
;
;Look at replacement information
S (BSTSCNT,MEXCT,RIEN)=0 F S RIEN=$O(^BSTS(9002318.4,CIEN,17,RIEN)) Q:'RIEN D
. NEW NODE,DA,IENS,VAR,RTYPE,PRET,PREID,XRDT
. S DA(1)=CIEN,DA=RIEN,IENS=$$IENS^DILF(.DA)
. S CONC=$$GET1^DIQ(9002318.417,IENS,.01,"I") Q:CONC=""
. S RTYPE=$$GET1^DIQ(9002318.417,IENS,.03,"I") Q:RTYPE=""
. S STS=$$CNCLKP^BSTSAPI("VAR",CONC_"^"_NMID)
. ;
. ;Skip if not active
. S XRDT=$G(VAR(1,"XRDT"))
. I XRDT]"",XRDT'>DT Q
. ;
. S PRET=$G(VAR(1,"PRE","TRM"))
. S PREID=$G(VAR(1,"PRE","DSC"))
. ;
. ;Look for single exact match - clear if more than one
. I MEXCT=1,(RTYPE="R")!(RTYPE="S") S BSTSRET=""
. I MEXCT=0,(RTYPE="R")!(RTYPE="S") D
.. S BSTSRET=CONC_U_PRET_U_PREID_U_RTYPE
.. S MEXCT=1
. ;
. S BSTSCNT=BSTSCNT+1,BSTSRET(BSTSCNT)=CONC_U_PRET_U_PREID_U_RTYPE
;
;If exact match found, clear out array
I BSTSRET]"" S ICNT="" F S ICNT=$O(BSTSRET(ICNT)) Q:ICNT="" K BSTSRET(ICNT)
;
Q
;
RTERM(DESCID,NMID,BSTSRET) ;PEP - Return replacement term and concept for a term
;
;This routine accepts a Description ID and Namespace ID and returns a
;possible replacement if the term has been retired.
;
;Input:
;DESCID - Description ID
;NMID (Optional) - Namespace ID (36-SNOMED/1552-RxNorm) - Default to 36
;BSTSRET - Return variable array
;
;Output:
;
;If term and underlying concept are still active
;BSTSRET=Passed in Description ID [1]^Term of Passed in Description ID [2]
; ^Concept ID of Passed in Term [3]
;
;If term is inactive but underlying concept is still active
;BSTSRET=Preferred Term Description ID of Underlying Concept [1]
; ^Preferred Term of Underlying Concept [2]
; ^Concept ID of Passed in Term [3]
;
;If both term and underlying concept are inactive it will try to identify an
;exact replacement concept. If one is found:
;1) It will first look for an exact match on the original term. If found:
;BSTSRET=New Description ID of Exact Term [1]^Exact Term [2]
; ^Replacement Concept ID [3]
;2) If no exact match on original term is found:
;BSTSRET=Description ID of Preferred Term of Replacement Concept [1]^Preferred
; Term of Replacement Concept [2]^Replacement Concept ID [3]
;
;If an exact replacement is not found but multiple replacements are:
;BSTSRET=""
;BSTSRET(#)=Possible Replacement (PR) Description ID [1]^PR Term [2]
; ^PR Concept ID [3]^PR Type, where: PR Type = R - Replaced By,
; S - Same As, M - May be a [4]
;
;Sample call:
;>D RTERM^BSTSAPI(1908012,36,.RET) ZW RET
;RET="3301304017^Disease caused by Capripoxvirus^715052003"
;
NEW STS,DTSID,CIEN,TIEN,RIEN,MEXCT,BSTSCNT,ICNT,RETR,VAR,TRY,MOD,OOD,NMIEN,LOC
NEW OCONC,RCONC,CTERM
;
;Reset output
S BSTSRET="" S ICNT="" F S ICNT=$O(BSTSRET(ICNT)) Q:ICNT="" K BSTSRET(ICNT)
;
;Quit if no concept or namespace ID passed in
I $G(DESCID)="" Q
S:$G(NMID)="" NMID=36
;
;Get internal codeset IEN
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
;
;Get the TIEN, CIEN and DTSID
S TIEN=$O(^BSTS(9002318.3,"D",NMIEN,DESCID,"")) Q:TIEN=""
S CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I") Q:CIEN=""
S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I") Q:DTSID=""
S CTERM=$$GET1^DIQ(9002318.3,TIEN_",",1,"I")
;
;Make sure the term is up to date
S OOD=$$GET1^DIQ(9002318.3,TIEN_",",".11","I")
S LOC=1 I OOD="Y" S LOC=""
F TRY=1:1:20 S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_U_NMID_U_U_LOC) Q:(+STS=2) I LOC=1,+STS=1 Q
I '+STS Q
;
;Check if term and underlying concept are active
S RETR=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
I (RETR="")!(RETR'<DT),($G(VAR(1,"XRDT"))="")!($G(VAR(1,"XRDT"))'<DT) D Q
. S BSTSRET=DESCID_U_CTERM_U_$G(VAR(1,"CON"))
;
;Check for inactive term, active concept
I (RETR]""),RETR'>DT,($G(VAR(1,"XRDT"))="")!($G(VAR(1,"XRDT"))'<DT) D Q
. S BSTSRET=$G(VAR(1,"PRE","DSC"))_U_$G(VAR(1,"PRE","TRM"))_U_$G(VAR(1,"CON"))
;
;Checks for replacement concept
;
S OCONC=$G(VAR(1,"CON")) Q:OCONC="" ;Original Concept ID
;
;Look for replacement concept
D RCONC(OCONC,NMID,.RCONC)
;
;Exact Replacement
I $G(RCONC)]"" D Q
. NEW RCONCID,RVAR,STS,SYN
. S RCONCID=$P(RCONC,U) Q:RCONCID=""
. ;
. ;Get information for replacement concept
. S STS=$$CNCLKP^BSTSAPI("RVAR",RCONCID_U_NMID)
. ;
. ;Loop through synonyms looking for exact match
. S SYN="" F S SYN=$O(RVAR(1,"SYN",SYN)) Q:SYN="" D I BSTSRET]"" Q
.. NEW RT
.. S RT=$G(RVAR(1,"SYN",SYN,"TRM")) Q:RT=""
.. I RT'=CTERM Q
.. S BSTSRET=$G(RVAR(1,"SYN",SYN,"DSC"))_U_RT_U_RCONCID
. ;
. ;If not exact match use preferred
. S BSTSRET=$G(RVAR(1,"PRE","DSC"))_U_$G(RVAR(1,"PRE","TRM"))_U_RCONCID
;
;Multiple Replacements
I $O(RCONC(""))]"" D Q
. NEW RCNT,CNT
. S RCNT="" F S RCNT=$O(RCONC(RCNT)) Q:RCNT="" D
.. S CNT=$G(CNT)+1,BSTSRET(CNT)=$P(RCONC(RCNT),U,3)_U_$P(RCONC(RCNT),U,2)_U_$P(RCONC(RCNT),U)_U_$P(RCONC(RCNT),U,4)
Q
;
PRINT(TAG,NMID) ;Print the report
;
N %ZIS,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,POP
S %ZIS="Q"
I TAG["CONC" D
. S %ZIS("A")="Print Inactive Concept Report on Device: ",ZTRTN="CONC^BSTSRPT"
. S ZTDESC="Inactive Concept Report"
I TAG["TERM" D
. S %ZIS("A")="Print Inactive Terms Report on Device: ",ZTRTN="TERM^BSTSRPT"
. S ZTDESC="Inactive Term Report"
;
;Prompt for device
D ^%ZIS I $G(POP) Q
;
;Report queued
I $D(IO("Q")) D Q
. S ZTIO=ION,ZTSAVE("NMID")="" D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Request queued!",1:"Unable to queue job. Request cancelled!")
. D ^%ZISC
;
;Print report
U IO
I TAG["CONC" D CONC
I TAG["TERM" D TERM
;
;Close the device
D ^%ZISC
Q
;
REPL(CONCDA,GL) ;Update replacement concept information
;
;Called from UPDATE^BSTSDTS0
;
I $G(CONCDA)="" Q 0
I $G(GL)="" Q 0
;
;Clear out existing entries
D
. NEW REPCNT
. S REPCNT=0 F S REPCNT=$O(^BSTS(9002318.4,CONCDA,17,REPCNT)) Q:'REPCNT D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=REPCNT
.. S DIK="^BSTS(9002318.4,"_DA(1)_",17," D ^DIK
;
;Now save Replacement Concepts
I $D(@GL@("REP"))>1 D
. ;
. NEW REPCNT
. S REPCNT="" F S REPCNT=$O(@GL@("REP",REPCNT)) Q:REPCNT="" D
.. ;
.. NEW DIC,DA,X,Y,IENS,DLAYGO,NODE,CONC,NMID,DTSID,IREV,OREV,NMIEN,RTYPE,BSTSC,ERROR
.. S NODE=$G(@GL@("REP",REPCNT))
.. ;
.. ;Pull replacement information
.. S CONC=$P(NODE,U) Q:CONC="" ;Replacement concept
.. S NMID=$P(NODE,U,2) Q:NMID="" ;Namespace
.. S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
.. S DTSID=$P(NODE,U,3) Q:DTSID="" ;DTSID
.. S IREV=$P(NODE,U,5) ;Revision In
.. S OREV=$P(NODE,U,6) ;Revision Out
.. S RTYPE=$P(NODE,U,7) ;Replacement Type
.. S RTYPE=$S(RTYPE["SAME":"S",RTYPE["REPLACE":"R",RTYPE["MAY BE":"M",1:"") Q:RTYPE=""
.. ;
.. S DA(1)=CONCDA
.. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",17,"
.. S X=CONC
.. S DLAYGO=9002318.417 D ^DIC
.. ;
.. ;Quit on fail
.. I +Y<0 Q
.. ;
.. ;Save remaining fields
.. S (DA)=+Y,IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.417,IENS,".02")=DTSID
.. S BSTSC(9002318.417,IENS,".03")=RTYPE
.. S BSTSC(9002318.417,IENS,".04")=NMIEN
.. S BSTSC(9002318.417,IENS,".05")=$$DTS2FMDT^BSTSUTIL(IREV,1)
.. S BSTSC(9002318.417,IENS,".06")=$$DTS2FMDT^BSTSUTIL(OREV,1)
.. ;
.. ;Save the information
.. D FILE^DIE("","BSTSC","ERROR")
;
Q
BSTSRPT ;GDIT/HS/BEE-Handle retired concepts/terms ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
EN ;EP - Main entry point
+1 ;
+2 NEW DIR,X,Y,FIX,CT,BST,TYPE,NMID,RCMP
+3 ;
+4 ;Determine whether concept or term review
+5 WRITE !!
+6 KILL BST
+7 SET BST(1)="This utility will loop through locally cached BSTS concepts and terms and for any that"
+8 SET BST(2)="have been retired, it will attempt to find replacement concepts/terms"
+9 DO EN^DDIOL(.BST)
+10 SET DIR(0)="S^C:Check for retired concepts;T:Check for retired terms;Q:Quit"
+11 DO ^DIR
+12 IF Y'="C"
IF Y'="T"
GOTO XEN
+13 SET TYPE=Y
+14 ;
+15 ;Determine whether SNOMED or RxNorm
+16 KILL BST
+17 SET BST(1)=" "
+18 SET BST(2)="Choose the codeset to report on"
+19 DO EN^DDIOL(.BST)
+20 SET DIR(0)="S^S:SNOMED;R:RxNorm (Out of Order);Q:Quit"
+21 DO ^DIR
+22 IF Y'="S"
GOTO XEN
+23 ;I Y'="S",Y'="R" G XEN
+24 SET NMID=$SELECT(Y="S":36,1:1552)
+25 ;
+26 ;Process concepts
+27 IF TYPE="C"
DO PRINT("CONC^BSTSRPT",NMID)
GOTO XEN
+28 ;
+29 IF TYPE="T"
DO PRINT("TERM^BSTSRPT",NMID)
GOTO XEN
+30 ;
XEN QUIT
+1 ;
CONC ;Find list of retired concepts
+1 ;
+2 ;Validate input
+3 IF $GET(NMID)=""
QUIT
+4 ;
+5 NEW OCONC
+6 ;
+7 ;Loop through Concept ID index
+8 WRITE !,"Original",?18,"Replacement",?36,"Type",?42,"Desc ID",?54,"Preferred Term"
+9 SET OCONC=""
FOR
SET OCONC=$ORDER(^BSTS(9002318.4,"C",NMID,OCONC))
IF OCONC=""
QUIT
Begin DoDot:1
+10 NEW CIEN
+11 SET CIEN=0
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,OCONC,CIEN))
IF 'CIEN
QUIT
Begin DoDot:2
+12 NEW RETR,RCONC
+13 ;
+14 ;Quit if not retired or retired after current date
+15 SET RETR=$$GET1^DIQ(9002318.4,CIEN_",",.06,"I")
+16 ;No retired date
IF (RETR="")
QUIT
+17 ;Retired date is in the future
IF (RETR>DT)
QUIT
+18 ;
+19 ;Look for replacements
+20 WRITE !,OCONC
+21 DO RCONC(OCONC,NMID,.RCONC)
+22 ;
+23 ;Handle Same As/Replaced By
+24 IF $GET(RCONC)]""
Begin DoDot:3
+25 WRITE ?17,"*"
+26 WRITE ?18,$PIECE(RCONC,U),?36,$PIECE(RCONC,U,4),?42,$PIECE(RCONC,U,3),?54,$EXTRACT($PIECE(RCONC,U,2),1,80)
End DoDot:3
QUIT
+27 ;
+28 ;Handle Multiple Results
+29 IF $GET(RCONC)=""
IF $ORDER(RCONC(""))]""
Begin DoDot:3
+30 NEW II
+31 SET II=""
FOR
SET II=$ORDER(RCONC(II))
IF II=""
QUIT
Begin DoDot:4
+32 NEW RES
+33 IF II'=1
WRITE !
WRITE ?18,$PIECE(RCONC(II),U),?36,$PIECE(RCONC(II),U,4),?42,$PIECE(RCONC(II),U,3),?54,$EXTRACT($PIECE(RCONC(II),U,2),1,80)
End DoDot:4
End DoDot:3
QUIT
+34 ;
+35 ;No Match
+36 WRITE ?18,"No Matches"
End DoDot:2
End DoDot:1
+37 ;
+38 ;Close the device
+39 IF $DATA(IO("Q"))
DO ^%ZISC
+40 ;
+41 QUIT
+42 ;
TERM ;Find list of retired terms
+1 ;
+2 ;Validate input
+3 IF $GET(NMID)=""
QUIT
+4 ;
+5 NEW ODSCID,NMIEN
+6 ;
+7 ;Get internal codeset IEN
+8 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT
+9 ;
+10 ;Reset scratch global
+11 KILL ^TMP("BSTSRPT",$JOB)
+12 ;
+13 ;Loop through Description ID index
+14 WRITE !,"Original Desc ID",?18,"Replacement Desc ID",?36,"Type",?42,"Conc ID",?54,"Term"
+15 SET ODSCID=""
FOR
SET ODSCID=$ORDER(^BSTS(9002318.3,"D",NMIEN,ODSCID))
IF ODSCID=""
QUIT
Begin DoDot:1
+16 NEW TIEN
+17 SET TIEN=0
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"D",NMIEN,ODSCID,TIEN))
IF 'TIEN
QUIT
Begin DoDot:2
+18 NEW RETR,RTERM
+19 ;
+20 ;Quit if not retired or retired after current date
+21 SET RETR=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
+22 ;No retired date
IF (RETR="")
QUIT
+23 ;Retired date is in the future
IF (RETR>DT)
QUIT
+24 ;
+25 ;Look for replacements
+26 WRITE !,ODSCID
+27 DO RTERM(ODSCID,NMID,.RTERM)
+28 ;
+29 ;Handle Exact Replacement
+30 IF $GET(RTERM)]""
Begin DoDot:3
+31 WRITE ?17,"*"
+32 WRITE ?18,$PIECE(RTERM,U),?42,$PIECE(RTERM,U,3),?54,$EXTRACT($PIECE(RTERM,U,2),1,80)
End DoDot:3
QUIT
+33 ;
+34 ;Handle Multiple Results
+35 IF $GET(RTERM)=""
IF $ORDER(RTERM(""))]""
Begin DoDot:3
+36 NEW II
+37 SET II=""
FOR
SET II=$ORDER(RTERM(II))
IF II=""
QUIT
Begin DoDot:4
+38 NEW RES
+39 IF II'=1
WRITE !
WRITE ?18,$PIECE(RTERM(II),U),?36,$PIECE(RTERM(II),U,4),?42,$PIECE(RTERM(II),U,3),?54,$EXTRACT($PIECE(RTERM(II),U,2),1,80)
End DoDot:4
End DoDot:3
QUIT
+40 ;
+41 ;No Match
+42 WRITE ?18,"No Matches"
End DoDot:2
End DoDot:1
+43 ;
+44 ;Close the device
+45 IF $DATA(IO("Q"))
DO ^%ZISC
+46 ;
+47 QUIT
+48 ;
RCONC(CONC,NMID,BSTSRET) ;PEP - Return replacement concept(s) for a concept
+1 ;
+2 ;This routine accepts a concept and namespace ID and returns a list
+3 ;of possible replacement concepts if it is retired.
+4 ;
+5 ;Input:
+6 ;CONC - Concept ID
+7 ;NMID (Optional) - Namespace ID (36-SNOMED/1552-RxNorm) - Default is 36
+8 ;BSTSRET - Return variable array
+9 ;
+10 ;Output:
+11 ;
+12 ;If concept still active
+13 ;BSTSRET=Passed in Concept ID [1]^Preferred Term of Passed in Concept ID [2]
+14 ; ^Preferred Desc ID of Passed in Concept ID [3]
+15 ;
+16 ;If exact match:
+17 ;BSTSRET=Exact Match (EM) Concept ID [1]^EM Preferred Term [2]^EM Preferred Desc ID [3]
+18 ; ^EM Type, where: EM Type = R - Replaced By, S - Same As [4]
+19 ;
+20 ;If no single exact match but possible match(es) available:
+21 ;BSTSRET=""
+22 ;BSTSRET(#)=Possible Replacement (PR) Concept ID [1]^PR Preferred Term [2]^PR Preferred Desc ID [3]
+23 ; ^PR Type, where: PR Type = R - Replaced By, S - Same As, M - May be a [4]
+24 ;
+25 ;If inactive and no matches available
+26 ;BSTSRET=""
+27 ;
+28 ;Sample call:
+29 ;
+30 ;>D RCONC^BSTSAPI(495003,36,.RET) ZW RET
+31 ;RET="715052003^Disease caused by Capripoxvirus^3301304017^R"
+32 ;
+33 NEW STS,DTSID,CIEN,RIEN,MEXCT,BSTSCNT,ICNT,RETR,VAR,TRY,MOD,OOD,LOC
+34 ;
+35 ;Reset output
+36 SET BSTSRET=""
SET ICNT=""
FOR
SET ICNT=$ORDER(BSTSRET(ICNT))
IF ICNT=""
QUIT
KILL BSTSRET(ICNT)
+37 ;
+38 ;Quit if no concept or namespace ID passed in
+39 IF $GET(CONC)=""
QUIT
+40 IF $GET(NMID)=""
SET NMID=36
+41 ;
+42 ;Get the CIEN and DTSID
+43 SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,CONC,""))
IF CIEN=""
QUIT
+44 SET DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I")
IF DTSID=""
QUIT
+45 ;
+46 ;Make sure the concept is up to date
+47 SET OOD=$$GET1^DIQ(9002318.4,CIEN_",",".11","I")
+48 SET MOD=$$GET1^DIQ(9002318.4,CIEN_",",".12","I")
+49 SET LOC=1
IF (MOD="")!(OOD="Y")
SET LOC=""
+50 FOR TRY=1:1:20
SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_U_NMID_U_U_LOC)
IF (+STS=2)
QUIT
IF LOC=1
IF +STS=1
QUIT
+51 IF '+STS
QUIT
+52 ;
+53 ;Check for active concept
+54 SET RETR=$GET(VAR(1,"XRDT"))
+55 IF (RETR="")!(RETR>DT)
SET BSTSRET=$GET(VAR(1,"CON"))_U_$GET(VAR(1,"PRE","TRM"))_U_$GET(VAR(1,"PRE","DSC"))
QUIT
+56 ;
+57 ;Look at replacement information
+58 SET (BSTSCNT,MEXCT,RIEN)=0
FOR
SET RIEN=$ORDER(^BSTS(9002318.4,CIEN,17,RIEN))
IF 'RIEN
QUIT
Begin DoDot:1
+59 NEW NODE,DA,IENS,VAR,RTYPE,PRET,PREID,XRDT
+60 SET DA(1)=CIEN
SET DA=RIEN
SET IENS=$$IENS^DILF(.DA)
+61 SET CONC=$$GET1^DIQ(9002318.417,IENS,.01,"I")
IF CONC=""
QUIT
+62 SET RTYPE=$$GET1^DIQ(9002318.417,IENS,.03,"I")
IF RTYPE=""
QUIT
+63 SET STS=$$CNCLKP^BSTSAPI("VAR",CONC_"^"_NMID)
+64 ;
+65 ;Skip if not active
+66 SET XRDT=$GET(VAR(1,"XRDT"))
+67 IF XRDT]""
IF XRDT'>DT
QUIT
+68 ;
+69 SET PRET=$GET(VAR(1,"PRE","TRM"))
+70 SET PREID=$GET(VAR(1,"PRE","DSC"))
+71 ;
+72 ;Look for single exact match - clear if more than one
+73 IF MEXCT=1
IF (RTYPE="R")!(RTYPE="S")
SET BSTSRET=""
+74 IF MEXCT=0
IF (RTYPE="R")!(RTYPE="S")
Begin DoDot:2
+75 SET BSTSRET=CONC_U_PRET_U_PREID_U_RTYPE
+76 SET MEXCT=1
End DoDot:2
+77 ;
+78 SET BSTSCNT=BSTSCNT+1
SET BSTSRET(BSTSCNT)=CONC_U_PRET_U_PREID_U_RTYPE
End DoDot:1
+79 ;
+80 ;If exact match found, clear out array
+81 IF BSTSRET]""
SET ICNT=""
FOR
SET ICNT=$ORDER(BSTSRET(ICNT))
IF ICNT=""
QUIT
KILL BSTSRET(ICNT)
+82 ;
+83 QUIT
+84 ;
RTERM(DESCID,NMID,BSTSRET) ;PEP - Return replacement term and concept for a term
+1 ;
+2 ;This routine accepts a Description ID and Namespace ID and returns a
+3 ;possible replacement if the term has been retired.
+4 ;
+5 ;Input:
+6 ;DESCID - Description ID
+7 ;NMID (Optional) - Namespace ID (36-SNOMED/1552-RxNorm) - Default to 36
+8 ;BSTSRET - Return variable array
+9 ;
+10 ;Output:
+11 ;
+12 ;If term and underlying concept are still active
+13 ;BSTSRET=Passed in Description ID [1]^Term of Passed in Description ID [2]
+14 ; ^Concept ID of Passed in Term [3]
+15 ;
+16 ;If term is inactive but underlying concept is still active
+17 ;BSTSRET=Preferred Term Description ID of Underlying Concept [1]
+18 ; ^Preferred Term of Underlying Concept [2]
+19 ; ^Concept ID of Passed in Term [3]
+20 ;
+21 ;If both term and underlying concept are inactive it will try to identify an
+22 ;exact replacement concept. If one is found:
+23 ;1) It will first look for an exact match on the original term. If found:
+24 ;BSTSRET=New Description ID of Exact Term [1]^Exact Term [2]
+25 ; ^Replacement Concept ID [3]
+26 ;2) If no exact match on original term is found:
+27 ;BSTSRET=Description ID of Preferred Term of Replacement Concept [1]^Preferred
+28 ; Term of Replacement Concept [2]^Replacement Concept ID [3]
+29 ;
+30 ;If an exact replacement is not found but multiple replacements are:
+31 ;BSTSRET=""
+32 ;BSTSRET(#)=Possible Replacement (PR) Description ID [1]^PR Term [2]
+33 ; ^PR Concept ID [3]^PR Type, where: PR Type = R - Replaced By,
+34 ; S - Same As, M - May be a [4]
+35 ;
+36 ;Sample call:
+37 ;>D RTERM^BSTSAPI(1908012,36,.RET) ZW RET
+38 ;RET="3301304017^Disease caused by Capripoxvirus^715052003"
+39 ;
+40 NEW STS,DTSID,CIEN,TIEN,RIEN,MEXCT,BSTSCNT,ICNT,RETR,VAR,TRY,MOD,OOD,NMIEN,LOC
+41 NEW OCONC,RCONC,CTERM
+42 ;
+43 ;Reset output
+44 SET BSTSRET=""
SET ICNT=""
FOR
SET ICNT=$ORDER(BSTSRET(ICNT))
IF ICNT=""
QUIT
KILL BSTSRET(ICNT)
+45 ;
+46 ;Quit if no concept or namespace ID passed in
+47 IF $GET(DESCID)=""
QUIT
+48 IF $GET(NMID)=""
SET NMID=36
+49 ;
+50 ;Get internal codeset IEN
+51 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT
+52 ;
+53 ;Get the TIEN, CIEN and DTSID
+54 SET TIEN=$ORDER(^BSTS(9002318.3,"D",NMIEN,DESCID,""))
IF TIEN=""
QUIT
+55 SET CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I")
IF CIEN=""
QUIT
+56 SET DTSID=$$GET1^DIQ(9002318.4,CIEN_",",".08","I")
IF DTSID=""
QUIT
+57 SET CTERM=$$GET1^DIQ(9002318.3,TIEN_",",1,"I")
+58 ;
+59 ;Make sure the term is up to date
+60 SET OOD=$$GET1^DIQ(9002318.3,TIEN_",",".11","I")
+61 SET LOC=1
IF OOD="Y"
SET LOC=""
+62 FOR TRY=1:1:20
SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_U_NMID_U_U_LOC)
IF (+STS=2)
QUIT
IF LOC=1
IF +STS=1
QUIT
+63 IF '+STS
QUIT
+64 ;
+65 ;Check if term and underlying concept are active
+66 SET RETR=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
+67 IF (RETR="")!(RETR'<DT)
IF ($GET(VAR(1,"XRDT"))="")!($GET(VAR(1,"XRDT"))'<DT)
Begin DoDot:1
+68 SET BSTSRET=DESCID_U_CTERM_U_$GET(VAR(1,"CON"))
End DoDot:1
QUIT
+69 ;
+70 ;Check for inactive term, active concept
+71 IF (RETR]"")
IF RETR'>DT
IF ($GET(VAR(1,"XRDT"))="")!($GET(VAR(1,"XRDT"))'<DT)
Begin DoDot:1
+72 SET BSTSRET=$GET(VAR(1,"PRE","DSC"))_U_$GET(VAR(1,"PRE","TRM"))_U_$GET(VAR(1,"CON"))
End DoDot:1
QUIT
+73 ;
+74 ;Checks for replacement concept
+75 ;
+76 ;Original Concept ID
SET OCONC=$GET(VAR(1,"CON"))
IF OCONC=""
QUIT
+77 ;
+78 ;Look for replacement concept
+79 DO RCONC(OCONC,NMID,.RCONC)
+80 ;
+81 ;Exact Replacement
+82 IF $GET(RCONC)]""
Begin DoDot:1
+83 NEW RCONCID,RVAR,STS,SYN
+84 SET RCONCID=$PIECE(RCONC,U)
IF RCONCID=""
QUIT
+85 ;
+86 ;Get information for replacement concept
+87 SET STS=$$CNCLKP^BSTSAPI("RVAR",RCONCID_U_NMID)
+88 ;
+89 ;Loop through synonyms looking for exact match
+90 SET SYN=""
FOR
SET SYN=$ORDER(RVAR(1,"SYN",SYN))
IF SYN=""
QUIT
Begin DoDot:2
+91 NEW RT
+92 SET RT=$GET(RVAR(1,"SYN",SYN,"TRM"))
IF RT=""
QUIT
+93 IF RT'=CTERM
QUIT
+94 SET BSTSRET=$GET(RVAR(1,"SYN",SYN,"DSC"))_U_RT_U_RCONCID
End DoDot:2
IF BSTSRET]""
QUIT
+95 ;
+96 ;If not exact match use preferred
+97 SET BSTSRET=$GET(RVAR(1,"PRE","DSC"))_U_$GET(RVAR(1,"PRE","TRM"))_U_RCONCID
End DoDot:1
QUIT
+98 ;
+99 ;Multiple Replacements
+100 IF $ORDER(RCONC(""))]""
Begin DoDot:1
+101 NEW RCNT,CNT
+102 SET RCNT=""
FOR
SET RCNT=$ORDER(RCONC(RCNT))
IF RCNT=""
QUIT
Begin DoDot:2
+103 SET CNT=$GET(CNT)+1
SET BSTSRET(CNT)=$PIECE(RCONC(RCNT),U,3)_U_$PIECE(RCONC(RCNT),U,2)_U_$PIECE(RCONC(RCNT),U)_U_$PIECE(RCONC(RCNT),U,4)
End DoDot:2
End DoDot:1
QUIT
+104 QUIT
+105 ;
PRINT(TAG,NMID) ;Print the report
+1 ;
+2 NEW %ZIS,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,POP
+3 SET %ZIS="Q"
+4 IF TAG["CONC"
Begin DoDot:1
+5 SET %ZIS("A")="Print Inactive Concept Report on Device: "
SET ZTRTN="CONC^BSTSRPT"
+6 SET ZTDESC="Inactive Concept Report"
End DoDot:1
+7 IF TAG["TERM"
Begin DoDot:1
+8 SET %ZIS("A")="Print Inactive Terms Report on Device: "
SET ZTRTN="TERM^BSTSRPT"
+9 SET ZTDESC="Inactive Term Report"
End DoDot:1
+10 ;
+11 ;Prompt for device
+12 DO ^%ZIS
IF $GET(POP)
QUIT
+13 ;
+14 ;Report queued
+15 IF $DATA(IO("Q"))
Begin DoDot:1
+16 SET ZTIO=ION
SET ZTSAVE("NMID")=""
DO ^%ZTLOAD
+17 WRITE !!,$SELECT($DATA(ZTSK):"Request queued!",1:"Unable to queue job. Request cancelled!")
+18 DO ^%ZISC
End DoDot:1
QUIT
+19 ;
+20 ;Print report
+21 USE IO
+22 IF TAG["CONC"
DO CONC
+23 IF TAG["TERM"
DO TERM
+24 ;
+25 ;Close the device
+26 DO ^%ZISC
+27 QUIT
+28 ;
REPL(CONCDA,GL) ;Update replacement concept information
+1 ;
+2 ;Called from UPDATE^BSTSDTS0
+3 ;
+4 IF $GET(CONCDA)=""
QUIT 0
+5 IF $GET(GL)=""
QUIT 0
+6 ;
+7 ;Clear out existing entries
+8 Begin DoDot:1
+9 NEW REPCNT
+10 SET REPCNT=0
FOR
SET REPCNT=$ORDER(^BSTS(9002318.4,CONCDA,17,REPCNT))
IF 'REPCNT
QUIT
Begin DoDot:2
+11 NEW DA,DIK
+12 SET DA(1)=CONCDA
SET DA=REPCNT
+13 SET DIK="^BSTS(9002318.4,"_DA(1)_",17,"
DO ^DIK
End DoDot:2
End DoDot:1
+14 ;
+15 ;Now save Replacement Concepts
+16 IF $DATA(@GL@("REP"))>1
Begin DoDot:1
+17 ;
+18 NEW REPCNT
+19 SET REPCNT=""
FOR
SET REPCNT=$ORDER(@GL@("REP",REPCNT))
IF REPCNT=""
QUIT
Begin DoDot:2
+20 ;
+21 NEW DIC,DA,X,Y,IENS,DLAYGO,NODE,CONC,NMID,DTSID,IREV,OREV,NMIEN,RTYPE,BSTSC,ERROR
+22 SET NODE=$GET(@GL@("REP",REPCNT))
+23 ;
+24 ;Pull replacement information
+25 ;Replacement concept
SET CONC=$PIECE(NODE,U)
IF CONC=""
QUIT
+26 ;Namespace
SET NMID=$PIECE(NODE,U,2)
IF NMID=""
QUIT
+27 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT
+28 ;DTSID
SET DTSID=$PIECE(NODE,U,3)
IF DTSID=""
QUIT
+29 ;Revision In
SET IREV=$PIECE(NODE,U,5)
+30 ;Revision Out
SET OREV=$PIECE(NODE,U,6)
+31 ;Replacement Type
SET RTYPE=$PIECE(NODE,U,7)
+32 SET RTYPE=$SELECT(RTYPE["SAME":"S",RTYPE["REPLACE":"R",RTYPE["MAY BE":"M",1:"")
IF RTYPE=""
QUIT
+33 ;
+34 SET DA(1)=CONCDA
+35 SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(1)_",17,"
+36 SET X=CONC
+37 SET DLAYGO=9002318.417
DO ^DIC
+38 ;
+39 ;Quit on fail
+40 IF +Y<0
QUIT
+41 ;
+42 ;Save remaining fields
+43 SET (DA)=+Y
SET IENS=$$IENS^DILF(.DA)
+44 SET BSTSC(9002318.417,IENS,".02")=DTSID
+45 SET BSTSC(9002318.417,IENS,".03")=RTYPE
+46 SET BSTSC(9002318.417,IENS,".04")=NMIEN
+47 SET BSTSC(9002318.417,IENS,".05")=$$DTS2FMDT^BSTSUTIL(IREV,1)
+48 SET BSTSC(9002318.417,IENS,".06")=$$DTS2FMDT^BSTSUTIL(OREV,1)
+49 ;
+50 ;Save the information
+51 DO FILE^DIE("","BSTSC","ERROR")
End DoDot:2
End DoDot:1
+52 ;
+53 QUIT
