APCLTAX0 ; IHS/CMI/LAB - DMS TAXONOMY MANAGEMENT UTILITY ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;UTILITY PROGRAM TO MANAGE TAXONOMY CREATION AND EDITING
TAX ;EP;TAXONOMY MANAGEMENT
W !!,"This taxonomy setup option has been disabled. Each individual package"
W !,"that requires taxonomy setup will have it's own menu option for setting"
W !,"up the taxonomies required by the package. For example, to update the"
W !,"taxonomies for the CRS report follow the menu path CI05-SET-TAX."
W !,"To update the taxonomies required by the 2005 Diabetes Audit use"
W !,"the taxonomy setup option provided in the 2005 Diabetes Audit menu.",!!
K DIR S DIR(0)="E",DIR("A")="Press enter: " D ^DIR K DIR
Q
F D TAX1 Q:$D(APCLQUIT)!$D(APCLOUT)
TAXEXIT K APCLQUIT,APCLOUT,APCLJ,APCLX,APCLY,APCLTDA,APCLTNAM,APCLINK,APCLINK0,APCLLDA,APCLWHCH,APCLADA,APCLANAM,APCLTF,APCLTFF,APCLCANN,APCLGO,APCLTFDA,APCLTFNA
K APCLHIGH,APCLLOW,APCLTYPE,APCLANAM,APCLCANN,APCLFILE,APCLILE,APLCGO,APLCJ,APCLRXDA,APCLRXVC,APCLTDA,APCLTNAM,APCLADA,APCLANAM
K ^TMP("APCLVR",$J)
Q
TAX1 D TAXEXIT
D TAXHEAD^APCLTAX1
S VALMCNT=1
S DIR(0)="SO^1:Diabetes Mgt System Taxonomies;2:Other Taxonomies"
S DIR("A")="Which one"
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
S APCLTYPE=$S(Y=1:"DMS",1:"OTHER")
I APCLTYPE="OTHER" D OTHER^APCLTAX2 Q
D TAXRX
Q
TAXRX ;PROCESS TAXONOMIES
F D TAXRX1 Q:$D(APCLQUIT)!$D(APCLOUT)
K APCLQUIT
Q
TAXRX1 ;
W @IOF
W !?10,"Select one of the following ",!?10
W "Diabetes Mgt System Taxonomy"
W "Categories to review."
S DIR(0)="SO^1:Diagnosis;2:Medication;3:Patient Education Topic;4:Health Factors;5:Problem List Diagnosis;6:Provider;7:Lab;8:ADA Code"
S DIR("A")="Which one"
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
S APCLWHCH=$S(Y=7:"LAB",1:"RX")
I Y=1 S APCLANAM="DIAGNOSIS"
I Y=2 S APCLANAM="RX"
I Y=3 S APCLANAM="PATIENT ED TOPIC"
I Y=4 S APCLANAM="HEALTH FACTORS"
I Y=5 S APCLANAM="PROBLEM LIST DIAGNOSIS"
I Y=6 S APCLANAM="PROVIDER"
I Y=7 S APCLANAM="LAB" D LAB^APCLTAX1 Q
I Y=8 S APCLANAM="ADA CODE"
S APCLADA=$O(^AMQQ(5,"B",APCLANAM,""))
I 'APCLADA D Q
.W !!,"A taxonomy can not be created for this attribute. Ask your"
.W !,"system manager to add ",APCLX," as an attribute then try again."
D TERM
Q:APCLINK0=""
D TAXDISP:APCLINK
Q
TERM ;EP;SET QMAN DICTIONARY OF TERMS VALUES
S APCLINK=$P(^AMQQ(5,APCLADA,0),U,5)
S APCLINK0=$G(^AMQQ(1,APCLINK,0))
APCLTF ;EP;
S APCLTF=U_$P(^AMQQ(5,APCLADA,0),U,18)
APCLTF1 ;EP;
S:$E(APCLTF,$L(APCLTF))="(" APCLTFF=$E(APCLTF,1,$L(APCLTF)-1)
S:$E(APCLTF,$L(APCLTF))="," APCLTFF=$E(APCLTF,1,$L(APCLTF)-1)_")"
S (APCLFILE,APCLTFDA)=+$P($G(@APCLTFF@(0)),U,2)
S APCLTFNA=$P($G(@APCLTFF@(0)),U)
Q
TAXDISP ;DISPLAY TAXONOMIES
D VALM("APCL TAXONOMY DISPLAY")
Q
S VALMSG="'-' Previous Page 'QU' Quit ?? for More Actions"
Q
TAXADD ;EP;ENTER A NEW TAXONOMY
D:'$G(APCLADA) ATTRIB^APCLTAX2
Q:'$G(APCLADA)
D APCLTF
I APCLANAM="DIAGNOSIS" S APCLCANN=1 ;CANONIC/NON-CANONIC
I APCLANAM="ADA CODE" S APCLCANN=0
I APCLANAM="RX" S APCLCANN=0
I APCLANAM="PROCEDURE (MEDICAL)" S APCLCANN=1
I APCLANAM="PATIENT ED TOPIC" S APCLCANN=0
I APCLANAM="HEALTH FACTORS" S APCLCANN=0
I APCLANAM="PROBLEM LIST DIAGNOSIS" S APCLCANN=1
I APCLANAM="PROVIDER" S APCLCANN=0
S DIR(0)="FO^3:30"
S DIR("A")="Taxonomy Name"
W !
D DIR^APCLDIC
I Y="" S APCLQUIT="" D TABACK Q
I $D(^ATXAX("B",Y)) W !!,"The ",Y," taxonomy already exists." G TAXADD
S (X,APCLTNAM)=Y
S DIC="^ATXAX("
S DIC(0)="L"
S DIC("DR")=".02////"_Y_";.05////"_DUZ_";.08////0;.09////"_DT_";.12////"_APCLINK_";.13////"_APCLCANN_";.15////"_+APCLTFDA
D FILE^APCLDIC
S APCLTDA=+Y
I 'APCLTDA D TABACK Q
D TILIST
TABACK S APCLGO="TAX"
D BACK
Q
TAXEDIT ;EP;EDIT AN EXISTING TAXONOMY
D SELECT
I $D(APCLQUIT) K APCLQUIT D TEBACK Q
TE1 ;EP
D TILIST
TEBACK S APCLGO="TAX"
D BACK
Q
SELECT ;SELECT AN EXISTING TAXONOMY
S DIR(0)="NO^1:"_APCLJ
S DIR("A")="Which Taxonomy"
W !
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
Q:'$D(APCLJ(Y))
S APCLTDA=+APCLJ(Y)
S APCLTNAM=$P($G(^ATXAX(+APCLTDA,0)),U)
Q
EDIT ;EP;EDIT A TAXONOMY
S DA=APCLTDA
S DIE=$S(APCLWHCH="RX":"^ATXAX(",1:"^ATXLAB(")
S DR=$S(APCLWHCH="RX":"[APCL EDIT TAXONOMY]",1:"[APCL EDIT LAB TAXONOMY]")
D DDS^APCLDIC
S APCLGO="TAX"
D BACK
Q
TAXINIT ;EP;INITIALIZE ARRAY FOR TAXONOMY DISPLAY
K ^TMP("APCLVR",$J),^TMP("APCLTMP",$J)
K APCLJ,VALMCNT S VALMCNT=0
D PROCESS^APCLTAX4
Q:'$D(APCLTAX)
N A,X,Y,Z
S X=" "_$S(APCLANAM'="RX":APCLANAM,1:"MEDICATION")_" Taxonomies"
D Z(X)
S X=" "
D Z(X)
S X=" No. Taxonomy"
D Z(X)
S X=" --- ------------------------------"
D Z(X)
S Z=0
S X=""
F S X=$O(APCLTAX(X)) Q:X="" D
.S Z=Z+1
.S A=" "_Z
.S:$L(A)=5 A=" "_A
.S A=A_" "
.S A=A_X
.D Z(A)
.S APCLJ(Z)=+APCLTAX(X)_U_X
I '$D(^TMP("APCLVR",$J)) D
.S X="NO TAXONOMIES ON FILE FOR "_APCLX
.D Z(X)
S APCLJ=Z
Q
VALM(APCLX) ;EP;VALM INTERFACE
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0
D EN^VALM(APCLX)
D CLEAR^VALM1
Q
LABADD ;EP;ADD LAB TO LAB TAXONOMY
F D L1 Q:$D(APCLQUIT)
D BACK
Q
L1 ;
D CLEAR^VALM1
W !,"Lab tests currently in this taxonomy:"
NEW X S X=0 F S X=$O(^ATXLAB(APCLTDA,21,X)) Q:X'=+X W !,$P(^LAB(60,$P(^ATXLAB(APCLTDA,21,X,0),U),0),U)
W !!,"Select lab tests to add."
S DIC="^LAB(60,"
S DIC(0)="AEMQZ"
S DIC("A")="Which LAB TEST: "
W !
D DIC^APCLDIC
I +Y<1 S APCLQUIT="" Q
I $D(^ATXLAB(APCLTDA,21,"B",+Y)) D Q
.S APCLLDA=$O(^ATXLAB(APCLTDA,21,"B",+Y,0))
.W !!,Y(0,0)," already selected for this taxonomy." H 2
I '$D(^ATXLAB(APCLTDA,21,"B",Y(0,0)))&'$D(^ATXLAB(APCLTDA,21,"B",+Y)) D I 1
.S DA(1)=APCLTDA
.S X=+Y
.S $P(^ATXLAB(DA(1),21,0),U,2)="9002228.02101PA"
.S DIC="^ATXLAB("_DA(1)_",21,"
.S DIC(0)="L"
.D FILE^APCLDIC
.S APCLLDA=+Y
LE S DA=APCLLDA
S DA(1)=APCLTDA
S DIE="^ATXLAB("_DA(1)_",21,"
S DR="1101;"
D DIE^APCLDIC
Q
LABEDIT ;EP;EDIT LAB IN LAB TAXONOMY
S DIR("A")="EDIT "
D SLAB
I $D(APCLQUIT) K APCLQUIT D BACK Q
D LE
D BACK
Q
SLAB ;SELECT EXISTING LAB FROM LAB TAXONOMY
S DIR(0)="NO^1:"_APCLJ
S DIR("A")=$G(DIR("A"))_"Which Lab Test"
W !
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
I '$D(APCLJ(APCLTDA,Y)) S APCLQUIT="" Q
S APCLLDA=+APCLJ(APCLTDA,Y)
Q
DLAB ;EP;DELETE LAB FROM LAB TAXONOMY
S DIR("A")="DELETE "
D SLAB
I $D(APCLQUIT) K APCLQUIT D BACK Q
S DA(1)=APCLTDA
S DA=APCLLDA
S DIK="^ATXLAB("_DA(1)_",21,"
D DIK^APCLDIC
D BACK
Q
TILIST ;EP;TO DISPLAY ITEMS ON TAXONOMY LIST
D VALM("APCL TAXONOMY ITEMS DISPLAY")
Q
TIINIT ;EP;TO LIST ITEMS ON TAXONOMY
K APCLY
K ^TMP("APCLVR",$J),APCLJ
S VALMCNT=0
S X=" "_$P(^ATXAX(APCLTDA,0),U)
D Z(X)
S X="--------------------------------------"
D Z(X)
N A,B,X,Y,Z
S APCLX=""
F S APCLX=$O(^ATXAX(APCLTDA,21,"B",APCLX)) Q:APCLX="" D
.S APCLLDA=0
.F S APCLLDA=$O(^ATXAX(APCLTDA,21,"B",APCLX,APCLLDA)) Q:'APCLLDA D
..S X=$G(^ATXAX(APCLTDA,21,APCLLDA,0))
..Q:X=""
..D Y^APCLTAX1
..S APCLY(APCLLOW_" ")=APCLHIGH_U_APCLLDA
S APCLJ=0
S APCLLOW=""
F S APCLLOW=$O(APCLY(APCLLOW)) Q:APCLLOW="" D
.S APCLHIGH=$P(APCLY(APCLLOW),U)
.S APCLJ=APCLJ+1
.S A=""
.S $E(A,5)=APCLJ
.S:$L(A)=5 A=" "_A
.S A=A_" "
.S A=A_APCLLOW_$E(" ",1,30-$L(APCLLOW))
.S A=A_APCLHIGH_$E(" ",1,30-$L(APCLHIGH))
.D Z(A)
.S APCLLDA=$P(APCLY(APCLLOW),U,2)
.S APCLJ(APCLTDA,APCLJ)=APCLLDA_U_A
Q
TIADD ;EP;TO ADD ITEM TO TAXONOMY
I $P(^ATXAX(APCLTDA,0),U,22) W !!,"The ",$P(^ATXAX(APCLTDA,0),U)," taxonomy is READ ONLY.",!,"You cannot add items to it." D PAUSE Q
F D TI1 Q:$D(APCLQUIT)
K APCLQUIT
Q
TI1 K APCL
N X,Y,Z
I APCLANAM="DIAGNOSIS"!(APCLANAM="PROBLEM LIST DIAGNOSIS")!(APCLTFDA=80) D I 1
.S X=0
.F S X=$O(^ATXAX(APCLTDA,21,X)) Q:'X D
..S Y=$G(^ATXAX(APCLTDA,21,X,0))
..S:$P(Y,U)]"" APCL(X)=$P(Y,U)_U_$S($P(Y,U,2)]"":$P(Y,U,2),1:$P(Y,U))
.D ^APCLTAX1
.Q:$D(APCLQUIT)
.S X=$P(APCL("LOW"),U)
E D
.D CLEAR^VALM1
.W !?5,"Select an item to ADD to the"
.W !!?5,APCLTNAM," Taxonomy"
.S DIC=APCLTF
.S DIC(0)="AEMQZ"
.S DIC("A")="Which "_APCLANAM_": "
.S:APCLANAM="OTHER" DIC("A")="Which "_APCLTFNA_": "
.W !
.D DIC^APCLDIC
.I +Y<1 S APCLQUIT="" Q
.D X^APCLTAX1
.S APCL("LOW")=X
.S APCL("HIGH")=""
I $D(APCLQUIT) D TIBACK Q
S X=$P(APCL("LOW"),U)
S DA(1)=APCLTDA
S DIC="^ATXAX("_APCLTDA_",21,"
S DIC(0)="L"
S DIC("DR")=".02////"_$S($P(APCL("HIGH"),U)]"":$P(APCL("HIGH"),U),1:X)
S:'$D(^ATXAX(APCLTDA,21,0)) ^ATXAX(APCLTDA,21,0)="^9002226.02101A"
D FILE^APCLDIC:'$D(^ATXAX(APCLTDA,21,"B",X))
TIBACK S APCLGO="TI"
D BACK
Q
TIREMOVE ;EP;TO REMOVE ITEM FROM TAXONOMY
I $P(^ATXAX(APCLTDA,0),U,22) W !!,"The ",$P(^ATXAX(APCLTDA,0),U)," taxonomy is READ ONLY.",!,"You cannot remove items from it." D PAUSE Q
D TISEL
I $D(APCLQUIT) K APCLQUIT D TIBACK Q
N APCLI,APCLX
F APCLI=1:1 S APCLX=$P(APCLY,",",APCLI) Q:APCLX="" D
.Q:'$D(APCLJ(APCLTDA,APCLX))
.S APCLLDA=+APCLJ(APCLTDA,APCLX)
.S DA(1)=APCLTDA
.S DA=APCLLDA
.S DIK="^ATXAX("_DA(1)_",21,"
.D DIK^APCLDIC
S APCLGO="TI"
D BACK
Q
TISEL ;EP;SELECT EXISTING ITEM FROM A TAXONOMY
S DIR(0)="LO^1:"_APCLJ
S DIR("A")="Delete which Taxonomy Item(s)"
W !
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
S APCLY=Y
Q
BACK ;EP;SETUP FOR RETURN TO LISTMAN
S VALMBCK="R"
I APCLWHCH="LAB" D LABINIT^APCLTAX4 Q
D TAXINIT:APCLGO="TAX"
D TIINIT:APCLGO="TI"
D TERM^VALM0
Q
Z(X) ;SET TMP NODE
S VALMCNT=$G(VALMCNT)+1
S ^TMP("APCLVR",$J,VALMCNT,0)=X
Q
LADD ;EP
S DIR(0)="FO^3:30"
S DIR("A")="Taxonomy Name"
W !
D DIR^APCLDIC
I Y="" S APCLQUIT="" D TABACK Q
I $D(^ATXLAB("B",Y)) W !!,"The ",Y," taxonomy already exists." G LADD
S (X,APCLTNAM)=Y
S DIC="^ATXLAB("
S DIC(0)="L"
S DIC("DR")=".02////"_($P(APCLTNAM," TAX")_" TEST TAX")_";.05////"_DUZ_";.06////"_DT_";.08////B;.09////60"
D FILE^APCLDIC
S APCLTDA=+Y
Q:'APCLTDA
D LABTEST^APCLTAX1
Q
PAUSE ;EP
Q:'(IO=IO(0))
Q:'($E(IOST,1,2)="C-")
S Y=$$DIR^XBDIR("EO")
S:$D(DUOUT) XBQ=1
Q
;
APCLTAX0 ; IHS/CMI/LAB - DMS TAXONOMY MANAGEMENT UTILITY ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;UTILITY PROGRAM TO MANAGE TAXONOMY CREATION AND EDITING
TAX ;EP;TAXONOMY MANAGEMENT
+1 WRITE !!,"This taxonomy setup option has been disabled. Each individual package"
+2 WRITE !,"that requires taxonomy setup will have it's own menu option for setting"
+3 WRITE !,"up the taxonomies required by the package. For example, to update the"
+4 WRITE !,"taxonomies for the CRS report follow the menu path CI05-SET-TAX."
+5 WRITE !,"To update the taxonomies required by the 2005 Diabetes Audit use"
+6 WRITE !,"the taxonomy setup option provided in the 2005 Diabetes Audit menu.",!!
+7 KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press enter: "
DO ^DIR
KILL DIR
+8 QUIT
+9 FOR
DO TAX1
IF $DATA(APCLQUIT)!$DATA(APCLOUT)
QUIT
TAXEXIT KILL APCLQUIT,APCLOUT,APCLJ,APCLX,APCLY,APCLTDA,APCLTNAM,APCLINK,APCLINK0,APCLLDA,APCLWHCH,APCLADA,APCLANAM,APCLTF,APCLTFF,APCLCANN,APCLGO,APCLTFDA,APCLTFNA
+1 KILL APCLHIGH,APCLLOW,APCLTYPE,APCLANAM,APCLCANN,APCLFILE,APCLILE,APLCGO,APLCJ,APCLRXDA,APCLRXVC,APCLTDA,APCLTNAM,APCLADA,APCLANAM
+2 KILL ^TMP("APCLVR",$JOB)
+3 QUIT
TAX1 DO TAXEXIT
+1 DO TAXHEAD^APCLTAX1
+2 SET VALMCNT=1
+3 SET DIR(0)="SO^1:Diabetes Mgt System Taxonomies;2:Other Taxonomies"
+4 SET DIR("A")="Which one"
+5 DO DIR^APCLDIC
+6 IF Y<1
SET APCLQUIT=""
QUIT
+7 SET APCLTYPE=$SELECT(Y=1:"DMS",1:"OTHER")
+8 IF APCLTYPE="OTHER"
DO OTHER^APCLTAX2
QUIT
+9 DO TAXRX
+10 QUIT
TAXRX ;PROCESS TAXONOMIES
+1 FOR
DO TAXRX1
IF $DATA(APCLQUIT)!$DATA(APCLOUT)
QUIT
+2 KILL APCLQUIT
+3 QUIT
TAXRX1 ;
+1 WRITE @IOF
+2 WRITE !?10,"Select one of the following ",!?10
+3 WRITE "Diabetes Mgt System Taxonomy"
+4 WRITE "Categories to review."
+5 SET DIR(0)="SO^1:Diagnosis;2:Medication;3:Patient Education Topic;4:Health Factors;5:Problem List Diagnosis;6:Provider;7:Lab;8:ADA Code"
+6 SET DIR("A")="Which one"
+7 DO DIR^APCLDIC
+8 IF Y<1
SET APCLQUIT=""
QUIT
+9 SET APCLWHCH=$SELECT(Y=7:"LAB",1:"RX")
+10 IF Y=1
SET APCLANAM="DIAGNOSIS"
+11 IF Y=2
SET APCLANAM="RX"
+12 IF Y=3
SET APCLANAM="PATIENT ED TOPIC"
+13 IF Y=4
SET APCLANAM="HEALTH FACTORS"
+14 IF Y=5
SET APCLANAM="PROBLEM LIST DIAGNOSIS"
+15 IF Y=6
SET APCLANAM="PROVIDER"
+16 IF Y=7
SET APCLANAM="LAB"
DO LAB^APCLTAX1
QUIT
+17 IF Y=8
SET APCLANAM="ADA CODE"
+18 SET APCLADA=$ORDER(^AMQQ(5,"B",APCLANAM,""))
+19 IF 'APCLADA
Begin DoDot:1
+20 WRITE !!,"A taxonomy can not be created for this attribute. Ask your"
+21 WRITE !,"system manager to add ",APCLX," as an attribute then try again."
End DoDot:1
QUIT
+22 DO TERM
+23 IF APCLINK0=""
QUIT
+24 IF APCLINK
DO TAXDISP
+25 QUIT
TERM ;EP;SET QMAN DICTIONARY OF TERMS VALUES
+1 SET APCLINK=$PIECE(^AMQQ(5,APCLADA,0),U,5)
+2 SET APCLINK0=$GET(^AMQQ(1,APCLINK,0))
APCLTF ;EP;
+1 SET APCLTF=U_$PIECE(^AMQQ(5,APCLADA,0),U,18)
APCLTF1 ;EP;
+1 IF $EXTRACT(APCLTF,$LENGTH(APCLTF))="("
SET APCLTFF=$EXTRACT(APCLTF,1,$LENGTH(APCLTF)-1)
+2 IF $EXTRACT(APCLTF,$LENGTH(APCLTF))=","
SET APCLTFF=$EXTRACT(APCLTF,1,$LENGTH(APCLTF)-1)_")"
+3 SET (APCLFILE,APCLTFDA)=+$PIECE($GET(@APCLTFF@(0)),U,2)
+4 SET APCLTFNA=$PIECE($GET(@APCLTFF@(0)),U)
+5 QUIT
TAXDISP ;DISPLAY TAXONOMIES
+1 DO VALM("APCL TAXONOMY DISPLAY")
+2 QUIT
+1 SET VALMSG="'-' Previous Page 'QU' Quit ?? for More Actions"
+2 QUIT
TAXADD ;EP;ENTER A NEW TAXONOMY
+1 IF '$GET(APCLADA)
DO ATTRIB^APCLTAX2
+2 IF '$GET(APCLADA)
QUIT
+3 DO APCLTF
+4 ;CANONIC/NON-CANONIC
IF APCLANAM="DIAGNOSIS"
SET APCLCANN=1
+5 IF APCLANAM="ADA CODE"
SET APCLCANN=0
+6 IF APCLANAM="RX"
SET APCLCANN=0
+7 IF APCLANAM="PROCEDURE (MEDICAL)"
SET APCLCANN=1
+8 IF APCLANAM="PATIENT ED TOPIC"
SET APCLCANN=0
+9 IF APCLANAM="HEALTH FACTORS"
SET APCLCANN=0
+10 IF APCLANAM="PROBLEM LIST DIAGNOSIS"
SET APCLCANN=1
+11 IF APCLANAM="PROVIDER"
SET APCLCANN=0
+12 SET DIR(0)="FO^3:30"
+13 SET DIR("A")="Taxonomy Name"
+14 WRITE !
+15 DO DIR^APCLDIC
+16 IF Y=""
SET APCLQUIT=""
DO TABACK
QUIT
+17 IF $DATA(^ATXAX("B",Y))
WRITE !!,"The ",Y," taxonomy already exists."
GOTO TAXADD
+18 SET (X,APCLTNAM)=Y
+19 SET DIC="^ATXAX("
+20 SET DIC(0)="L"
+21 SET DIC("DR")=".02////"_Y_";.05////"_DUZ_";.08////0;.09////"_DT_";.12////"_APCLINK_";.13////"_APCLCANN_";.15////"_+APCLTFDA
+22 DO FILE^APCLDIC
+23 SET APCLTDA=+Y
+24 IF 'APCLTDA
DO TABACK
QUIT
+25 DO TILIST
TABACK SET APCLGO="TAX"
+1 DO BACK
+2 QUIT
TAXEDIT ;EP;EDIT AN EXISTING TAXONOMY
+1 DO SELECT
+2 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO TEBACK
QUIT
TE1 ;EP
+1 DO TILIST
TEBACK SET APCLGO="TAX"
+1 DO BACK
+2 QUIT
SELECT ;SELECT AN EXISTING TAXONOMY
+1 SET DIR(0)="NO^1:"_APCLJ
+2 SET DIR("A")="Which Taxonomy"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y<1
SET APCLQUIT=""
QUIT
+6 IF '$DATA(APCLJ(Y))
QUIT
+7 SET APCLTDA=+APCLJ(Y)
+8 SET APCLTNAM=$PIECE($GET(^ATXAX(+APCLTDA,0)),U)
+9 QUIT
EDIT ;EP;EDIT A TAXONOMY
+1 SET DA=APCLTDA
+2 SET DIE=$SELECT(APCLWHCH="RX":"^ATXAX(",1:"^ATXLAB(")
+3 SET DR=$SELECT(APCLWHCH="RX":"[APCL EDIT TAXONOMY]",1:"[APCL EDIT LAB TAXONOMY]")
+4 DO DDS^APCLDIC
+5 SET APCLGO="TAX"
+6 DO BACK
+7 QUIT
TAXINIT ;EP;INITIALIZE ARRAY FOR TAXONOMY DISPLAY
+1 KILL ^TMP("APCLVR",$JOB),^TMP("APCLTMP",$JOB)
+2 KILL APCLJ,VALMCNT
SET VALMCNT=0
+3 DO PROCESS^APCLTAX4
+4 IF '$DATA(APCLTAX)
QUIT
+5 NEW A,X,Y,Z
+6 SET X=" "_$SELECT(APCLANAM'="RX":APCLANAM,1:"MEDICATION")_" Taxonomies"
+7 DO Z(X)
+8 SET X=" "
+9 DO Z(X)
+10 SET X=" No. Taxonomy"
+11 DO Z(X)
+12 SET X=" --- ------------------------------"
+13 DO Z(X)
+14 SET Z=0
+15 SET X=""
+16 FOR
SET X=$ORDER(APCLTAX(X))
IF X=""
QUIT
Begin DoDot:1
+17 SET Z=Z+1
+18 SET A=" "_Z
+19 IF $LENGTH(A)=5
SET A=" "_A
+20 SET A=A_" "
+21 SET A=A_X
+22 DO Z(A)
+23 SET APCLJ(Z)=+APCLTAX(X)_U_X
End DoDot:1
+24 IF '$DATA(^TMP("APCLVR",$JOB))
Begin DoDot:1
+25 SET X="NO TAXONOMIES ON FILE FOR "_APCLX
+26 DO Z(X)
End DoDot:1
+27 SET APCLJ=Z
+28 QUIT
VALM(APCLX) ;EP;VALM INTERFACE
+1 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+2 DO TERM^VALM0
+3 DO EN^VALM(APCLX)
+4 DO CLEAR^VALM1
+5 QUIT
LABADD ;EP;ADD LAB TO LAB TAXONOMY
+1 FOR
DO L1
IF $DATA(APCLQUIT)
QUIT
+2 DO BACK
+3 QUIT
L1 ;
+1 DO CLEAR^VALM1
+2 WRITE !,"Lab tests currently in this taxonomy:"
+3 NEW X
SET X=0
FOR
SET X=$ORDER(^ATXLAB(APCLTDA,21,X))
IF X'=+X
QUIT
WRITE !,$PIECE(^LAB(60,$PIECE(^ATXLAB(APCLTDA,21,X,0),U),0),U)
+4 WRITE !!,"Select lab tests to add."
+5 SET DIC="^LAB(60,"
+6 SET DIC(0)="AEMQZ"
+7 SET DIC("A")="Which LAB TEST: "
+8 WRITE !
+9 DO DIC^APCLDIC
+10 IF +Y<1
SET APCLQUIT=""
QUIT
+11 IF $DATA(^ATXLAB(APCLTDA,21,"B",+Y))
Begin DoDot:1
+12 SET APCLLDA=$ORDER(^ATXLAB(APCLTDA,21,"B",+Y,0))
+13 WRITE !!,Y(0,0)," already selected for this taxonomy."
HANG 2
End DoDot:1
QUIT
+14 IF '$DATA(^ATXLAB(APCLTDA,21,"B",Y(0,0)))&'$DATA(^ATXLAB(APCLTDA,21,"B",+Y))
Begin DoDot:1
+15 SET DA(1)=APCLTDA
+16 SET X=+Y
+17 SET $PIECE(^ATXLAB(DA(1),21,0),U,2)="9002228.02101PA"
+18 SET DIC="^ATXLAB("_DA(1)_",21,"
+19 SET DIC(0)="L"
+20 DO FILE^APCLDIC
+21 SET APCLLDA=+Y
End DoDot:1
IF 1
LE SET DA=APCLLDA
+1 SET DA(1)=APCLTDA
+2 SET DIE="^ATXLAB("_DA(1)_",21,"
+3 SET DR="1101;"
+4 DO DIE^APCLDIC
+5 QUIT
LABEDIT ;EP;EDIT LAB IN LAB TAXONOMY
+1 SET DIR("A")="EDIT "
+2 DO SLAB
+3 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO BACK
QUIT
+4 DO LE
+5 DO BACK
+6 QUIT
SLAB ;SELECT EXISTING LAB FROM LAB TAXONOMY
+1 SET DIR(0)="NO^1:"_APCLJ
+2 SET DIR("A")=$GET(DIR("A"))_"Which Lab Test"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y<1
SET APCLQUIT=""
QUIT
+6 IF '$DATA(APCLJ(APCLTDA,Y))
SET APCLQUIT=""
QUIT
+7 SET APCLLDA=+APCLJ(APCLTDA,Y)
+8 QUIT
DLAB ;EP;DELETE LAB FROM LAB TAXONOMY
+1 SET DIR("A")="DELETE "
+2 DO SLAB
+3 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO BACK
QUIT
+4 SET DA(1)=APCLTDA
+5 SET DA=APCLLDA
+6 SET DIK="^ATXLAB("_DA(1)_",21,"
+7 DO DIK^APCLDIC
+8 DO BACK
+9 QUIT
TILIST ;EP;TO DISPLAY ITEMS ON TAXONOMY LIST
+1 DO VALM("APCL TAXONOMY ITEMS DISPLAY")
+2 QUIT
TIINIT ;EP;TO LIST ITEMS ON TAXONOMY
+1 KILL APCLY
+2 KILL ^TMP("APCLVR",$JOB),APCLJ
+3 SET VALMCNT=0
+4 SET X=" "_$PIECE(^ATXAX(APCLTDA,0),U)
+5 DO Z(X)
+6 SET X="--------------------------------------"
+7 DO Z(X)
+8 NEW A,B,X,Y,Z
+9 SET APCLX=""
+10 FOR
SET APCLX=$ORDER(^ATXAX(APCLTDA,21,"B",APCLX))
IF APCLX=""
QUIT
Begin DoDot:1
+11 SET APCLLDA=0
+12 FOR
SET APCLLDA=$ORDER(^ATXAX(APCLTDA,21,"B",APCLX,APCLLDA))
IF 'APCLLDA
QUIT
Begin DoDot:2
+13 SET X=$GET(^ATXAX(APCLTDA,21,APCLLDA,0))
+14 IF X=""
QUIT
+15 DO Y^APCLTAX1
+16 SET APCLY(APCLLOW_" ")=APCLHIGH_U_APCLLDA
End DoDot:2
End DoDot:1
+17 SET APCLJ=0
+18 SET APCLLOW=""
+19 FOR
SET APCLLOW=$ORDER(APCLY(APCLLOW))
IF APCLLOW=""
QUIT
Begin DoDot:1
+20 SET APCLHIGH=$PIECE(APCLY(APCLLOW),U)
+21 SET APCLJ=APCLJ+1
+22 SET A=""
+23 SET $EXTRACT(A,5)=APCLJ
+24 IF $LENGTH(A)=5
SET A=" "_A
+25 SET A=A_" "
+26 SET A=A_APCLLOW_$EXTRACT(" ",1,30-$LENGTH(APCLLOW))
+27 SET A=A_APCLHIGH_$EXTRACT(" ",1,30-$LENGTH(APCLHIGH))
+28 DO Z(A)
+29 SET APCLLDA=$PIECE(APCLY(APCLLOW),U,2)
+30 SET APCLJ(APCLTDA,APCLJ)=APCLLDA_U_A
End DoDot:1
+31 QUIT
TIADD ;EP;TO ADD ITEM TO TAXONOMY
+1 IF $PIECE(^ATXAX(APCLTDA,0),U,22)
WRITE !!,"The ",$PIECE(^ATXAX(APCLTDA,0),U)," taxonomy is READ ONLY.",!,"You cannot add items to it."
DO PAUSE
QUIT
+2 FOR
DO TI1
IF $DATA(APCLQUIT)
QUIT
+3 KILL APCLQUIT
+4 QUIT
TI1 KILL APCL
+1 NEW X,Y,Z
+2 IF APCLANAM="DIAGNOSIS"!(APCLANAM="PROBLEM LIST DIAGNOSIS")!(APCLTFDA=80)
Begin DoDot:1
+3 SET X=0
+4 FOR
SET X=$ORDER(^ATXAX(APCLTDA,21,X))
IF 'X
QUIT
Begin DoDot:2
+5 SET Y=$GET(^ATXAX(APCLTDA,21,X,0))
+6 IF $PIECE(Y,U)]""
SET APCL(X)=$PIECE(Y,U)_U_$SELECT($PIECE(Y,U,2)]"":$PIECE(Y,U,2),1:$PIECE(Y,U))
End DoDot:2
+7 DO ^APCLTAX1
+8 IF $DATA(APCLQUIT)
QUIT
+9 SET X=$PIECE(APCL("LOW"),U)
End DoDot:1
IF 1
+10 IF '$TEST
Begin DoDot:1
+11 DO CLEAR^VALM1
+12 WRITE !?5,"Select an item to ADD to the"
+13 WRITE !!?5,APCLTNAM," Taxonomy"
+14 SET DIC=APCLTF
+15 SET DIC(0)="AEMQZ"
+16 SET DIC("A")="Which "_APCLANAM_": "
+17 IF APCLANAM="OTHER"
SET DIC("A")="Which "_APCLTFNA_": "
+18 WRITE !
+19 DO DIC^APCLDIC
+20 IF +Y<1
SET APCLQUIT=""
QUIT
+21 DO X^APCLTAX1
+22 SET APCL("LOW")=X
+23 SET APCL("HIGH")=""
End DoDot:1
+24 IF $DATA(APCLQUIT)
DO TIBACK
QUIT
+25 SET X=$PIECE(APCL("LOW"),U)
+26 SET DA(1)=APCLTDA
+27 SET DIC="^ATXAX("_APCLTDA_",21,"
+28 SET DIC(0)="L"
+29 SET DIC("DR")=".02////"_$SELECT($PIECE(APCL("HIGH"),U)]"":$PIECE(APCL("HIGH"),U),1:X)
+30 IF '$DATA(^ATXAX(APCLTDA,21,0))
SET ^ATXAX(APCLTDA,21,0)="^9002226.02101A"
+31 IF '$DATA(^ATXAX(APCLTDA,21,"B",X))
DO FILE^APCLDIC
TIBACK SET APCLGO="TI"
+1 DO BACK
+2 QUIT
TIREMOVE ;EP;TO REMOVE ITEM FROM TAXONOMY
+1 IF $PIECE(^ATXAX(APCLTDA,0),U,22)
WRITE !!,"The ",$PIECE(^ATXAX(APCLTDA,0),U)," taxonomy is READ ONLY.",!,"You cannot remove items from it."
DO PAUSE
QUIT
+2 DO TISEL
+3 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO TIBACK
QUIT
+4 NEW APCLI,APCLX
+5 FOR APCLI=1:1
SET APCLX=$PIECE(APCLY,",",APCLI)
IF APCLX=""
QUIT
Begin DoDot:1
+6 IF '$DATA(APCLJ(APCLTDA,APCLX))
QUIT
+7 SET APCLLDA=+APCLJ(APCLTDA,APCLX)
+8 SET DA(1)=APCLTDA
+9 SET DA=APCLLDA
+10 SET DIK="^ATXAX("_DA(1)_",21,"
+11 DO DIK^APCLDIC
End DoDot:1
+12 SET APCLGO="TI"
+13 DO BACK
+14 QUIT
TISEL ;EP;SELECT EXISTING ITEM FROM A TAXONOMY
+1 SET DIR(0)="LO^1:"_APCLJ
+2 SET DIR("A")="Delete which Taxonomy Item(s)"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y<1
SET APCLQUIT=""
QUIT
+6 SET APCLY=Y
+7 QUIT
BACK ;EP;SETUP FOR RETURN TO LISTMAN
+1 SET VALMBCK="R"
+2 IF APCLWHCH="LAB"
DO LABINIT^APCLTAX4
QUIT
+3 IF APCLGO="TAX"
DO TAXINIT
+4 IF APCLGO="TI"
DO TIINIT
+5 DO TERM^VALM0
+6 QUIT
Z(X) ;SET TMP NODE
+1 SET VALMCNT=$GET(VALMCNT)+1
+2 SET ^TMP("APCLVR",$JOB,VALMCNT,0)=X
+3 QUIT
LADD ;EP
+1 SET DIR(0)="FO^3:30"
+2 SET DIR("A")="Taxonomy Name"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y=""
SET APCLQUIT=""
DO TABACK
QUIT
+6 IF $DATA(^ATXLAB("B",Y))
WRITE !!,"The ",Y," taxonomy already exists."
GOTO LADD
+7 SET (X,APCLTNAM)=Y
+8 SET DIC="^ATXLAB("
+9 SET DIC(0)="L"
+10 SET DIC("DR")=".02////"_($PIECE(APCLTNAM," TAX")_" TEST TAX")_";.05////"_DUZ_";.06////"_DT_";.08////B;.09////60"
+11 DO FILE^APCLDIC
+12 SET APCLTDA=+Y
+13 IF 'APCLTDA
QUIT
+14 DO LABTEST^APCLTAX1
+15 QUIT
PAUSE ;EP
+1 IF '(IO=IO(0))
QUIT
+2 IF '($EXTRACT(IOST,1,2)="C-")
QUIT
+3 SET Y=$$DIR^XBDIR("EO")
+4 IF $DATA(DUOUT)
SET XBQ=1
+5 QUIT
+6 ;
