BGPGT.m

BGPGT ; IHS/CMI/LAB - BGPG Gui CRS Tables 2/2/2005 10:24:22 AM ;

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 ;

 ;

 ;

GETTAX(RETVAL,BGPSTR) ;-- get taxonomies based on user selection

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPDA,BGPI,P,BGPPKG,BGPPKGI,BGPI

 S P="|"

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S BGPERR=""

 S BGPPKG=$P(BGPSTR,P)

 S BGPPKGI=$O(^DIC(9.4,"C",BGPPKG,0))

 S ^BGPTMP($J,BGPI)="T00080TAXONOMIES"_$C(30)

 S BGPDA=0 F  S BGPDA=$O(^ATXAX("APKG",BGPPKGI,BGPDA)) Q:'BGPDA  D

 . N BGPTAX,BGPRO,BGPFL

 . S BGPTAX=$P($G(^ATXAX(BGPDA,0)),U)

 . S BGPRO=$S($P($G(^ATXAX(BGPDA,0)),U,22):"Read Only",1:"Editable")

 . S BGPFL=$P($G(^ATXAX(BGPDA,0)),U,15)

 . Q:'$G(BGPFL)

 . S ^BGPTMP("TAX",$J,BGPFL,BGPTAX)=BGPRO_U_$S(BGPFL=50:"Med",1:"Tax")

 S BGPDA=0 F  S BGPDA=$O(^ATXLAB("APKG",BGPPKGI,BGPDA)) Q:'BGPDA  D

 . N BGPTAX,BGPRO,BGPFL

 . S BGPTAX=$P($G(^ATXLAB(BGPDA,0)),U)

 . S BGPRO=$S($P($G(^ATXLAB(BGPDA,0)),U,22):"Read Only",1:"Editable")

 . S BGPFL=$P($G(^ATXLAB(BGPDA,0)),U,9)

 . S ^BGPTMP("TAX",$J,BGPFL,BGPTAX)=BGPRO_U_"Lab"

 S BGPDA=0 F  S BGPDA=$O(^BGPTMP("TAX",$J,BGPDA)) Q:BGPDA=""  D

 . N BGPIEN

 . S BGPIEN=0 F  S BGPIEN=$O(^BGPTMP("TAX",$J,BGPDA,BGPIEN)) Q:BGPIEN=""  D

 .. S BGPI=BGPI+1

 .. S BGPRO=$G(^BGPTMP("TAX",$J,BGPDA,BGPIEN))

 .. S ^BGPTMP($J,BGPI)=BGPIEN_"("_$P(BGPRO,U)_"/"_$P(BGPRO,U,2)_"/"_BGPDA_")"_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 K ^BGPTMP("TAX",$J)

 Q

 ;

TAX(RETVAL,BGPSTR) ;-- generic taxonomy table

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N P,BGPRFL,BGPI,BGPERR,BGPIEN,BGPTAXE,BGPTAX,BGPDA,BGPNONC,BGPXRF

 N BGPGL,BGPGRF,BGPP

 S P="|"

 I $P(BGPSTR,P)="Lab" D LABTAX(.RETVAL,.BGPSTR) Q

 I $P(BGPSTR,P)="LAB" D LTAX(.RETVAL) Q

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S BGPERR=""

 S ^BGPTMP($J,BGPI)="T00080TAXONOMY"_$C(30)

 I $P(BGPSTR,P)="MED" D MEDBLD

 F BGPP=3:1 S BGPTAXE=$P(BGPSTR,P,BGPP) Q:$G(BGPTAXE)=""  D

 . Q:$G(BGPTAXE)=""

 . ;S BGPTAXE=$P(BGPSTR,P)

 . S BGPTAX=$O(^ATXAX("B",BGPTAXE,0))

 . Q:'$G(BGPTAX)

 . S BGPNONC=$P($G(^ATXAX(BGPTAX,0)),U,13)

 . S BGPXRF=$P($G(^ATXAX(BGPTAX,0)),U,14)

 . S BGPFL=$P($G(^ATXAX(BGPTAX,0)),U,15)

 . ;I $G(BGPXRF)="" S BGPXRF="B"

 . I BGPFL=80 S BGPXRF="BA"  ;icd diagnosis x ref

 . S BGPGL=$G(^DIC(BGPFL,0,"GL"))

 . S BGPDA=0 F  S BGPDA=$O(^ATXAX(BGPTAX,21,BGPDA)) Q:'BGPDA  D

 .. N BGPL,BGPH

 .. S BGPI=BGPI+1

 .. S BGPL=$P($G(^ATXAX(BGPTAX,21,BGPDA,0)),U)

 .. S BGPH=$P($G(^ATXAX(BGPTAX,21,BGPDA,0)),U,2)

 .. I (BGPL=BGPH)!($G(BGPH)="") D  Q

 ... I $G(BGPXRF)="" D  Q

 .... S BGPGRF=BGPGL_""""_BGPL_""""_")"

 .... S ^BGPTMP($J,BGPI)=$P($G(@BGPGRF@(0)),U)_$C(30)

 ... S ^BGPTMP($J,BGPI)=BGPL_$C(30)

 .. S BGPGRF=BGPGL_""""_BGPXRF_""")"

 .. N BGPIEN

 .. S BGPIEN=$O(@BGPGRF@(BGPL),-1)

 .. F  S BGPIEN=$O(@BGPGRF@(BGPIEN)) Q:BGPIEN>BGPH  D

 ... S BGPI=BGPI+1

 ... S ^BGPTMP($J,BGPI)=BGPIEN_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

