APCLXXCA ; IHS/OHPRD/TMJ -CREATED BY ^XBERTN ON APR 18, 1996 ;
;;3.0;IHS PCC REPORTS;;FEB 05, 1997
;;ATXTXCHK ; IHS/OHPRD/TMJ - CHECK CODE AGAINST TAXONOMY ;
;; ;;5.1T1;TAXONOMY SYSTEM;;APR 18, 1996
;; ;
;; ; 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
APCLXXCA ; IHS/OHPRD/TMJ -CREATED BY ^XBERTN ON APR 18, 1996 ;
+1 ;;3.0;IHS PCC REPORTS;;FEB 05, 1997
+2 ;;ATXTXCHK ; IHS/OHPRD/TMJ - CHECK CODE AGAINST TAXONOMY ;
+3 ;; ;;5.1T1;TAXONOMY SYSTEM;;APR 18, 1996
+4 ;; ;
+5 ;; ; This routine checks to see if a specific code is in a specific
+6 ;; ; taxonomy.
+7 ;; ;
+8 ;; ; If the taxonomy entry says the taxonomy is a 'range' of codes, the
+9 ;; ; lookup is on the AA xref of the 2101 multiple. Otherwise, the
+10 ;; ; lookup is on the B xref of the 2101 multiple. See .16 RANGE field.
+11 ;; ;
+12 ;; ; There are many ways the AA xref can be messed up. It is only set if
+13 ;; ; a range of codes is specified and it has a " " appended if
+14 ;; ; non-canonic is set. It is not set if the high value of the range is
+15 ;; ; not entered. If the taxonomy is created with range or non-canonic
+16 ;; ; set one way, then changed later you may have AA entries missing,
+17 ;; ; some canonic, and some non-canonic.
+18 ;; ;
+19 ;; ; There needs to be a routine that checks the validity of the entries
+20 ;; ; in the taxonomy file.
+21 ;; ;
+22 ;; ; ** I hope the taxonomy dictionary prevents overlapping ranges **
+23 ;; ; ** I checked. It does not. It also doesn't prevent the high **
+24 ;; ; ** code from being lower than the low code. **
+25 ;; ;
+26 ;;TXC(ATXCIEN,ATXTIEN,TEST) ;EP-EXTRN FUNC/see if code is in taxonomy
+27 ;; ; input variables: ATXCIEN=code ien, ATXTIEN=taxonomy ien
+28 ;; ; TEST causes code and hits to be displayed
+29 ;; ; returns 1 if in taxonomy, otherwise returns 0
+30 ;; ;
+31 ;; NEW ATXBEG,ATXEND,ATXFILE,ATXGBL,ATXMIXED,ATXMODE,ATXQ,ATXQV,X,Y
+32 ;; S (ATXQ,ATXQV)=0
+33 ;; G:'$G(ATXCIEN) TXCX
+34 ;; G:'$G(ATXTIEN) TXCX
+35 ;; D GETCODE ; get code
+36 ;; G:ATXQ TXCX ; can't find code
+37 ;; D CHKTAX ; check taxonomy
+38 ;; ; if taxonomy single values instead of code ranges do test & exit
+39 ;; I 'ATXRANGE S:$D(^ATXAX(ATXTIEN,21,"B",ATXCODE)) ATXQV=1 D G TXCX
+40 ;; . Q:'ATXQV ; no hit
+41 ;; . W:$G(TEST) " SINGLE VALUES HIT ",!
+42 ;; . Q
+43 ;; D SRCHTAX ; search taxonomy for code
+44 ;;TXCX ;
+45 ;; Q ATXQV
+46 ;; ;
+47 ;;GETCODE ; GET CODE TO CHECK
+48 ;; S ATXQ=1
+49 ;; S ATXFILE=$P($G(^ATXAX(ATXTIEN,0)),U,15) ; get reference file
+50 ;; Q:ATXFILE="" ; quit if no file
+51 ;; S ATXGBL=$$ROOT^DILFD(ATXFILE) ; get gbl root to file
+52 ;; Q:ATXGBL="" ; corrupt data dictionary
+53 ;; S ATXGBL=ATXGBL_ATXCIEN_"," ; set gbl to entry in file
+54 ;; S @("ATXCODE=$P($G("_ATXGBL_"0)),U)") ; get code
+55 ;; Q:ATXCODE="" ; quit if can't find code
+56 ;; W:$G(TEST) !,"CODE=""",ATXCODE,""""
+57 ;; S ATXQ=0
+58 ;; Q
+59 ;; ;
+60 ;;CHKTAX ; CHECK TAXONOMY ENTRY
+61 ;; S ATXRANGE=$P(^ATXAX(ATXTIEN,0),U,16) ; single value or range
+62 ;; Q:'ATXRANGE ; quit if not range
+63 ;; ;
+64 ;; ; When we talk about xref being canonic or non-canonic we are talking
+65 ;; ; about the AA xref in the taxonomy 2101 multiple. This has nothing
+66 ;; ; to do with the file from which the code was retrieved. Treat as
+67 ;; ; non-canonic if the dictionary says it is, the xref really is, or
+68 ;; ; if the passed code is.
+69 ;; ;
+70 ;; S ATXNONC=$P(^ATXAX(ATXTIEN,0),U,13) ; is xref non-canonic?
+71 ;; S:ATXCODE'=+ATXCODE ATXNONC=1 ; code non-canonic, force it
+72 ;; I 'ATXNONC D ; confirm canonic
+73 ;; . S X=$O(^ATXAX(ATXTIEN,21,"AA","~"),-1),X=$S(X'=+X:1,1:0)
+74 ;; . S:X ATXNONC=1 ; go with what really is
+75 ;; . Q
+76 ;; ; see if xref is both canonic and non-canonic (i.e., mixed).
+77 ;; S X=$O(^ATXAX(ATXTIEN,21,"AA","~"),-1),X=$S(X'=+X:1,1:0)
+78 ;; S Y=$O(^ATXAX(ATXTIEN,21,"AA","")),Y=$S(Y=+Y:1,1:0)
+79 ;; S ATXMIXED=((X+Y)-1) ; 1=mixed mode xref
+80 ;; Q
+81 ;; ;
+82 ;;SRCHTAX ; SEARCH TAXONOMY FOR CODE
+83 ;; I ATXMIXED D Q ; mixed mode xref
+84 ;; . D NONCANON
+85 ;; . Q:ATXQV
+86 ;; . D CANONIC
+87 ;; . Q
+88 ;; I ATXNONC D NONCANON Q ; non-canonic xref
+89 ;; D CANONIC ; canonic xref
+90 ;; Q
+91 ;; ;
+92 ;;NONCANON ; NON CANONIC XREF OR CODE
+93 ;; S X=ATXCODE
+94 ;; S:$E(X,$L(X))'=" " X=X_" " ; add " " force non-canonic
+95 ;; S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",X),-1) ; right before code
+96 ;; 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
+97 ;; F S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT)) Q:ATXNXT="" D EQUALIZE(1) Q:ATXBEG]ATXCMPC D Q:ATXQV
+98 ;; . S ATXEND=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT,""))
+99 ;; . S:ATXEND="" ATXEND=ATXBEG ; must be single code
+100 ;; .;actually if no end code no "AA" xref is created (design flaw?)
+101 ;; . D EQUALIZE(2) ; equalize lengths
+102 ;; . Q:ATXCMPC]ATXEND ; higher than end of range
+103 ;; . S ATXQV=1 ; found code in taxonomy
+104 ;; . W:$G(TEST) " NON-CANONIC HIT: RANGE=""",$TR(ATXBEG," ","_"),"""-""",$TR(ATXEND," ","_"),"""",!
+105 ;; . Q
+106 ;; Q
+107 ;; ;
+108 ;;EQUALIZE(F) ; EQUALIZE LENGTH AND FORCE LAST CHAR TO " "
+109 ;; NEW A,B,C,X,Y
+110 ;; S X=$S(F=1:ATXNXT,1:ATXEND)
+111 ;; S:$E(X,$L(X))="." X=$E(X,1,($L(X)-1)) ; strip off trailing period
+112 ;; S X=X_$S($E(X,$L(X))'=" ":" ",1:"")
+113 ;; S Y=ATXCODE
+114 ;; S:$E(Y,$L(Y))="." Y=$E(Y,1,($L(Y)-1)) ; strip off trailing period
+115 ;; S Y=Y_$S($E(Y,$L(Y))'=" ":" ",1:"")
+116 ;; S A=$L(X),B=$L(Y)
+117 ;; I A'=B D ; pad short var with blanks
+118 ;; . S $P(C," ",$S(A>B:A-B,1:B-A))=" "
+119 ;; . I A>B S Y=Y_C I 1
+120 ;; . E S X=X_C
+121 ;; . Q
+122 ;; S @($S(F=1:"ATXBEG",1:"ATXEND")_"=X,ATXCMPC=Y")
+123 ;; Q
+124 ;; ;
+125 ;;CANONIC ; CANONIC XREF AND CODE
+126 ;; Q:ATXCODE'=+ATXCODE ; code is not canonic
+127 ;; S X=ATXCODE
+128 ;; S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",X),-1) ; right before code
+129 ;; S:ATXNXT]"" ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT),-1) ;1 more back
+130 ;; F S ATXNXT=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT)) Q:ATXNXT="" Q:ATXNXT>ATXCODE S ATXBEG=ATXNXT D Q:ATXQV
+131 ;; . S ATXEND=$O(^ATXAX(ATXTIEN,21,"AA",ATXNXT,""))
+132 ;; . S:ATXEND="" ATXEND=ATXBEG ; must be single code
+133 ;; .;actually if no end code no "AA" xref is created (design flaw?)
+134 ;; . Q:ATXCODE>ATXEND ; higher than end of range
+135 ;; . S ATXQV=1 ; found code in taxonomy
+136 ;; . W:$G(TEST) " CANONIC HIT: RANGE=""",ATXBEG,"""-""",ATXEND,"""",!
+137 ;; . Q
+138 ;; Q
