RA97PST1 ;HINES/RVD - Radiology BI-RADS ;10/10/08
;;5.0;RADIOLOGY;**97**;March 16, 1998;Build 6
;
;
BIR(RAX,RALEX,RALEXDT,RALEXSO,RALEXS,RALEXC) ; Example of 'Silent' Lexicon Call
; Return List of Categories w/Lexicon Pointers
;
; Input Variables
;
; RAX Text to Search for (Optional)
;
; RALEX Array name passed by Reference (Required)
;
; RALEXDT Version Date (Optional, default TODAY)
;
; RALEXSO Coding System (file 757.03) For the purposes
; of patch LEX*2.0*55, this may be set to "BIR"
; or <null> (Optional)
;
; RALEXS Source of terminology (file 757.14) For the
; purposes of patch LEX*2.0*55, this may be set
; to "BI-RADS" or "MQSA" (Optional)
;
; BI-RADS = Breast Imaging Reporting & Data System
; MQSA = Mammography Quality Standards Act
;
; RALEXC Source Category of the terminology (file 757.13)
; Frequently a terminology is broken down into
; categories (example, MRI, Ultrasound and/or
; Mammography) For the purposes of patch
; LEX*2.0*55, this is set to "MAMMOGRAPHY
; ASSESSMENT CATEGORIES" (Optional)
;
; Output Variables
;
; RALEX(0) Number of entries
; RALEX(#) Lexicon IEN ^ Text (term) ^ Code
; LEX ICR 2950
;
; NOTE: This API mimics code found in CPRS
;
; Global Variables
; ^TMP("LEXFND") ICR 2950
; ^TMP("LEXHIT") ICR 2950
; ^TMP("LEXSCH") ICR 1609
;
; External References
; LOOK^LEXA ICR 2950
; CONFIG^LEXSET ICR 1609
; $$DT^XLFDT ICR 10103
; SO^LEXA ICR 5386
;
N DIC,RALEXA,RALEXCAT,RALEXCN,RALEXCT,RALEXI,RALEXIEN,RALEXSRC,RALEXSUB,RALEXT,RALEXVDT
N RALEXX S RALEXSUB="WRD" S:$G(RALEXSO)="BIR" RALEXSUB="BI1"
S (RAX,RALEXX)=$G(RAX) S:'$L(RALEXX) RALEXX="BIRAD" S RALEXVDT=$E($G(RALEXDT),1,7)
S:+RALEXVDT'>0!(RALEXVDT'?7N)!(RALEXVDT<3030101) RALEXVDT=$$DT^XLFDT
S:$L($G(RALEXS)) RALEXSRC=$G(RALEXS) S:$L($G(RALEXC)) RALEXCAT=$G(RALEXC)
K ^TMP("LEXSCH",$J) D CONFIG^LEXSET(RALEXSUB,"WRD",RALEXVDT)
S RALEXSUB="WRD" S:$G(RALEXSO)="BIR" RALEXSUB="BI1" S ^TMP("LEXSCH",$J,"DIS",0)="BIR",^TMP("LEXSCH",$J,"LEN",0)=100
K DIC("S"),^TMP("LEXSCH",$J,"FIL",0)
S:$L($G(RALEXSO)) (DIC("S"),^TMP("LEXSCH",$J,"FIL",0))="I +($$SO^LEXU(Y,"""_RALEXSO_""",+($G(RALEXVDT))))>0"
D LOOK^LEXA(RALEXX,RALEXSUB,100,"",RALEXVDT,$G(RALEXSRC),$G(RALEXCAT))
K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
S RALEXI=0 F S RALEXI=$O(LEX("LIST",RALEXI)) Q:+RALEXI'>0 D
. N RALEXIEN,RALEXT,RALEXE,RALEXCT,RALEXCN,RALEXN
. S RALEXT=$G(LEX("LIST",RALEXI)),RALEXIEN=+RALEXT Q:RALEXIEN'>0
. S (RALEXE,RALEXT)=$P(RALEXT,"^",2) Q:'$L(RALEXE)
. S RALEXN=$O(RALEXA(" "),-1)+1,RALEXCN=+($E($P(RALEXT,"Category ",2),1)),RALEXCT="Category "_RALEXCN S:RALEXE["(BI" RALEXE=$P(RALEXE,"(BI",1) S:RALEXE[" *" RALEXE=$P(RALEXE," *",1)
. S RALEXCN=+RALEXCN+1 S:$G(RALEXSO)="BIR" RALEXA(RALEXCN)=RALEXIEN_"^"_RALEXE_"^"_RALEXCT S:$G(RALEXSO)'="BIR" RALEXA(RALEXN)=RALEXIEN_"^"_RALEXT
S:+($O(RALEXA(" "),-1))>0 RALEXA(0)=+($O(RALEXA(" "),-1)) K LEX S (RALEXCT,RALEXI)=0 F S RALEXI=$O(RALEXA(RALEXI)) Q:+RALEXI'>0 D
. Q:'$L($G(RALEXA(RALEXI))) S RALEXCT=RALEXCT+1,RALEX(RALEXCT)=$G(RALEXA(RALEXI)),RALEX(0)=RALEXCT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRA97PST1 3567 printed Dec 13, 2024@02:33:39 Page 2
RA97PST1 ;HINES/RVD - Radiology BI-RADS ;10/10/08
+1 ;;5.0;RADIOLOGY;**97**;March 16, 1998;Build 6
+2 ;
+3 ;
BIR(RAX,RALEX,RALEXDT,RALEXSO,RALEXS,RALEXC) ; Example of 'Silent' Lexicon Call
+1 ; Return List of Categories w/Lexicon Pointers
+2 ;
+3 ; Input Variables
+4 ;
+5 ; RAX Text to Search for (Optional)
+6 ;
+7 ; RALEX Array name passed by Reference (Required)
+8 ;
+9 ; RALEXDT Version Date (Optional, default TODAY)
+10 ;
+11 ; RALEXSO Coding System (file 757.03) For the purposes
+12 ; of patch LEX*2.0*55, this may be set to "BIR"
+13 ; or <null> (Optional)
+14 ;
+15 ; RALEXS Source of terminology (file 757.14) For the
+16 ; purposes of patch LEX*2.0*55, this may be set
+17 ; to "BI-RADS" or "MQSA" (Optional)
+18 ;
+19 ; BI-RADS = Breast Imaging Reporting & Data System
+20 ; MQSA = Mammography Quality Standards Act
+21 ;
+22 ; RALEXC Source Category of the terminology (file 757.13)
+23 ; Frequently a terminology is broken down into
+24 ; categories (example, MRI, Ultrasound and/or
+25 ; Mammography) For the purposes of patch
+26 ; LEX*2.0*55, this is set to "MAMMOGRAPHY
+27 ; ASSESSMENT CATEGORIES" (Optional)
+28 ;
+29 ; Output Variables
+30 ;
+31 ; RALEX(0) Number of entries
+32 ; RALEX(#) Lexicon IEN ^ Text (term) ^ Code
+33 ; LEX ICR 2950
+34 ;
+35 ; NOTE: This API mimics code found in CPRS
+36 ;
+37 ; Global Variables
+38 ; ^TMP("LEXFND") ICR 2950
+39 ; ^TMP("LEXHIT") ICR 2950
+40 ; ^TMP("LEXSCH") ICR 1609
+41 ;
+42 ; External References
+43 ; LOOK^LEXA ICR 2950
+44 ; CONFIG^LEXSET ICR 1609
+45 ; $$DT^XLFDT ICR 10103
+46 ; SO^LEXA ICR 5386
+47 ;
+48 NEW DIC,RALEXA,RALEXCAT,RALEXCN,RALEXCT,RALEXI,RALEXIEN,RALEXSRC,RALEXSUB,RALEXT,RALEXVDT
+49 NEW RALEXX
SET RALEXSUB="WRD"
if $GET(RALEXSO)="BIR"
SET RALEXSUB="BI1"
+50 SET (RAX,RALEXX)=$GET(RAX)
if '$LENGTH(RALEXX)
SET RALEXX="BIRAD"
SET RALEXVDT=$EXTRACT($GET(RALEXDT),1,7)
+51 if +RALEXVDT'>0!(RALEXVDT'?7N)!(RALEXVDT<3030101)
SET RALEXVDT=$$DT^XLFDT
+52 if $LENGTH($GET(RALEXS))
SET RALEXSRC=$GET(RALEXS)
if $LENGTH($GET(RALEXC))
SET RALEXCAT=$GET(RALEXC)
+53 KILL ^TMP("LEXSCH",$JOB)
DO CONFIG^LEXSET(RALEXSUB,"WRD",RALEXVDT)
+54 SET RALEXSUB="WRD"
if $GET(RALEXSO)="BIR"
SET RALEXSUB="BI1"
SET ^TMP("LEXSCH",$JOB,"DIS",0)="BIR"
SET ^TMP("LEXSCH",$JOB,"LEN",0)=100
+55 KILL DIC("S"),^TMP("LEXSCH",$JOB,"FIL",0)
+56 if $LENGTH($GET(RALEXSO))
SET (DIC("S"),^TMP("LEXSCH",$JOB,"FIL",0))="I +($$SO^LEXU(Y,"""_RALEXSO_""",+($G(RALEXVDT))))>0"
+57 DO LOOK^LEXA(RALEXX,RALEXSUB,100,"",RALEXVDT,$GET(RALEXSRC),$GET(RALEXCAT))
+58 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+59 SET RALEXI=0
FOR
SET RALEXI=$ORDER(LEX("LIST",RALEXI))
if +RALEXI'>0
QUIT
Begin DoDot:1
+60 NEW RALEXIEN,RALEXT,RALEXE,RALEXCT,RALEXCN,RALEXN
+61 SET RALEXT=$GET(LEX("LIST",RALEXI))
SET RALEXIEN=+RALEXT
if RALEXIEN'>0
QUIT
+62 SET (RALEXE,RALEXT)=$PIECE(RALEXT,"^",2)
if '$LENGTH(RALEXE)
QUIT
+63 SET RALEXN=$ORDER(RALEXA(" "),-1)+1
SET RALEXCN=+($EXTRACT($PIECE(RALEXT,"Category ",2),1))
SET RALEXCT="Category "_RALEXCN
if RALEXE["(BI"
SET RALEXE=$PIECE(RALEXE,"(BI",1)
if RALEXE[" *"
SET RALEXE=$PIECE(RALEXE," *",1)
+64 SET RALEXCN=+RALEXCN+1
if $GET(RALEXSO)="BIR"
SET RALEXA(RALEXCN)=RALEXIEN_"^"_RALEXE_"^"_RALEXCT
if $GET(RALEXSO)'="BIR"
SET RALEXA(RALEXN)=RALEXIEN_"^"_RALEXT
End DoDot:1
+65 if +($ORDER(RALEXA(" "),-1))>0
SET RALEXA(0)=+($ORDER(RALEXA(" "),-1))
KILL LEX
SET (RALEXCT,RALEXI)=0
FOR
SET RALEXI=$ORDER(RALEXA(RALEXI))
if +RALEXI'>0
QUIT
Begin DoDot:1
+66 if '$LENGTH($GET(RALEXA(RALEXI)))
QUIT
SET RALEXCT=RALEXCT+1
SET RALEX(RALEXCT)=$GET(RALEXA(RALEXI))
SET RALEX(0)=RALEXCT
End DoDot:1
+67 QUIT