LABTAX(RETVAL,BGPSTR) ;-- return the lab taxonomy

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N P,BGPRFL,BGPI,BGPERR,BGPIEN,BGPTAXE,BGPTAX,BGPDA,BGPNONC,BGPXRF

 N BGPGL,BGPGRF,BGPP

 S P="|"

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S BGPERR=""

 S ^BGPTMP($J,BGPI)="T00080LABTAXONOMY"_$C(30)

 F BGPP=3:1 S BGPTAXE=$P(BGPSTR,P,BGPP) Q:$G(BGPTAXE)=""  D

 . Q:$G(BGPTAXE)=""

 . ;S BGPTAXE=$P(BGPSTR,P)

 . S BGPTAX=$O(^ATXLAB("B",BGPTAXE,0))

 . Q:'$G(BGPTAX)

 . S BGPNONC=$P($G(^ATXLAB(BGPTAX,0)),U,13)

 . S BGPXRF=$P($G(^ATXLAB(BGPTAX,0)),U,14)

 . S BGPFL=60

 . S BGPGL=$G(^DIC(BGPFL,0,"GL"))

 . S BGPDA=0 F  S BGPDA=$O(^ATXLAB(BGPTAX,21,BGPDA)) Q:'BGPDA  D

 .. N BGPL,BGPH

 .. S BGPI=BGPI+1

 .. S BGPL=$P($G(^ATXLAB(BGPTAX,21,BGPDA,0)),U)

 .. S BGPH=$P($G(^ATXLAB(BGPTAX,21,BGPDA,0)),U,2)

 .. I (BGPL=BGPH)!($G(BGPH)="") D  Q

 ... I $G(BGPXRF)="" D  Q

 .... S BGPGRF=BGPGL_""""_BGPL_""""_")"

 .... S ^BGPTMP($J,BGPI)=$P($G(@BGPGRF@(0)),U)_$C(30)

 ... S ^BGPTMP($J,BGPI)=BGPL_$C(30)

 .. S BGPGRF=BGPGL_""""_BGPXRF_""")"

 .. N BGPIEN

 .. S BGPIEN=$O(@BGPGRF@(BGPL),-1)

 .. F  S BGPIEN=$O(@BGPGRF@(BGPIEN)) Q:BGPIEN>BGPH  D

 ... S BGPI=BGPI+1

 ... S ^BGPTMP($J,BGPI)=BGPIEN_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

