ATX50P71.m

ATX50P71 ; IHS/OHPRD/LAB - POST INIT PATCH 6 [ 09/07/04  12:03 PM ]

 ;;5.1;TAXONOMY;**7**;FEB 04, 1997

 ;

 ;

LAB ;EP

 S ATXPNSP=""

 F ATXPNSP="ACD","ABM","ACHS","ACPT","ADE","AICD","AMH","AMQQ","APCD","APCH","APCL","APCP","APMF","AQAC","AQAJ","AQAO","AQAQ","ATS","ATX","AUPN","BAT","BCH","BCM","BDW","BGP","BI","BMC","BQC","BUD","BW","CIMY","CIMB","CIMG" D SET

 S ATXTEXT="TAX" F ATXX=1:1 S ATXDATA=$P($T(@ATXTEXT+ATXX),";;",2) Q:ATXDATA=""  D

 .S ATXDA=$O(^ATXLAB("B",$P(ATXDATA,"|"),0))

 .Q:ATXDA=""

 .S $P(^ATXLAB(ATXDA,0),U,4)="n" W !,$P(ATXDATA,"|")  ;SET NO DELETE

 .S $P(^ATXLAB(ATXDA,0),U,22)=$P(ATXDATA,"|",2) ;set read only

 .;set packages in multiple

 .K DIC,DA,DR

 .S ATXP=$P(ATXDATA,"|",3)

 .F ATXN=1:1 S ATXPP=$P(ATXP,"*",ATXN) Q:ATXPP=""  D

 ..S ATXPI=$O(^DIC(9.4,"C",ATXPP,0))

 ..Q:ATXPI=""  ;NO PACKAGE

 ..S X="`"_ATXPI,DIC="^ATXLAB("_ATXDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=ATXDA

 ..D ^DIC

 ..I Y=-1 W !,"updating package multiple for ",ATXPP," entry ",$P(^ATXLAB(ATXDA,0),U)," failed"

 ..K DIC,DA,Y,X

 .Q

 D SETTAXF

 Q

SETTAXF ;

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

 .Q:$P(^ATXLAB(X,0),U,9)]""

 .S $P(^ATXLAB(X,0),U,9)=60

 .Q

 Q

SET ;

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

 .S Y=$P(^ATXLAB(X,0),U)

 .S L=$L(ATXPNSP)

 .I $E(Y,1,L)=ATXPNSP S $P(^ATXLAB(X,0),U,4)="n" W !,Y

 .Q

 Q

 ;

TAX ;

 ;;APCH FECAL OCCULT BLOOD|0|APCH

 ;;APCH HCT/HGB TESTS|0|APCH

 ;;APCP PAP SMEAR LAB TESTS|0|APCP

 ;;APCP PAP SMEAR TESTS|0|APCP

 ;;APCP PSA TESTS TAX|0|APCP

 ;;AQAJ CREATININE CLEARANCE|0|AQAJ

 ;;BDR ALBUMIN TAX|0|BDR

 ;;BDR BICARBONATE TAX|0|BDR

 ;;BDR CALCIUM TAX|0|BDR

 ;;BDR CHOLESTEROL TAX|0|BDR

 ;;BDR HDL TAX|0|BDR

 ;;BDR HEMOGLOBIN TAX|0|BDR

 ;;BDR PHOSPHATES TAX|0|BDR

 ;;BDW PAP SMEAR LAB TESTS|0|BDW

 ;;BDW PSA TESTS TAX|0|BDW

 ;;BGP CD4 TAX|0|BGP

 ;;BGP CHLAMYDIA TESTS TAX|0|BGP

 ;;BGP GPRA ESTIMATED GFR TAX|0|BGP*APCH

 ;;BGP GPRA FOB TESTS|0|BGP

 ;;BGP HIV TEST TAX|0|BGP

 ;;BGP HIV VIRAL LOAD TAX|0|BGP

 ;;BGP PAP SMEAR TAX|0|BGP

 ;;BUD PAP SMEAR TAX|0|BUD

 ;;CIMG GPRA FOB TESTS|0|

 ;;CIMG GPRA PSA TESTS|0|

 ;;DM AUDIT 2 HR GTT TAX|0|APCL*BDM

 ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL*BDM

 ;;DM AUDIT 75GM 2HR GLUCOSE|0|APCL*BDM

 ;;DM AUDIT ALT TAX|0|APCL*BDM

 ;;DM AUDIT AST TAX|0|APCL*BDM

 ;;DM AUDIT CHOLESTEROL TAX|0|APCL*BDM*BGP

 ;;DM AUDIT CREATININE TAX|0|APCL*BDM*BGP

 ;;DM AUDIT GLUCOSE TESTS TAX|0|APCL*BDM

 ;;DM AUDIT HDL TAX|0|APCL*BDM*BGP

 ;;DM AUDIT HGB A1C TAX|0|APCL*BDM*BGP

 ;;DM AUDIT LDL CHOLESTEROL TAX|0|APCL*BDM*BGP

 ;;DM AUDIT LIPID PROFILE TAX|0|APCL*BDM*BGP

 ;;DM AUDIT MICROALBUMINURIA TAX|0|APCL*BDM*BGP

 ;;DM AUDIT PAP SMEAR TAX|0|APCL*BDM

 ;;DM AUDIT TRIGLYCERIDE TAX|0|APCL*BDM*BGP

 ;;DM AUDIT URINALYSIS TAX|0|APCL*BDM

 ;;DM AUDIT URINE PROTEIN TAX|0|APCL*BDM*BGP

 ;;

 ;;

 ;;

