BSTSRPT.m

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      ;