LTAX(RETVAL) ;-- generic lab taxonomy table

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N P,BGPRFL,BGPI,BGPERR,BGPIEN,BGPTAXE,BGPTAX,BGPDA,BGPNONC,BGPXRF

 N BGPGL,BGPGRF,BGPP,BGPPKG,BGPTDA,BGPPKGI

 S P="|"

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S BGPERR=""

 S BGPPKG=$P(BGPSTR,P,2)

 S BGPPKGI=$O(^DIC(9.4,"C",BGPPKG,0))

 S ^BGPTMP($J,BGPI)="T00080LABTAXONOMY"_$C(30)

 S BGPTAX=0 F  S BGPTAX=$O(^ATXLAB("APKG",BGPPKGI,BGPTAX)) Q:'BGPTAX  D

 . ;S BGPTAX=0 F  S BGPTAX=$O(^ATXLAB(BGPTAX)) Q:'BGPTAX  D

 . ;S BGPTAX=$P($G(^ATXLAB(BGPP,0)),U)

 . ;Q:$E($P($G(^ATXLAB(BGPTAX,0)),U),1,2)'="DM"

 . ;S BGPTAXE=$P(BGPSTR,P)

 . ;S BGPTAX=$O(^ATXLAB("B",BGPTAXE,0))

 . ;Q:'$G(BGPTAX)

 . S BGPXRF=$P($G(^ATXLAB(BGPTAX,0)),U,8)

 . I $G(BGPXRF)="" S BGPXRF="B"

 . S BGPFL=$P($G(^ATXLAB(BGPTAX,0)),U,9)

 . S BGPGL=$G(^DIC(BGPFL,0,"GL"))

 . S BGPDA=0 F  S BGPDA=$O(^ATXLAB(BGPTAX,21,BGPDA)) Q:'BGPDA  D

 .. N BGPL,BGPH

 .. S BGPI=BGPI+1

 .. S BGPL=$P($G(^ATXLAB(BGPTAX,21,BGPDA,0)),U)

 .. S BGPGRF=BGPGL_""""_BGPL_""""_")"

 .. N BGPIEN

 .. S BGPI=BGPI+1

 .. S ^BGPTMP($J,BGPI)=$P($G(@BGPGRF@(0)),U)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

MEDBLD ;-- setup BGPSTR for medication taxonomy

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPTDA,BGPI,BGPPKG,BGPPKGI

 S BGPI=1

 S BGPPKG=$P(BGPSTR,P,2)

 S BGPPKGI=$O(^DIC(9.4,"C",BGPPKG,0))

 S BGPTDA=0 F  S BGPTDA=$O(^ATXAX(BGPTDA)) Q:'BGPTDA  D

 . ;S BGPTDA=0 F  S BGPTDA=$O(^ATXAX(BGPTDA)) Q:'BGPTDA  D

 . ;Q:$E($P($G(^ATXAX(BGPTDA,0)),U),1,2)'="DM"

 . Q:$P($G(^ATXAX(BGPTDA,0)),U,15)'=50

 . S BGPI=BGPI+1

 . S $P(BGPSTR,P,BGPI)=$P($G(^ATXAX(BGPTDA,0)),U)

 Q

 ;

GETTAXN(RETVAL,BGPSTR) ;-- get taxonomies based on user selection

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPDA,BGPI,P,BGPPKG,BGPPKGI,BGPI

 S P="|"

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S BGPERR=""

 S BGPPKG=$P(BGPSTR,P)

 S BGPPKGI=$O(^DIC(9.4,"C",BGPPKG,0))

 S ^BGPTMP($J,BGPI)="T00080TAXONOMIES"_$C(30)

 S BGPDA=0 F  S BGPDA=$O(^ATXAX("APKG",BGPPKGI,BGPDA)) Q:'BGPDA  D

 . N BGPTAX,BGPRO,BGPFL

 . S BGPTAX=$P($G(^ATXAX(BGPDA,0)),U)

 . S BGPRO=$S($P($G(^ATXAX(BGPDA,0)),U,22):"Read Only",1:"Editable")

 . S BGPFL=$P($G(^ATXAX(BGPDA,0)),U,15)

 . S ^BGPTMP("TAX",$J,BGPFL,BGPTAX)=BGPRO_U_$S(BGPFL=50:"Med",1:"Tax")

 S BGPDA=0 F  S BGPDA=$O(^ATXLAB("APKG",BGPPKGI,BGPDA)) Q:'BGPDA  D

 . N BGPTAX,BGPRO,BGPFL

 . S BGPTAX=$P($G(^ATXLAB(BGPDA,0)),U)

 . S BGPRO=$S($P($G(^ATXLAB(BGPDA,0)),U,22):"Read Only",1:"Editable")

 . S BGPFL=$P($G(^ATXLAB(BGPDA,0)),U,9)

 . S ^BGPTMP("TAX",$J,BGPFL,BGPTAX)=BGPRO_U_"Lab"

 S BGPDA=0 F  S BGPDA=$O(^BGPTMP("TAX",$J,BGPDA)) Q:BGPDA=""  D

 . N BGPIEN

 . S BGPIEN=0 F  S BGPIEN=$O(^BGPTMP("TAX",$J,BGPDA,BGPIEN)) Q:BGPIEN=""  D

 .. S BGPI=BGPI+1

 .. S BGPRO=$G(^BGPTMP("TAX",$J,BGPDA,BGPIEN))

 .. S ^BGPTMP($J,BGPI)=BGPIEN_"("_$P(BGPRO,U)_"/"_$P(BGPRO,U,2)_"/"_BGPDA_")"_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 K ^BGPTMP("TAX",$J)

 Q

 ;

