BGPGTXUA ;cmi/anch/maw - ATX Gui Taxonomy Utilities (con't)
;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
;
;generic Taxonomy GUI calls
;
Q
DEBUG(RETVAL,BGPSTR) ;run the debugger
D DEBUG^%Serenji("TAX^BGPGTXU(.RETVAL,.BGPSTR)")
Q
;
TAX(ATXRET,ATXSTR) ;
S X="MERR^BGPGTXU",@^%ZOSF("TRAP")
N P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
N ATXGL,ATXGRF,ATXP
S P="|"
I $P(ATXSTR,P)="Lab" D LABTAX^BGPGTXE(.ATXRET,.ATXSTR) Q
I $P(ATXSTR,P)="LAB" D LTAX^BGPGTXE(.ATXRET) Q
K ^ATXTMP($J)
S ATXRET="^ATXTMP("_$J_")"
S ATXI=0
S ATXERR=""
S ^ATXTMP($J,ATXI)="T00080TAXONOMY"_$C(30)
I $P(ATXSTR,P)="MED" D MEDBLD^BGPGTXE
F ATXP=3:1 S ATXTAXE=$P(ATXSTR,P,ATXP) Q:$G(ATXTAXE)="" D
. Q:$G(ATXTAXE)=""
. S ATXTAX=$O(^ATXAX("B",ATXTAXE,0))
. Q:'$G(ATXTAX)
. S ATXNONC=$P($G(^ATXAX(ATXTAX,0)),U,13)
. S ATXXRF=$P($G(^ATXAX(ATXTAX,0)),U,14)
. S ATXFL=$P($G(^ATXAX(ATXTAX,0)),U,15)
. I ATXFL=80 S ATXXRF="BA" ;icd dX x ref
. I ATXFL=80.1 S ATXXRF="BA" ;icd op and proc xref
. I ATXFL=81 S ATXXRF="BA"
. I ATXFL]"" S ATXGL=$G(^DIC(ATXFL,0,"GL"))
. S ATXDA=0 F S ATXDA=$O(^ATXAX(ATXTAX,21,ATXDA)) Q:'ATXDA D
.. N ATXL,ATXH
.. S ATXI=ATXI+1
.. S ATXL=$P($G(^ATXAX(ATXTAX,21,ATXDA,0)),U)
.. S ATXH=$P($G(^ATXAX(ATXTAX,21,ATXDA,0)),U,2)
.. I (ATXL=ATXH)!($G(ATXH)="") D Q
... I $G(ATXXRF)="",$G(ATXGL)]"" D Q
.... S ATXGRF=ATXGL_""""_ATXL_""""_")"
.... S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_$C(30)
.... I $G(ATXFL)=95.3 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"/"_$G(^LAB(95.3,$P(ATXL,"-"),80))_$C(30) Q
.... ;I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($G(^ICPT($TR(ATXL," "),0)),U,2)_$C(30) Q
.... ;I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($G(^ICD9($O(^ICD9(ATXXRF,ATXL,0)),0)),U,3)_$C(30) Q
.... ;I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($G(^ICD0($O(^ICD0(ATXXRF,ATXL,0)),0)),U,4)_$C(30) Q
.... I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($$CPT^ICPTCOD($TR(ATXL," ")),U,3)_$C(30) Q
.... I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($$ICDDX^ICDCODE(ATXL),U,4)_$C(30) Q
.... I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($$ICDOP^ICDCODE(ATXL),U,5)_$C(30) Q
... S ^ATXTMP($J,ATXI)=ATXL_$C(30)
... I $G(ATXFL)=95.3 S ^ATXTMP($J,ATXI)=ATXL_"/"_$G(^LAB(95.3,$P(ATXL,"-"),80))_$C(30) Q
... ;I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($G(^ICPT($TR(ATXL," "),0)),U,2)_$C(30) Q
... ;I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($G(^ICD9($O(^ICD9(ATXXRF,ATXL,0)),0)),U,3)_$C(30) Q
... ;I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($G(^ICD0($O(^ICD0(ATXXRF,ATXL,0)),0)),U,4)_$C(30) Q
... I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($$CPT^ICPTCOD($TR(ATXL," ")),U,3)_$C(30) Q
... I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($$ICDDX^ICDCODE(ATXL),U,4)_$C(30) Q
... I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($$ICDOP^ICDCODE(ATXL),U,5)_$C(30) Q
.. S ATXGRF=ATXGL_""""_ATXXRF_""")"
.. N ATXIEN
.. S ATXIEN=$O(@ATXGRF@(ATXL),-1)
.. F S ATXIEN=$O(@ATXGRF@(ATXIEN)) Q:$S(ATXIEN[" ":ATXIEN]ATXH,1:ATXIEN>ATXH) D
... S ATXI=ATXI+1
... S ^ATXTMP($J,ATXI)=ATXIEN_$C(30)
... I $G(ATXFL)=95.3 S ^ATXTMP($J,ATXI)=ATXIEN_"/"_$G(^LAB(95.3,$P(ATXIEN,"-"),80))_$C(30) Q
... ;I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($G(^ICPT($TR(ATXIEN," "),0)),U,2)_$C(30) Q
... ;I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($G(^ICD9($O(^ICD9(ATXXRF,ATXIEN,0)),0)),U,3)_$C(30) Q
... ;I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($G(^ICD0($O(^ICD0(ATXXRF,ATXIEN,0)),0)),U,4)_$C(30) Q
... I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($$CPT^ICPTCOD($TR(ATXIEN," ")),U,3)_$C(30) Q
... I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($$ICDDX^ICDCODE(ATXIEN),U,4)_$C(30) Q
... I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($$ICDOP^ICDCODE(ATXIEN),U,5)_$C(30) Q
S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
Q
;
GETTAX(ATXRET,ATXSTR) ;-- get tax
S X="MERR^BGPGTXU",@^%ZOSF("TRAP")
N ATXDA,ATXI,P,ATXPKG,ATXPKGI,ATXI
S P="|"
K ^ATXTMP($J)
S ATXRET="^ATXTMP("_$J_")"
S ATXI=0
S ATXERR=""
S ATXPKG=$P(ATXSTR,P)
S ATXPKGI=$O(^DIC(9.4,"C",ATXPKG,0))
S ^ATXTMP($J,ATXI)="T00080TAXONOMIES"_$C(30)
S ATXDA=0 F S ATXDA=$O(^ATXAX("APKG",ATXPKGI,ATXDA)) Q:'ATXDA D
. N ATXTAX,ATXRO,ATXFL
. S ATXTAX=$P($G(^ATXAX(ATXDA,0)),U)
. S ATXRO=$S($P($G(^ATXAX(ATXDA,0)),U,22):"Read Only",1:"Editable")
. S ATXFL=$P($G(^ATXAX(ATXDA,0)),U,15)
. Q:'$G(ATXFL)
. S ^ATXTMP("TAX",$J,ATXTAX,ATXFL)=ATXRO_U_$S(ATXFL=50:"Med",1:"Tax")
S ATXDA=0 F S ATXDA=$O(^ATXLAB("APKG",ATXPKGI,ATXDA)) Q:'ATXDA D
. N ATXTAX,ATXRO,ATXFL
. S ATXTAX=$P($G(^ATXLAB(ATXDA,0)),U)
. S ATXRO=$S($P($G(^ATXLAB(ATXDA,0)),U,22):"Read Only",1:"Editable")
. S ATXFL=$P($G(^ATXLAB(ATXDA,0)),U,9)
. I '$G(ATXFL) S ATXFL=60
. Q:'$G(ATXFL)
. S ^ATXTMP("TAX",$J,ATXTAX,ATXFL)=ATXRO_U_"Lab"
S ATXDA=0 F S ATXDA=$O(^ATXTMP("TAX",$J,ATXDA)) Q:ATXDA="" D
. N ATXIEN
. S ATXIEN=0 F S ATXIEN=$O(^ATXTMP("TAX",$J,ATXDA,ATXIEN)) Q:ATXIEN="" D
.. S ATXI=ATXI+1
.. S ATXRO=$G(^ATXTMP("TAX",$J,ATXDA,ATXIEN))
.. S ^ATXTMP($J,ATXI)=ATXDA_"("_$P(ATXRO,U)_"/"_$P(ATXRO,U,2)_"/"_ATXIEN_")"_$C(30)
S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
K ^ATXTMP("TAX",$J)
Q
;
BGPGTXUA ;cmi/anch/maw - ATX Gui Taxonomy Utilities (con't)
+1 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
+2 ;
+3 ;generic Taxonomy GUI calls
+4 ;
+5 QUIT
DEBUG(RETVAL,BGPSTR) ;run the debugger
+1 DO DEBUG^%Serenji("TAX^BGPGTXU(.RETVAL,.BGPSTR)")
+2 QUIT
+3 ;
TAX(ATXRET,ATXSTR) ;
+1 SET X="MERR^BGPGTXU"
SET @^%ZOSF("TRAP")
+2 NEW P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
+3 NEW ATXGL,ATXGRF,ATXP
+4 SET P="|"
+5 IF $PIECE(ATXSTR,P)="Lab"
DO LABTAX^BGPGTXE(.ATXRET,.ATXSTR)
QUIT
+6 IF $PIECE(ATXSTR,P)="LAB"
DO LTAX^BGPGTXE(.ATXRET)
QUIT
+7 KILL ^ATXTMP($JOB)
+8 SET ATXRET="^ATXTMP("_$JOB_")"
+9 SET ATXI=0
+10 SET ATXERR=""
+11 SET ^ATXTMP($JOB,ATXI)="T00080TAXONOMY"_$CHAR(30)
+12 IF $PIECE(ATXSTR,P)="MED"
DO MEDBLD^BGPGTXE
+13 FOR ATXP=3:1
SET ATXTAXE=$PIECE(ATXSTR,P,ATXP)
IF $GET(ATXTAXE)=""
QUIT
Begin DoDot:1
+14 IF $GET(ATXTAXE)=""
QUIT
+15 SET ATXTAX=$ORDER(^ATXAX("B",ATXTAXE,0))
+16 IF '$GET(ATXTAX)
QUIT
+17 SET ATXNONC=$PIECE($GET(^ATXAX(ATXTAX,0)),U,13)
+18 SET ATXXRF=$PIECE($GET(^ATXAX(ATXTAX,0)),U,14)
+19 SET ATXFL=$PIECE($GET(^ATXAX(ATXTAX,0)),U,15)
+20 ;icd dX x ref
IF ATXFL=80
SET ATXXRF="BA"
+21 ;icd op and proc xref
IF ATXFL=80.1
SET ATXXRF="BA"
+22 IF ATXFL=81
SET ATXXRF="BA"
+23 IF ATXFL]""
SET ATXGL=$GET(^DIC(ATXFL,0,"GL"))
+24 SET ATXDA=0
FOR
SET ATXDA=$ORDER(^ATXAX(ATXTAX,21,ATXDA))
IF 'ATXDA
QUIT
Begin DoDot:2
+25 NEW ATXL,ATXH
+26 SET ATXI=ATXI+1
+27 SET ATXL=$PIECE($GET(^ATXAX(ATXTAX,21,ATXDA,0)),U)
+28 SET ATXH=$PIECE($GET(^ATXAX(ATXTAX,21,ATXDA,0)),U,2)
+29 IF (ATXL=ATXH)!($GET(ATXH)="")
Begin DoDot:3
+30 IF $GET(ATXXRF)=""
IF $GET(ATXGL)]""
Begin DoDot:4
+31 SET ATXGRF=ATXGL_""""_ATXL_""""_")"
+32 SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_$CHAR(30)
+33 IF $GET(ATXFL)=95.3
SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_"/"_$GET(^LAB(95.3,$PIECE(ATXL,"-"),80))_$CHAR(30)
QUIT
+34 ;I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($G(^ICPT($TR(ATXL," "),0)),U,2)_$C(30) Q
+35 ;I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($G(^ICD9($O(^ICD9(ATXXRF,ATXL,0)),0)),U,3)_$C(30) Q
+36 ;I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_"-"_$P($G(^ICD0($O(^ICD0(ATXXRF,ATXL,0)),0)),U,4)_$C(30) Q
+37 IF $GET(ATXFL)=81
SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_"-"_$PIECE($$CPT^ICPTCOD($TRANSLATE(ATXL," ")),U,3)_$CHAR(30)
QUIT
+38 IF $GET(ATXFL)=80
SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_"-"_$PIECE($$ICDDX^ICDCODE(ATXL),U,4)_$CHAR(30)
QUIT
+39 IF $GET(ATXFL)=80.1
SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_"-"_$PIECE($$ICDOP^ICDCODE(ATXL),U,5)_$CHAR(30)
QUIT
End DoDot:4
QUIT
+40 SET ^ATXTMP($JOB,ATXI)=ATXL_$CHAR(30)
+41 IF $GET(ATXFL)=95.3
SET ^ATXTMP($JOB,ATXI)=ATXL_"/"_$GET(^LAB(95.3,$PIECE(ATXL,"-"),80))_$CHAR(30)
QUIT
+42 ;I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($G(^ICPT($TR(ATXL," "),0)),U,2)_$C(30) Q
+43 ;I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($G(^ICD9($O(^ICD9(ATXXRF,ATXL,0)),0)),U,3)_$C(30) Q
+44 ;I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=ATXL_"-"_$P($G(^ICD0($O(^ICD0(ATXXRF,ATXL,0)),0)),U,4)_$C(30) Q
+45 IF $GET(ATXFL)=81
SET ^ATXTMP($JOB,ATXI)=ATXL_"-"_$PIECE($$CPT^ICPTCOD($TRANSLATE(ATXL," ")),U,3)_$CHAR(30)
QUIT
+46 IF $GET(ATXFL)=80
SET ^ATXTMP($JOB,ATXI)=ATXL_"-"_$PIECE($$ICDDX^ICDCODE(ATXL),U,4)_$CHAR(30)
QUIT
+47 IF $GET(ATXFL)=80.1
SET ^ATXTMP($JOB,ATXI)=ATXL_"-"_$PIECE($$ICDOP^ICDCODE(ATXL),U,5)_$CHAR(30)
QUIT
End DoDot:3
QUIT
+48 SET ATXGRF=ATXGL_""""_ATXXRF_""")"
+49 NEW ATXIEN
+50 SET ATXIEN=$ORDER(@ATXGRF@(ATXL),-1)
+51 FOR
SET ATXIEN=$ORDER(@ATXGRF@(ATXIEN))
IF $SELECT(ATXIEN[" "
QUIT
Begin DoDot:3
+52 SET ATXI=ATXI+1
+53 SET ^ATXTMP($JOB,ATXI)=ATXIEN_$CHAR(30)
+54 IF $GET(ATXFL)=95.3
SET ^ATXTMP($JOB,ATXI)=ATXIEN_"/"_$GET(^LAB(95.3,$PIECE(ATXIEN,"-"),80))_$CHAR(30)
QUIT
+55 ;I $G(ATXFL)=81 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($G(^ICPT($TR(ATXIEN," "),0)),U,2)_$C(30) Q
+56 ;I $G(ATXFL)=80 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($G(^ICD9($O(^ICD9(ATXXRF,ATXIEN,0)),0)),U,3)_$C(30) Q
+57 ;I $G(ATXFL)=80.1 S ^ATXTMP($J,ATXI)=ATXIEN_"-"_$P($G(^ICD0($O(^ICD0(ATXXRF,ATXIEN,0)),0)),U,4)_$C(30) Q
+58 IF $GET(ATXFL)=81
SET ^ATXTMP($JOB,ATXI)=ATXIEN_"-"_$PIECE($$CPT^ICPTCOD($TRANSLATE(ATXIEN," ")),U,3)_$CHAR(30)
QUIT
+59 IF $GET(ATXFL)=80
SET ^ATXTMP($JOB,ATXI)=ATXIEN_"-"_$PIECE($$ICDDX^ICDCODE(ATXIEN),U,4)_$CHAR(30)
QUIT
+60 IF $GET(ATXFL)=80.1
SET ^ATXTMP($JOB,ATXI)=ATXIEN_"-"_$PIECE($$ICDOP^ICDCODE(ATXIEN),U,5)_$CHAR(30)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+61 SET ^ATXTMP($JOB,ATXI+1)=$CHAR(31)_$GET(ATXERR)
+62 QUIT
+63 ;
GETTAX(ATXRET,ATXSTR) ;-- get tax
+1 SET X="MERR^BGPGTXU"
SET @^%ZOSF("TRAP")
+2 NEW ATXDA,ATXI,P,ATXPKG,ATXPKGI,ATXI
+3 SET P="|"
+4 KILL ^ATXTMP($JOB)
+5 SET ATXRET="^ATXTMP("_$JOB_")"
+6 SET ATXI=0
+7 SET ATXERR=""
+8 SET ATXPKG=$PIECE(ATXSTR,P)
+9 SET ATXPKGI=$ORDER(^DIC(9.4,"C",ATXPKG,0))
+10 SET ^ATXTMP($JOB,ATXI)="T00080TAXONOMIES"_$CHAR(30)
+11 SET ATXDA=0
FOR
SET ATXDA=$ORDER(^ATXAX("APKG",ATXPKGI,ATXDA))
IF 'ATXDA
QUIT
Begin DoDot:1
+12 NEW ATXTAX,ATXRO,ATXFL
+13 SET ATXTAX=$PIECE($GET(^ATXAX(ATXDA,0)),U)
+14 SET ATXRO=$SELECT($PIECE($GET(^ATXAX(ATXDA,0)),U,22):"Read Only",1:"Editable")
+15 SET ATXFL=$PIECE($GET(^ATXAX(ATXDA,0)),U,15)
+16 IF '$GET(ATXFL)
QUIT
+17 SET ^ATXTMP("TAX",$JOB,ATXTAX,ATXFL)=ATXRO_U_$SELECT(ATXFL=50:"Med",1:"Tax")
End DoDot:1
+18 SET ATXDA=0
FOR
SET ATXDA=$ORDER(^ATXLAB("APKG",ATXPKGI,ATXDA))
IF 'ATXDA
QUIT
Begin DoDot:1
+19 NEW ATXTAX,ATXRO,ATXFL
+20 SET ATXTAX=$PIECE($GET(^ATXLAB(ATXDA,0)),U)
+21 SET ATXRO=$SELECT($PIECE($GET(^ATXLAB(ATXDA,0)),U,22):"Read Only",1:"Editable")
+22 SET ATXFL=$PIECE($GET(^ATXLAB(ATXDA,0)),U,9)
+23 IF '$GET(ATXFL)
SET ATXFL=60
+24 IF '$GET(ATXFL)
QUIT
+25 SET ^ATXTMP("TAX",$JOB,ATXTAX,ATXFL)=ATXRO_U_"Lab"
End DoDot:1
+26 SET ATXDA=0
FOR
SET ATXDA=$ORDER(^ATXTMP("TAX",$JOB,ATXDA))
IF ATXDA=""
QUIT
Begin DoDot:1
+27 NEW ATXIEN
+28 SET ATXIEN=0
FOR
SET ATXIEN=$ORDER(^ATXTMP("TAX",$JOB,ATXDA,ATXIEN))
IF ATXIEN=""
QUIT
Begin DoDot:2
+29 SET ATXI=ATXI+1
+30 SET ATXRO=$GET(^ATXTMP("TAX",$JOB,ATXDA,ATXIEN))
+31 SET ^ATXTMP($JOB,ATXI)=ATXDA_"("_$PIECE(ATXRO,U)_"/"_$PIECE(ATXRO,U,2)_"/"_ATXIEN_")"_$CHAR(30)
End DoDot:2
End DoDot:1
+32 SET ^ATXTMP($JOB,ATXI+1)=$CHAR(31)_$GET(ATXERR)
+33 KILL ^ATXTMP("TAX",$JOB)
+34 QUIT
+35 ;