ATX50P71  ; IHS/OHPRD/LAB - POST INIT PATCH 6 [ 09/07/04  12:03 PM ]

 +1       ;;5.1;TAXONOMY;**7**;FEB 04, 1997

 +2       ;

 +3       ;

LAB       ;EP

 +1        SET ATXPNSP=""

 +2        FOR ATXPNSP="ACD","ABM","ACHS","ACPT","ADE","AICD","AMH","AMQQ","APCD","APCH","APCL","APCP","APMF","AQAC","AQAJ","AQAO","AQAQ","ATS","ATX","AUPN","BAT","BCH","BCM","BDW","BGP","BI","BMC","BQC","BUD","BW","CIMY","CIMB","CIMG"

               DO SET

 +3        SET ATXTEXT="TAX"

           FOR ATXX=1:1

               SET ATXDATA=$PIECE($TEXT(@ATXTEXT+ATXX),";;",2)

               IF ATXDATA=""

                   QUIT 

               Begin DoDot:1

 +4                SET ATXDA=$ORDER(^ATXLAB("B",$PIECE(ATXDATA,"|"),0))

 +5                IF ATXDA=""

                       QUIT 

 +6       ;SET NO DELETE

                   SET $PIECE(^ATXLAB(ATXDA,0),U,4)="n"

                   WRITE !,$PIECE(ATXDATA,"|")

 +7       ;set read only

                   SET $PIECE(^ATXLAB(ATXDA,0),U,22)=$PIECE(ATXDATA,"|",2)

 +8       ;set packages in multiple

 +9                KILL DIC,DA,DR

 +10               SET ATXP=$PIECE(ATXDATA,"|",3)

 +11               FOR ATXN=1:1

                       SET ATXPP=$PIECE(ATXP,"*",ATXN)

                       IF ATXPP=""

                           QUIT 

                       Begin DoDot:2

 +12                       SET ATXPI=$ORDER(^DIC(9.4,"C",ATXPP,0))

 +13      ;NO PACKAGE

                           IF ATXPI=""

                               QUIT 

 +14                       SET X="`"_ATXPI

                           SET DIC="^ATXLAB("_ATXDA_",41,"

                           SET DIC(0)="L"

                           SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)

                           SET DA(1)=ATXDA

 +15                       DO ^DIC

 +16                       IF Y=-1

                               WRITE !,"updating package multiple for ",ATXPP," entry ",$PIECE(^ATXLAB(ATXDA,0),U)," failed"

 +17                       KILL DIC,DA,Y,X

                       End DoDot:2

 +18               QUIT 

               End DoDot:1

 +19       DO SETTAXF

 +20       QUIT 