GI(RETVAL) ;-- get GPRA indicators

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 S X=0 F  S X=$O(^BGPINDV("AO",X)) Q:X'=+X  D

 . S Y=0 F  S Y=$O(^BGPINDV("AO",X,Y)) Q:Y'=+Y  D

 .. Q:$P(^BGPINDV(Y,0),U,7)'=1

 .. S BGPI=BGPI+1

 .. S ^BGPTMP($J,BGPI)=Y_U_$P($G(^BGPINDV(Y,0)),U,4)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

GSI(RETVAL,BGPSTR) ;-- get sub indicator based on passed in indicator

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N P,BGPSIND,BGPIND,BGPI,X

 S P="|"

 S BGPIND=$P(BGPSTR,P)

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Sub Indicator"_$C(30)

 S X=0 F  S X=$O(^BGPVNPL("B",BGPIND,X)) Q:'X  D

 . S BGPI=BGPI+1

 . S ^BGPTMP($J,BGPI)=X_U_$P($G(^BGPVNPL(X,0)),U,3)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

GIALL(RETVAL) ;-- get all GPRA indicators

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 S X=0 F  S X=$O(^BGPINDV("AO",X)) Q:X'=+X  D

 . S Y=0 F  S Y=$O(^BGPINDV("AO",X,Y)) Q:Y'=+Y  D

 .. ;Q:$P(^BGPINDV(Y,0),U,7)'=1

 .. S BGPI=BGPI+1

 .. S ^BGPTMP($J,BGPI)=Y_U_$P($G(^BGPINDV(Y,0)),U,4)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

ECALL(RETVAL) ;-- get all elder care indicators

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 S X=0 F  S X=$O(^BGPELIV("AO",X)) Q:X'=+X  D

 . S Y=0 F  S Y=$O(^BGPELIV("AO",X,Y)) Q:Y'=+Y  D

 .. ;Q:$P(^BGPINDV(Y,0),U,7)'=1

 .. S BGPI=BGPI+1

 .. S ^BGPTMP($J,BGPI)=Y_U_$P($G(^BGPELIV(Y,0)),U,4)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

PATLST(RETVAL,BGPSTR) ;-- get all GPRA indicators

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z,P,BGPIND

 S P="|"

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 N I

 F I=2:1 D  Q:$P(BGPSTR,P,I)=""

 . Q:$P(BGPSTR,P,I)=""

 . S BGPINDI=$P(BGPSTR,P,I)

 . S BGPIND(BGPINDI)=""

 S X=0 F  S X=$O(BGPIND(X)) Q:X'=+X  D

 . Q:$P(^BGPINDV(X,0),U,5)=""

 . S BGPI=BGPI+1

 . S ^BGPTMP($J,BGPI)=X_U_$P($G(^BGPINDV(X,0)),U,4)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

EPATLST(RETVAL,BGPSTR) ;-- get all GPRA indicators

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z,P,BGPIND

 S P="|"

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 N I

 F I=2:1 D  Q:$P(BGPSTR,P,I)=""

 . Q:$P(BGPSTR,P,I)=""

 . S BGPINDI=$P(BGPSTR,P,I)

 . S BGPIND(BGPINDI)=""

 S X=0 F  S X=$O(BGPIND(X)) Q:X'=+X  D

 . Q:$P(^BGPELIV(X,0),U,5)=""

 . S BGPI=BGPI+1

 . S ^BGPTMP($J,BGPI)=X_U_$P($G(^BGPELIV(X,0)),U,5)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

