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