Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLXXCA

APCLXXCA.m

Go to the documentation of this file. 
  1. APCLXXCA ; IHS/OHPRD/TMJ -CREATED BY ^XBERTN ON APR 18, 1996 ;
  1.  ;;3.0;IHS PCC REPORTS;;FEB 05, 1997
  1.  ;;ATXTXCHK ; IHS/OHPRD/TMJ - CHECK CODE AGAINST TAXONOMY ; 
  1.  ;; ;;5.1T1;TAXONOMY SYSTEM;;APR 18, 1996
  1.  ;; ;
  1.  ;; ; This routine checks to see if a specific code is in a specific
  1.  ;; ; taxonomy.
  1.  ;; ;
  1.  ;; ; If the taxonomy entry says the taxonomy is a 'range' of codes, the
  1.  ;; ; lookup is on the AA xref of the 2101 multiple.  Otherwise, the
  1.  ;; ; lookup is on the B xref of the 2101 multiple.  See .16 RANGE field.
  1.  ;; ;
  1.  ;; ; There are many ways the AA xref can be messed up.  It is only set if
  1.  ;; ; a range of codes is specified and it has a " " appended if
  1.  ;; ; non-canonic is set.  It is not set if the high value of the range is
  1.  ;; ; not entered.  If the taxonomy is created with range or non-canonic
  1.  ;; ; set one way, then changed later you may have AA entries missing,
  1.  ;; ; some canonic, and some non-canonic.
  1.  ;; ;
  1.  ;; ; There needs to be a routine that checks the validity of the entries
  1.  ;; ; in the taxonomy file.
  1.  ;; ;
  1.  ;; ; ** I hope the taxonomy dictionary prevents overlapping ranges **
  1.  ;; ; ** I checked.  It does not. It also doesn't prevent the high  **
  1.  ;; ; ** code from being lower than the low code.                   **
  1.  ;; ;
  1.  ;;TXC(ATXCIEN,ATXTIEN,TEST) ;EP-EXTRN FUNC/see if code is in taxonomy
  1.  ;; ; input variables: ATXCIEN=code ien, ATXTIEN=taxonomy ien
  1.  ;; ;                  TEST causes code and hits to be displayed
  1.  ;; ; returns 1 if in taxonomy, otherwise returns 0
  1.  ;; ;
  1.  ;; NEW ATXBEG,ATXEND,ATXFILE,ATXGBL,ATXMIXED,ATXMODE,ATXQ,ATXQV,X,Y
  1.  ;; S (ATXQ,ATXQV)=0
  1.  ;; G:'$G(ATXCIEN) TXCX
  1.  ;; G:'$G(ATXTIEN) TXCX
  1.  ;; D GETCODE ;                                 get code
  1.  ;; G:ATXQ TXCX ;                               can't find code
  1.  ;; D CHKTAX ;                                  check taxonomy
  1.  ;; ; if taxonomy single values instead of code ranges do test & exit
  1.  ;; I 'ATXRANGE S:$D(^ATXAX(ATXTIEN,21,"B",ATXCODE)) ATXQV=1 D  G TXCX
  1.  ;; . Q:'ATXQV  ;                               no hit
  1.  ;; . W:$G(TEST) "  SINGLE VALUES HIT ",!
  1.  ;; . Q
  1.  ;; D SRCHTAX ;                                 search taxonomy for code
  1.  ;;TXCX ;
  1.  ;; Q ATXQV
  1.  ;; ;
  1.  ;;GETCODE ; GET CODE TO CHECK
  1.  ;; S ATXQ=1
  1.  ;; S ATXFILE=$P($G(^ATXAX(ATXTIEN,0)),U,15) ;  get reference file
  1.  ;; Q:ATXFILE="" ;                              quit if no file
  1.  ;; S ATXGBL=$$ROOT^DILFD(ATXFILE) ;            get gbl root to file
  1.  ;; Q:ATXGBL="" ;                               corrupt data dictionary
  1.  ;; S ATXGBL=ATXGBL_ATXCIEN_"," ;               set gbl to entry in file
  1.  ;; S @("ATXCODE=$P($G("_ATXGBL_"0)),U)") ;     get code
  1.  ;; Q:ATXCODE="" ;                              quit if can't find code
  1.  ;; W:$G(TEST) !,"CODE=""",ATXCODE,""""
  1.  ;; S ATXQ=0
  1.  ;; Q
  1.  ;; ;
  1.  ;;CHKTAX ; CHECK TAXONOMY ENTRY
  1.  ;; S ATXRANGE=$P(^ATXAX(ATXTIEN,0),U,16) ;     single value or range
  1.  ;; Q:'ATXRANGE ;                               quit if not range
  1.  ;; ;
  1.  ;; ; When we talk about xref being canonic or non-canonic we are talking
  1.  ;; ; about the AA xref in the taxonomy 2101 multiple.  This has nothing
  1.  ;; ; to do with the file from which the code was retrieved.  Treat as
  1.  ;; ; non-canonic if the dictionary says it is, the xref really is, or
  1.  ;; ; if the passed code is.
  1.  ;; ;
  1.  ;; S ATXNONC=$P(^ATXAX(ATXTIEN,0),U,13) ;      is xref non-canonic?
  1.  ;; S:ATXCODE'=+ATXCODE ATXNONC=1 ;             code non-canonic, force it
  1.  ;; I 'ATXNONC D  ;                             confirm canonic
  1.  ;; . S X=$O(^ATXAX(ATXTIEN,21,"AA","~"),-1),X=$S(X'=+X:1,1:0)
  1.  ;; . S:X ATXNONC=1 ;                           go with what really is
  1.  ;; . Q
  1.  ;; ; see if xref is both canonic and non-canonic (i.e., mixed).
  1.  ;; S X=$O(^ATXAX(ATXTIEN,21,"AA","~"),-1),X=$S(X'=+X:1,1:0)
  1.  ;; S Y=$O(^ATXAX(ATXTIEN,21,"AA","")),Y=$S(Y=+Y:1,1:0)
  1.  ;; S ATXMIXED=((X+Y)-1) ;                      1=mixed mode xref
  1.  ;; Q
  1.  ;; ;
  1.  ;;SRCHTAX ; SEARCH TAXONOMY FOR CODE
  1.  ;; I ATXMIXED D  Q  ;                          mixed mode xref
  1.  ;; . D NONCANON
  1.  ;; . Q:ATXQV
  1.  ;; . D CANONIC
  1.  ;; . Q
  1.  ;; I ATXNONC D NONCANON Q  ;                   non-canonic xref
  1.  ;; D CANONIC ;                                 canonic xref
  1.  ;; Q
  1.  ;; ;
  1.  ;;NONCANON ; NON CANONIC XREF OR CODE
  1.  ;; S X=ATXCODE
  1.  ;; S:$E(X,$L(X))'=" " X=X_" " ;                add " " force non-canonic
  1.  ;; S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",X),-1) ; right before code
  1.  ;; I ATXNXT]"",ATXNXT'=+ATXNXT S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT),-1) ;1 more back to insure $O from atxnxt will not move past atxcode
  1.  ;; F  S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT)) Q:ATXNXT=""  D EQUALIZE(1) Q:ATXBEG]ATXCMPC  D  Q:ATXQV
  1.  ;; . S ATXEND=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT,""))
  1.  ;; . S:ATXEND="" ATXEND=ATXBEG ;               must be single code
  1.  ;; .;actually if no end code no "AA" xref is created (design flaw?)
  1.  ;; . D EQUALIZE(2) ;                           equalize lengths
  1.  ;; . Q:ATXCMPC]ATXEND  ;                       higher than end of range
  1.  ;; . S ATXQV=1 ;                               found code in taxonomy
  1.  ;; . W:$G(TEST) "  NON-CANONIC HIT: RANGE=""",$TR(ATXBEG," ","_"),"""-""",$TR(ATXEND," ","_"),"""",!
  1.  ;; . Q
  1.  ;; Q
  1.  ;; ;
  1.  ;;EQUALIZE(F) ; EQUALIZE LENGTH AND FORCE LAST CHAR TO " "
  1.  ;; NEW A,B,C,X,Y
  1.  ;; S X=$S(F=1:ATXNXT,1:ATXEND)
  1.  ;; S:$E(X,$L(X))="." X=$E(X,1,($L(X)-1)) ;     strip off trailing period
  1.  ;; S X=X_$S($E(X,$L(X))'=" ":" ",1:"")
  1.  ;; S Y=ATXCODE
  1.  ;; S:$E(Y,$L(Y))="." Y=$E(Y,1,($L(Y)-1)) ;     strip off trailing period
  1.  ;; S Y=Y_$S($E(Y,$L(Y))'=" ":" ",1:"")
  1.  ;; S A=$L(X),B=$L(Y)
  1.  ;; I A'=B D  ;                                 pad short var with blanks
  1.  ;; . S $P(C," ",$S(A>B:A-B,1:B-A))=" "
  1.  ;; . I A>B S Y=Y_C I 1
  1.  ;; . E  S X=X_C
  1.  ;; . Q
  1.  ;; S @($S(F=1:"ATXBEG",1:"ATXEND")_"=X,ATXCMPC=Y")
  1.  ;; Q
  1.  ;; ;
  1.  ;;CANONIC ; CANONIC XREF AND CODE
  1.  ;; Q:ATXCODE'=+ATXCODE  ;                      code is not canonic
  1.  ;; S X=ATXCODE
  1.  ;; S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",X),-1) ; right before code
  1.  ;; S:ATXNXT]"" ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT),-1) ;1 more back
  1.  ;; F  S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT)) Q:ATXNXT=""  Q:ATXNXT>ATXCODE  S ATXBEG=ATXNXT D  Q:ATXQV
  1.  ;; . S ATXEND=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT,""))
  1.  ;; . S:ATXEND="" ATXEND=ATXBEG ;               must be single code
  1.  ;; .;actually if no end code no "AA" xref is created (design flaw?)
  1.  ;; . Q:ATXCODE>ATXEND  ;                       higher than end of range
  1.  ;; . S ATXQV=1 ;                               found code in taxonomy
  1.  ;; . W:$G(TEST) "  CANONIC HIT: RANGE=""",ATXBEG,"""-""",ATXEND,"""",!
  1.  ;; . Q
  1.  ;; Q