COM(RETVAL,BGPSTR) ;-- get indicators based on user selection

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z,BGPLP,XREF

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 I BGPSTR="D" D

 . S XREF="ADM"

 I BGPSTR="C" D

 . S XREF="ACARD"

 I BGPSTR="W" D

 . S XREF="AWH"

 I BGPSTR="E" D

 . S XREF="AEL"

 S BGPLP="^BGPINDVC("""_XREF_""",1)"

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 K ^TMP($J,"BGPG")

 S X=0 F  S X=$O(@BGPLP@(X)) Q:X'=+X  D

 . ;Q:$P(^BGPINDV(Y,0),U,7)'=1

 . S ^TMP($J,"BGPG",$P($G(^BGPINDVC(X,0)),U))=""

 S Y=0  F  S Y=$O(^TMP($J,"BGPG",Y)) Q:'Y  D

 . S BGPI=BGPI+1

 . S ^BGPTMP($J,BGPI)=Y_U_$P($G(^BGPINDV(Y,0)),U,5)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

CMSIND(RETVAL) ;-- get CMS indicators

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,X,Y,Z

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S BGPI=0

 S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Indicator"_$C(30)

 S X=0 F  S X=$O(^BGPCMSIF("AO",X)) Q:X'=+X  D

 . S Y=0 F  S Y=$O(^BGPCMSIF("AO",X,Y)) Q:Y'=+Y  D

 .. ;Q:$P(^BGPINDV(Y,0),U,7)'=1

 .. S BGPI=BGPI+1

 .. S ^BGPTMP($J,BGPI)=Y_U_$P($G(^BGPCMSIF(Y,0)),U,4)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)

 Q

 ;

BGPGT     ; IHS/CMI/LAB - BGPG Gui CRS Tables 2/2/2005 10:24:22 AM ;

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;

 +3       ;

 +4       ;

GETTAX(RETVAL,BGPSTR) ;-- get taxonomies based on user selection

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW BGPDA,BGPI,P,BGPPKG,BGPPKGI,BGPI

 +3        SET P="|"

 +4        KILL ^BGPTMP($JOB)

 +5        SET RETVAL="^BGPTMP("_$JOB_")"

 +6        SET BGPI=0

 +7        SET BGPERR=""

 +8        SET BGPPKG=$PIECE(BGPSTR,P)

 +9        SET BGPPKGI=$ORDER(^DIC(9.4,"C",BGPPKG,0))

 +10       SET ^BGPTMP($JOB,BGPI)="T00080TAXONOMIES"_$CHAR(30)

 +11       SET BGPDA=0

           FOR 

               SET BGPDA=$ORDER(^ATXAX("APKG",BGPPKGI,BGPDA))

               IF 'BGPDA

                   QUIT 

               Begin DoDot:1

 +12               NEW BGPTAX,BGPRO,BGPFL

 +13               SET BGPTAX=$PIECE($GET(^ATXAX(BGPDA,0)),U)

 +14               SET BGPRO=$SELECT($PIECE($GET(^ATXAX(BGPDA,0)),U,22):"Read Only",1:"Editable")

 +15               SET BGPFL=$PIECE($GET(^ATXAX(BGPDA,0)),U,15)

 +16               IF '$GET(BGPFL)

                       QUIT 

 +17               SET ^BGPTMP("TAX",$JOB,BGPFL,BGPTAX)=BGPRO_U_$SELECT(BGPFL=50:"Med",1:"Tax")

               End DoDot:1

 +18       SET BGPDA=0

           FOR 

               SET BGPDA=$ORDER(^ATXLAB("APKG",BGPPKGI,BGPDA))

               IF 'BGPDA

                   QUIT 

               Begin DoDot:1

 +19               NEW BGPTAX,BGPRO,BGPFL

 +20               SET BGPTAX=$PIECE($GET(^ATXLAB(BGPDA,0)),U)

 +21               SET BGPRO=$SELECT($PIECE($GET(^ATXLAB(BGPDA,0)),U,22):"Read Only",1:"Editable")

 +22               SET BGPFL=$PIECE($GET(^ATXLAB(BGPDA,0)),U,9)

 +23               SET ^BGPTMP("TAX",$JOB,BGPFL,BGPTAX)=BGPRO_U_"Lab"

               End DoDot:1

 +24       SET BGPDA=0

           FOR 

               SET BGPDA=$ORDER(^BGPTMP("TAX",$JOB,BGPDA))

               IF BGPDA=""

                   QUIT 

               Begin DoDot:1

 +25               NEW BGPIEN

 +26               SET BGPIEN=0

                   FOR 

                       SET BGPIEN=$ORDER(^BGPTMP("TAX",$JOB,BGPDA,BGPIEN))

                       IF BGPIEN=""

                           QUIT 

                       Begin DoDot:2

 +27                       SET BGPI=BGPI+1

 +28                       SET BGPRO=$GET(^BGPTMP("TAX",$JOB,BGPDA,BGPIEN))

 +29                       SET ^BGPTMP($JOB,BGPI)=BGPIEN_"("_$PIECE(BGPRO,U)_"/"_$PIECE(BGPRO,U,2)_"/"_BGPDA_")"_$CHAR(30)

                       End DoDot:2

               End DoDot:1

 +30       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_$GET(BGPERR)

 +31       KILL ^BGPTMP("TAX",$JOB)

 +32       QUIT 

 +33      ;

TAX(RETVAL,BGPSTR) ;-- generic taxonomy table

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW P,BGPRFL,BGPI,BGPERR,BGPIEN,BGPTAXE,BGPTAX,BGPDA,BGPNONC,BGPXRF

 +3        NEW BGPGL,BGPGRF,BGPP

 +4        SET P="|"

 +5        IF $PIECE(BGPSTR,P)="Lab"

               DO LABTAX(.RETVAL,.BGPSTR)

               QUIT 

 +6        IF $PIECE(BGPSTR,P)="LAB"

               DO LTAX(.RETVAL)

               QUIT 

 +7        KILL ^BGPTMP($JOB)

 +8        SET RETVAL="^BGPTMP("_$JOB_")"

 +9        SET BGPI=0

 +10       SET BGPERR=""

 +11       SET ^BGPTMP($JOB,BGPI)="T00080TAXONOMY"_$CHAR(30)

 +12       IF $PIECE(BGPSTR,P)="MED"

               DO MEDBLD

 +13       FOR BGPP=3:1

               SET BGPTAXE=$PIECE(BGPSTR,P,BGPP)

               IF $GET(BGPTAXE)=""

                   QUIT 

               Begin DoDot:1

 +14               IF $GET(BGPTAXE)=""

                       QUIT 

 +15      ;S BGPTAXE=$P(BGPSTR,P)

 +16               SET BGPTAX=$ORDER(^ATXAX("B",BGPTAXE,0))

 +17               IF '$GET(BGPTAX)

                       QUIT 

 +18               SET BGPNONC=$PIECE($GET(^ATXAX(BGPTAX,0)),U,13)

 +19               SET BGPXRF=$PIECE($GET(^ATXAX(BGPTAX,0)),U,14)

 +20               SET BGPFL=$PIECE($GET(^ATXAX(BGPTAX,0)),U,15)

 +21      ;I $G(BGPXRF)="" S BGPXRF="B"

 +22      ;icd diagnosis x ref

                   IF BGPFL=80

                       SET BGPXRF="BA"

 +23               SET BGPGL=$GET(^DIC(BGPFL,0,"GL"))

 +24               SET BGPDA=0

                   FOR 

                       SET BGPDA=$ORDER(^ATXAX(BGPTAX,21,BGPDA))

                       IF 'BGPDA

                           QUIT 

                       Begin DoDot:2

 +25                       NEW BGPL,BGPH

 +26                       SET BGPI=BGPI+1

 +27                       SET BGPL=$PIECE($GET(^ATXAX(BGPTAX,21,BGPDA,0)),U)

 +28                       SET BGPH=$PIECE($GET(^ATXAX(BGPTAX,21,BGPDA,0)),U,2)

 +29                       IF (BGPL=BGPH)!($GET(BGPH)="")

                               Begin DoDot:3

 +30                               IF $GET(BGPXRF)=""

                                       Begin DoDot:4

 +31                                       SET BGPGRF=BGPGL_""""_BGPL_""""_")"

 +32                                       SET ^BGPTMP($JOB,BGPI)=$PIECE($GET(@BGPGRF@(0)),U)_$CHAR(30)

                                       End DoDot:4

                                       QUIT 

 +33                               SET ^BGPTMP($JOB,BGPI)=BGPL_$CHAR(30)

                               End DoDot:3

                               QUIT 

 +34                       SET BGPGRF=BGPGL_""""_BGPXRF_""")"

 +35                       NEW BGPIEN

 +36                       SET BGPIEN=$ORDER(@BGPGRF@(BGPL),-1)

 +37                       FOR 

                               SET BGPIEN=$ORDER(@BGPGRF@(BGPIEN))

                               IF BGPIEN>BGPH

                                   QUIT 

                               Begin DoDot:3

 +38                               SET BGPI=BGPI+1

 +39                               SET ^BGPTMP($JOB,BGPI)=BGPIEN_$CHAR(30)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +40       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_$GET(BGPERR)

 +41       QUIT 

 +42      ;

