RA97PST1.m

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 ---RA97PST1   3567     printed  Apr 23, 2025@18:47:57                                                                                                                                                                                                    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