SETTAXF   ;

 +1        SET X=0

           FOR 

               SET X=$ORDER(^ATXLAB(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(^ATXLAB(X,0),U,9)]""

                       QUIT 

 +3                SET $PIECE(^ATXLAB(X,0),U,9)=60

 +4                QUIT 

               End DoDot:1

 +5        QUIT 

SET       ;

 +1        SET X=0

           FOR 

               SET X=$ORDER(^ATXLAB(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=$PIECE(^ATXLAB(X,0),U)

 +3                SET L=$LENGTH(ATXPNSP)

 +4                IF $EXTRACT(Y,1,L)=ATXPNSP

                       SET $PIECE(^ATXLAB(X,0),U,4)="n"

                       WRITE !,Y

 +5                QUIT 

               End DoDot:1

 +6        QUIT 

 +7       ;

TAX       ;

 +1       ;;APCH FECAL OCCULT BLOOD|0|APCH

 +2       ;;APCH HCT/HGB TESTS|0|APCH

 +3       ;;APCP PAP SMEAR LAB TESTS|0|APCP

 +4       ;;APCP PAP SMEAR TESTS|0|APCP

 +5       ;;APCP PSA TESTS TAX|0|APCP

 +6       ;;AQAJ CREATININE CLEARANCE|0|AQAJ

 +7       ;;BDR ALBUMIN TAX|0|BDR

 +8       ;;BDR BICARBONATE TAX|0|BDR

 +9       ;;BDR CALCIUM TAX|0|BDR

 +10      ;;BDR CHOLESTEROL TAX|0|BDR

 +11      ;;BDR HDL TAX|0|BDR

 +12      ;;BDR HEMOGLOBIN TAX|0|BDR

 +13      ;;BDR PHOSPHATES TAX|0|BDR

 +14      ;;BDW PAP SMEAR LAB TESTS|0|BDW

 +15      ;;BDW PSA TESTS TAX|0|BDW

 +16      ;;BGP CD4 TAX|0|BGP

 +17      ;;BGP CHLAMYDIA TESTS TAX|0|BGP

 +18      ;;BGP GPRA ESTIMATED GFR TAX|0|BGP*APCH

 +19      ;;BGP GPRA FOB TESTS|0|BGP

 +20      ;;BGP HIV TEST TAX|0|BGP

 +21      ;;BGP HIV VIRAL LOAD TAX|0|BGP

 +22      ;;BGP PAP SMEAR TAX|0|BGP

 +23      ;;BUD PAP SMEAR TAX|0|BUD

 +24      ;;CIMG GPRA FOB TESTS|0|

 +25      ;;CIMG GPRA PSA TESTS|0|

 +26      ;;DM AUDIT 2 HR GTT TAX|0|APCL*BDM

 +27      ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL*BDM

 +28      ;;DM AUDIT 75GM 2HR GLUCOSE|0|APCL*BDM

 +29      ;;DM AUDIT ALT TAX|0|APCL*BDM

 +30      ;;DM AUDIT AST TAX|0|APCL*BDM

 +31      ;;DM AUDIT CHOLESTEROL TAX|0|APCL*BDM*BGP

 +32      ;;DM AUDIT CREATININE TAX|0|APCL*BDM*BGP

 +33      ;;DM AUDIT GLUCOSE TESTS TAX|0|APCL*BDM

 +34      ;;DM AUDIT HDL TAX|0|APCL*BDM*BGP

 +35      ;;DM AUDIT HGB A1C TAX|0|APCL*BDM*BGP

 +36      ;;DM AUDIT LDL CHOLESTEROL TAX|0|APCL*BDM*BGP

 +37      ;;DM AUDIT LIPID PROFILE TAX|0|APCL*BDM*BGP

 +38      ;;DM AUDIT MICROALBUMINURIA TAX|0|APCL*BDM*BGP

 +39      ;;DM AUDIT PAP SMEAR TAX|0|APCL*BDM

 +40      ;;DM AUDIT TRIGLYCERIDE TAX|0|APCL*BDM*BGP

 +41      ;;DM AUDIT URINALYSIS TAX|0|APCL*BDM

 +42      ;;DM AUDIT URINE PROTEIN TAX|0|APCL*BDM*BGP

 +43      ;;

 +44      ;;

 +45      ;;