LABTAX(RETVAL,BGPSTR) ;-- return the lab taxonomy

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW P,BGPRFL,BGPI,BGPERR,BGPIEN,BGPTAXE,BGPTAX,BGPDA,BGPNONC,BGPXRF

 +3        NEW BGPGL,BGPGRF,BGPP

 +4        SET P="|"

 +5        KILL ^BGPTMP($JOB)

 +6        SET RETVAL="^BGPTMP("_$JOB_")"

 +7        SET BGPI=0

 +8        SET BGPERR=""

 +9        SET ^BGPTMP($JOB,BGPI)="T00080LABTAXONOMY"_$CHAR(30)

 +10       FOR BGPP=3:1

               SET BGPTAXE=$PIECE(BGPSTR,P,BGPP)

               IF $GET(BGPTAXE)=""

                   QUIT 

               Begin DoDot:1

 +11               IF $GET(BGPTAXE)=""

                       QUIT 

 +12      ;S BGPTAXE=$P(BGPSTR,P)

 +13               SET BGPTAX=$ORDER(^ATXLAB("B",BGPTAXE,0))

 +14               IF '$GET(BGPTAX)

                       QUIT 

 +15               SET BGPNONC=$PIECE($GET(^ATXLAB(BGPTAX,0)),U,13)

 +16               SET BGPXRF=$PIECE($GET(^ATXLAB(BGPTAX,0)),U,14)

 +17               SET BGPFL=60

 +18               SET BGPGL=$GET(^DIC(BGPFL,0,"GL"))

 +19               SET BGPDA=0

                   FOR 

                       SET BGPDA=$ORDER(^ATXLAB(BGPTAX,21,BGPDA))

                       IF 'BGPDA

                           QUIT 

                       Begin DoDot:2

 +20                       NEW BGPL,BGPH

 +21                       SET BGPI=BGPI+1

 +22                       SET BGPL=$PIECE($GET(^ATXLAB(BGPTAX,21,BGPDA,0)),U)

 +23                       SET BGPH=$PIECE($GET(^ATXLAB(BGPTAX,21,BGPDA,0)),U,2)

 +24                       IF (BGPL=BGPH)!($GET(BGPH)="")

                               Begin DoDot:3

 +25                               IF $GET(BGPXRF)=""

                                       Begin DoDot:4

 +26                                       SET BGPGRF=BGPGL_""""_BGPL_""""_")"

 +27                                       SET ^BGPTMP($JOB,BGPI)=$PIECE($GET(@BGPGRF@(0)),U)_$CHAR(30)

                                       End DoDot:4

                                       QUIT 

 +28                               SET ^BGPTMP($JOB,BGPI)=BGPL_$CHAR(30)

                               End DoDot:3

                               QUIT 

 +29                       SET BGPGRF=BGPGL_""""_BGPXRF_""")"

 +30                       NEW BGPIEN

 +31                       SET BGPIEN=$ORDER(@BGPGRF@(BGPL),-1)

 +32                       FOR 

                               SET BGPIEN=$ORDER(@BGPGRF@(BGPIEN))

                               IF BGPIEN>BGPH

                                   QUIT 

                               Begin DoDot:3

 +33                               SET BGPI=BGPI+1

 +34                               SET ^BGPTMP($JOB,BGPI)=BGPIEN_$CHAR(30)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +35       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_$GET(BGPERR)

 +36       QUIT 

 +37      ;

LTAX(RETVAL) ;-- generic lab taxonomy table

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW P,BGPRFL,BGPI,BGPERR,BGPIEN,BGPTAXE,BGPTAX,BGPDA,BGPNONC,BGPXRF

 +3        NEW BGPGL,BGPGRF,BGPP,BGPPKG,BGPTDA,BGPPKGI

 +4        SET P="|"

 +5        KILL ^BGPTMP($JOB)