APCLTAX1 ; IHS/CMI/LAB - TAXONOMY SYSTEM CON'T ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;;
;
EN D CLEAR^VALM1
W !?5,"Select diagnosis(es) to add to the"
W !!?5,APCLTNAM," Taxonomy"
S DIR(0)="FO^1:20"
S DIR("A",1)="Enter a Diagnosis, an ICD Code"
S DIR("A")="or a Range of ICD9 codes"
S DIR("?",1)=" Enter a diagnosis such as: 'DIABETES'"
S DIR("?",2)=" or an ICD9 Code such as: '250.00'"
S DIR("?")="a range of ICD9 Codes such as: '250.00-250.93'"
W !
D DIR^APCLDIC
I X=""!$D(APCLQUIT) S APCLQUIT="" Q
D EVAL
Q
EVAL ;EVALUATE USERS INPUT
K APCL,APCLX
N APCL1,APCL2
S APCL1=+$P(X,"-")
S APCL2=+$P(X,"-",2)
S APCL1=$TR(APCL1," ","")
S APCL2=$TR(APCL2," ","")
S:APCL1 APCLX(APCL1)=""
S:APCL2 APCLX(APCL2)=""
S APCLLOW=$O(APCLX(""))
S APCLHIGH=$S(APCLLOW]"":$O(APCLX(APCLLOW)),1:"")
S APCL("LOW")=""
S APCL("HIGH")=""
F APCLX="APCLLOW","APCLHIGH" D:APCLX]""
.S X=@APCLX
.S DIC="^ICD9("
.S DIC(0)="EMQZ"
.W !!
.D DIC^APCLDIC
.I +Y>0 D
..S:APCLX="APCLLOW" APCL("LOW")=$P(Y(0),U)_U_$P(Y(0),U,3)
..S:APCLX="APCLHIGH" APCL("HIGH")=$P(Y(0),U)_U_$P(Y(0),U,3)
I APCL("LOW")="",APCL("HIGH")="" S APCLQUIT="" Q
I APCL("LOW")="",APCL("HIGH")]"" S APCL("LOW")=APCL("HIGH"),APCL("HIGH")=""
D VERIFY
Q
VERIFY W @IOF
D IN
I '$D(APCL("FINAL")) D
.W !!?5,"Add the following diagnos",$S(APCL("HIGH")]"":"es",1:"is")," to the"
.W !?5,APCLTNAM," Taxonomy"
I $D(APCL("FINAL")) D
.W !!?5,"You selected the range of diagnoses"
.W !?5,"listed below to add to this Taxonomy:"
I APCL("HIGH")]"" D
.W !!?5,$P(APCL("LOW"),U),?35,"-",?40,$P(APCL("HIGH"),U)
.W !?5,$P(APCL("LOW"),U,2),?35,"-",?40,$P(APCL("HIGH"),U,2)
I APCL("HIGH")="" D
.W !!?5,$P(APCL("LOW"),U),?35,$P(APCL("LOW"),U,2)
I $D(APCL("IN")) D
.W !!?5,"The diagnos",$S(APCL("HIGH")]"":"es",1:"is")," you chose overlap the existing range:"
.W !!?5,$P(APCL("IN"),U),?35,"-",?40,$P(APCL("IN"),U,2)
I $D(APCL("FINAL")) D
.W !!?5,"The range which includes all these diagnoses is:"
.W !!?5,$P(APCL("FINAL"),U),?35,"-",?40,$P(APCL("FINAL"),U,2)
S DIR(0)="YO"
S DIR("A")="Is this what you want"
S DIR("B")="YES"
W !
D DIR^APCLDIC
I Y'=1 S APCLQUIT="" Q
I $D(APCL("IN")) D
.S DA(1)=APCLTDA
.S DA=$P(APCL("IN"),U,3)
.S DIK="^ATXAX("_DA(1)_",21,"
.D DIK^APCLDIC
I $D(APCL("FINAL")) D
.S APCL("LOW")=$P(APCL("FINAL"),U)
.S APCL("HIGH")=$P(APCL("FINAL"),U,2)
Q
IN ;CHECK IF SELECTED DX OR RANGE IS ALREADY IN ANOTHER RANGE
N X,Y,Z,APCLX
S X=0
F S X=$O(^ATXAX(APCLTDA,21,X)) Q:'X D
.S Y=$G(^ATXAX(APCLTDA,21,X,0))
.I $P(Y,U)]"",$P(Y,U)'=$P(Y,U,2) S APCLX($P(Y,U))=X_U_$S($P(Y,U,2)]"":$P(Y,U,2),1:$P(Y,U))
S X=""
F S X=$O(APCLX(X)) Q:X="" D
.I $P(APCL("LOW"),U)=X!($P(APCL("LOW"),U)>X),$P(APCL("LOW"),U)<$P(APCLX(X),U,2) D
..S APCL("IN")=X_U_$P(APCLX(X),U,2)_U_+APCLX(X)
..S APCL("FINAL")=X_U_$S($P(APCLX(X),U,2)>$P(APCL("HIGH"),U):$P(APCLX(X),U,2),1:$P(APCL("HIGH"),U))
.I $P(APCL("LOW"),U)=X!($P(APCL("LOW"),U)<X),$P(APCL("HIGH"),U)>X D
..S APCL("IN")=X_U_$P(APCLX(X),U,2)_U_+APCLX(X)
..S APCL("FINAL")=$P(APCL("LOW"),U)_U_$S($P(APCLX(X),U,2)>$P(APCL("HIGH"),U):$P(APCLX(X),U,2),1:$P(APCL("HIGH"),U))
.I $P(APCL("LOW"),U)=X!($P(APCL("LOW"),U)<X),$P(APCL("HIGH"),U)>$P(APCLX(X),U,2) D
..S APCL("IN")=X_U_$P(APCLX(X),U,2)_U_+APCLX(X)
..S APCL("FINAL")=$P(APCL("LOW"),U)_U_$P(APCL("HIGH"),U)
Q
Y ;EP;EVALUATE OUTPUT FROM TAXONOMY FOR PROPER EXTERNAL DISPLAY
S APCLLOW=$P(X,U),APCLHIGH=$P(X,U,2)
I "^RX^PATIENT ED TOPIC^HEALTH FACTORS^PROVIDER^OTHER^ADA CODE^"[(U_APCLANAM_U) D YCON
Q
X ;EP;EVALUATE X FOR PROPER INTERNAL VALUE
I APCLANAM="OTHER",APCLCANN=0 D Q
.I '+Y S X=Y(0,0)
.E S X=+Y
.I $G(APCLTFNA)="COMMUNITY" S X=$P(^AUTTCOM(X,0),U)
I APCLANAM="OTHER",APCLCANN=1 S X=Y(0,0) Q
I APCLANAM="RX" S X=+Y Q
I APCLANAM="PATIENT ED TOPIC" S X=+Y Q
I APCLANAM="ADA CODE" S X=+Y Q
I APCLANAM="HEALTH FACTORS" S X=+Y Q
I APCLANAM="PROBLEM LIST DIAGNOSIS" S X=Y(0,0) Q
I APCLANAM="PROVIDER" S X=+Y Q
I APCLANAM="CURRENT COMMUNITY" S X=$P(^AUTTCOM(+Y,0),U)
Q
LABTAX ;EP;PROCESS LAB TAXONOMIES
S APCLTNAM="DM AUDIT "_APCLX_" TAX"
S APCLTDA=$O(^ATXLAB("B",APCLTNAM,0))
I 'APCLTDA D LABTADD
Q:'APCLTDA
D LABTEST
Q
LABTADD ;EP;ADD NEW LAB TAXONOMY
D CLEAR^VALM1
S DIR(0)="FO^3:30"
S DIR("A")="Taxonomy Name"
W !
D DIR^APCLDIC
I Y="" S APCLQUIT="" Q
I $D(^ATXLAB("B",Y)) W !!,"The ",Y," taxonomy already exists." G LABTADD
S (X,APCLTNAM)=Y
S APCLTNAM=Y
W !!,"The ",APCLTNAM," Lab Taxonomy does not exist on this system"
S DIR(0)="YO"
S DIR("A")="Do you want to create it now"
S DIR("B")="NO"
W !
D DIR^APCLDIC
I +Y'=1 S APCLTDA="" Q
S X=APCLTNAM
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
YCON ;CONVERT IEN TO EXTERNAL FORMAT FOR DISPLAY
I APCLANAM="OTHER" D OTHER Q
I APCLANAM="RX" D Q
.N XX
.S XX=APCLLOW
.S APCLLOW=$P($G(^PSDRUG(+APCLLOW,0)),U)
.S APCLHIGH=""
.I $O(^PSDRUG(+XX,1,0)) D ;IHS/CIM/THL PATCH 9
..N X,Y,Z
..S X=0
..F S X=$O(^PSDRUG(XX,1,X)) Q:'X D
...S Z="("
...S Y=$P($G(^PSDRUG(XX,1,X,0)),U)
...S:Y["" APCLHIGH=$S($G(Y)'["(":Z,1:"")_Y_", "
..S:$L(APCLHIGH)>41 APCLHIGH=$E($G(APCLHIGH),1,40)_", "
..S:$E(APCLHIGH,$L(APCLHIGH)-1,$L(APCLHIGH))=", " APCLHIGH=$E(APCLHIGH,1,$L(APCLHIGH)-2)_")"
..;IHS/CIM/THL PATCH 9 END
.S:$G(APCLHIGH) APCLHIGH=$P($G(^PSDRUG(+APCLHIGH,0)),U)
.S APCLHIGH=APCLHIGH_" ien: "_+XX
.D YCON1
I APCLANAM="PATIENT ED TOPIC" D Q
.S APCLLOW=$P($G(^AUTTEDT(+APCLLOW,0)),U)
.S APCLHIGH=$P($G(^AUTTEDT(+APCLHIGH,0)),U)
.D YCON1
I APCLANAM="HEALTH FACTORS" D Q
.S APCLLOW=$P($G(^AUTTHF(+APCLLOW,0)),U)
.S APCLHIGH=$P($G(^AUTTHF(+APCLHIGH,0)),U)
.D YCON1
I APCLANAM="ADA CODE" D Q
.S APCLLOW=$P($G(^AUTTADA(+APCLLOW,0)),U)
.S APCLHIGH=$P($G(^AUTTADA(+APCLHIGH,0)),U)
.D YCON1
I APCLANAM="PROVIDER" D
.;S APCLLOW=$P($G(^DIC(16,+APCLLOW,0)),U)
.S APCLLOW=$$VAL^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),APCLLOW,.01)
.;S APCLHIGH=$P($G(^DIC(16,+APCLHIGH,0)),U)
.I APCLHIGH]"" S APCLHIGH=$$VAL^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),APCLHIGH,.01)
YCON1 S:APCLHIGH=APCLLOW APCLHIGH=""
Q
OTHER ;PROCESS FOR DISPLAY
Q:APCLCANN=1
Q:'APCLLOW
I APCLTFNA="ADA CODE" D Q
.S APCLHIGH=$P($G(^AUTTADA(+APCLLOW,0)),U,2)
.S APCLLOW=$P($G(^AUTTADA(+APCLLOW,0)),U)
N X
S X=$G(^DIC(APCLFILE,0,"GL"))
Q:X=""
I $E(X,$L(X))="(" S X=$E(X,1,$L(X)-1)
E I $E(X,$L(X))="," S X=$E(X,1,$L(X)-1)_")"
E S X=X_")"
S APCLLOW=$P($G(@X@(+APCLLOW,0)),U)
S APCLHIGH=$P($G(@X@(+APCLHIGH,0)),U)
D YCON1
Q
LABTEST ;EP;
D VALM^APCLTAX0("APCL LAB TAXONOMY DISPLAY")
Q
TAXHEAD ;EP;PRINT HEADER FOR TAXONOMY MANAGEMENT
W @IOF
TAXHEAD1 N X
F X="RPMS PATIENT CARE COMPONENT","TAXONOMY MANAGEMENT" D
.W !?(80-$L(X))\2,X
Q
DXHEAD ;PRINT HEADER FOR TAXONOMY MANAGEMENT
W @IOF
D TAXHEAD1
N X
F X="Diagnosti/Medication Taxonomies"
W !?(80-$L(X))\2,X
Q
LABHEAD ;EP;PRINT HEADER FOR TAXONOMY MANAGEMENT
W @IOF
N X
F X="Laboratory Taxonomies" D
.W !?(80-$L(X))\2,X
Q
TAXDH ;DISPLAY HEADER FOR TAXONOMY SYSTEM
Q
RXCLASS ;EP;ALLOW ADD OF ALL MEDS OF THE SAME DRUG CLASSIFICATION
Q:'$P($G(^PSDRUG(APCLRXDA,"ND")),U,6) S APCLRXVC=$P(^("ND"),U,6)
S DIR(0)="YO"
S DIR("A",1)="Add all Medications with the same"
S DIR("A")="VA Classification to this taxonomy"
S DIR("B")="NO"
W !
D DIR^APCLDIC
Q:Y'=1
N APCLX,APCLY,APCLZ
S APCLX=0
F S APCLX=$O(^PSDRUG("VAC",APCLRXVC,APCLX)) Q:'APCLX D
.S X=APCLX
.Q:$D(^ATXAX(APCLTDA,21,"B",X))
.S DA(1)=APCLTDA
.S DIC="^ATXAX("_APCLTDA_",21,"
.S DIC(0)="L"
.S DIC("DR")=".02////"_$P(APCL("HIGH"),U)
.S:'$D(^ATXAX(APCLTDA,21,0)) ^ATXAX(APCLTDA,21,0)="^9002226.02101A"
.D FILE^APCLDIC
Q
LAB ;EP;
D VALM^APCLTAX0("APCL LAB TAXONOMY LIST")
Q
SLAB ;EP;SELECT LAB TAXONOMY TO EDIT
Q:'$G(APCLJ)
S DIR(0)="NO^1:"_APCLJ
S DIR("A")="Edit which Lab Taxonomy"
W !
D DIR^APCLDIC
I '+Y S APCLQUIT="" Q
S APCLTDA=+APCLJ(Y)
S APCLTNAM=$P(APCLJ(Y),U,2)
D LABTEST
Q
LABH ;LAB TAXONOMY HEADER
D VALM^APCLTAX0("APCL LAB TAXONOMY LIST")
Q
W @IOF
W !?10,"Select one of the LAB Taxonomies"
W !?10,"or ADD a NEW Lab Taxonomy"
W !!?5,"Select one of the following"
W !
S J=0
S X="DM AUDIT "
F S X=$O(^ATXLAB("B",X)) Q:X=""!(X'["DM AUDIT") D
.S Y=0
.F S Y=$O(^ATXLAB("B",X,Y)) Q:'Y D
..S J=J+1
..W !?10,$J(J,2),?15,$P($P(X,"DM AUDIT ",2)," TAX")
..S J(J)=Y_U_X
S J=J+1
S APCLJ=J
W !?10,$J(J,2),?15,"Add NEW Lab Taxonomy"
Q
TABACK S APCLGO="TAX"
D BACK^APCLTAX0
Q
APCLTAX1 ; IHS/CMI/LAB - TAXONOMY SYSTEM CON'T ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;;
+3 ;
EN DO CLEAR^VALM1
+1 WRITE !?5,"Select diagnosis(es) to add to the"
+2 WRITE !!?5,APCLTNAM," Taxonomy"
+3 SET DIR(0)="FO^1:20"
+4 SET DIR("A",1)="Enter a Diagnosis, an ICD Code"
+5 SET DIR("A")="or a Range of ICD9 codes"
+6 SET DIR("?",1)=" Enter a diagnosis such as: 'DIABETES'"
+7 SET DIR("?",2)=" or an ICD9 Code such as: '250.00'"
+8 SET DIR("?")="a range of ICD9 Codes such as: '250.00-250.93'"
+9 WRITE !
+10 DO DIR^APCLDIC
+11 IF X=""!$DATA(APCLQUIT)
SET APCLQUIT=""
QUIT
+12 DO EVAL
+13 QUIT
EVAL ;EVALUATE USERS INPUT
+1 KILL APCL,APCLX
+2 NEW APCL1,APCL2
+3 SET APCL1=+$PIECE(X,"-")
+4 SET APCL2=+$PIECE(X,"-",2)
+5 SET APCL1=$TRANSLATE(APCL1," ","")
+6 SET APCL2=$TRANSLATE(APCL2," ","")
+7 IF APCL1
SET APCLX(APCL1)=""
+8 IF APCL2
SET APCLX(APCL2)=""
+9 SET APCLLOW=$ORDER(APCLX(""))
+10 SET APCLHIGH=$SELECT(APCLLOW]"":$ORDER(APCLX(APCLLOW)),1:"")
+11 SET APCL("LOW")=""
+12 SET APCL("HIGH")=""
+13 FOR APCLX="APCLLOW","APCLHIGH"
IF APCLX]""
Begin DoDot:1
+14 SET X=@APCLX
+15 SET DIC="^ICD9("
+16 SET DIC(0)="EMQZ"
+17 WRITE !!
+18 DO DIC^APCLDIC
+19 IF +Y>0
Begin DoDot:2
+20 IF APCLX="APCLLOW"
SET APCL("LOW")=$PIECE(Y(0),U)_U_$PIECE(Y(0),U,3)
+21 IF APCLX="APCLHIGH"
SET APCL("HIGH")=$PIECE(Y(0),U)_U_$PIECE(Y(0),U,3)
End DoDot:2
End DoDot:1
+22 IF APCL("LOW")=""
IF APCL("HIGH")=""
SET APCLQUIT=""
QUIT
+23 IF APCL("LOW")=""
IF APCL("HIGH")]""
SET APCL("LOW")=APCL("HIGH")
SET APCL("HIGH")=""
+24 DO VERIFY
+25 QUIT
VERIFY WRITE @IOF
+1 DO IN
+2 IF '$DATA(APCL("FINAL"))
Begin DoDot:1
+3 WRITE !!?5,"Add the following diagnos",$SELECT(APCL("HIGH")]"":"es",1:"is")," to the"
+4 WRITE !?5,APCLTNAM," Taxonomy"
End DoDot:1
+5 IF $DATA(APCL("FINAL"))
Begin DoDot:1
+6 WRITE !!?5,"You selected the range of diagnoses"
+7 WRITE !?5,"listed below to add to this Taxonomy:"
End DoDot:1
+8 IF APCL("HIGH")]""
Begin DoDot:1
+9 WRITE !!?5,$PIECE(APCL("LOW"),U),?35,"-",?40,$PIECE(APCL("HIGH"),U)
+10 WRITE !?5,$PIECE(APCL("LOW"),U,2),?35,"-",?40,$PIECE(APCL("HIGH"),U,2)
End DoDot:1
+11 IF APCL("HIGH")=""
Begin DoDot:1
+12 WRITE !!?5,$PIECE(APCL("LOW"),U),?35,$PIECE(APCL("LOW"),U,2)
End DoDot:1
+13 IF $DATA(APCL("IN"))
Begin DoDot:1
+14 WRITE !!?5,"The diagnos",$SELECT(APCL("HIGH")]"":"es",1:"is")," you chose overlap the existing range:"
+15 WRITE !!?5,$PIECE(APCL("IN"),U),?35,"-",?40,$PIECE(APCL("IN"),U,2)
End DoDot:1
+16 IF $DATA(APCL("FINAL"))
Begin DoDot:1
+17 WRITE !!?5,"The range which includes all these diagnoses is:"
+18 WRITE !!?5,$PIECE(APCL("FINAL"),U),?35,"-",?40,$PIECE(APCL("FINAL"),U,2)
End DoDot:1
+19 SET DIR(0)="YO"
+20 SET DIR("A")="Is this what you want"
+21 SET DIR("B")="YES"
+22 WRITE !
+23 DO DIR^APCLDIC
+24 IF Y'=1
SET APCLQUIT=""
QUIT
+25 IF $DATA(APCL("IN"))
Begin DoDot:1
+26 SET DA(1)=APCLTDA
+27 SET DA=$PIECE(APCL("IN"),U,3)
+28 SET DIK="^ATXAX("_DA(1)_",21,"
+29 DO DIK^APCLDIC
End DoDot:1
+30 IF $DATA(APCL("FINAL"))
Begin DoDot:1
+31 SET APCL("LOW")=$PIECE(APCL("FINAL"),U)
+32 SET APCL("HIGH")=$PIECE(APCL("FINAL"),U,2)
End DoDot:1
+33 QUIT
IN ;CHECK IF SELECTED DX OR RANGE IS ALREADY IN ANOTHER RANGE
+1 NEW X,Y,Z,APCLX
+2 SET X=0
+3 FOR
SET X=$ORDER(^ATXAX(APCLTDA,21,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=$GET(^ATXAX(APCLTDA,21,X,0))
+5 IF $PIECE(Y,U)]""
IF $PIECE(Y,U)'=$PIECE(Y,U,2)
SET APCLX($PIECE(Y,U))=X_U_$SELECT($PIECE(Y,U,2)]"":$PIECE(Y,U,2),1:$PIECE(Y,U))
End DoDot:1
+6 SET X=""
+7 FOR
SET X=$ORDER(APCLX(X))
IF X=""
QUIT
Begin DoDot:1
+8 IF $PIECE(APCL("LOW"),U)=X!($PIECE(APCL("LOW"),U)>X)
IF $PIECE(APCL("LOW"),U)<$PIECE(APCLX(X),U,2)
Begin DoDot:2
+9 SET APCL("IN")=X_U_$PIECE(APCLX(X),U,2)_U_+APCLX(X)
+10 SET APCL("FINAL")=X_U_$SELECT($PIECE(APCLX(X),U,2)>$PIECE(APCL("HIGH"),U):$PIECE(APCLX(X),U,2),1:$PIECE(APCL("HIGH"),U))
End DoDot:2
+11 IF $PIECE(APCL("LOW"),U)=X!($PIECE(APCL("LOW"),U)<X)
IF $PIECE(APCL("HIGH"),U)>X
Begin DoDot:2
+12 SET APCL("IN")=X_U_$PIECE(APCLX(X),U,2)_U_+APCLX(X)
+13 SET APCL("FINAL")=$PIECE(APCL("LOW"),U)_U_$SELECT($PIECE(APCLX(X),U,2)>$PIECE(APCL("HIGH"),U):$PIECE(APCLX(X),U,2),1:$PIECE(APCL("HIGH"),U))
End DoDot:2
+14 IF $PIECE(APCL("LOW"),U)=X!($PIECE(APCL("LOW"),U)<X)
IF $PIECE(APCL("HIGH"),U)>$PIECE(APCLX(X),U,2)
Begin DoDot:2
+15 SET APCL("IN")=X_U_$PIECE(APCLX(X),U,2)_U_+APCLX(X)
+16 SET APCL("FINAL")=$PIECE(APCL("LOW"),U)_U_$PIECE(APCL("HIGH"),U)
End DoDot:2
End DoDot:1
+17 QUIT
Y ;EP;EVALUATE OUTPUT FROM TAXONOMY FOR PROPER EXTERNAL DISPLAY
+1 SET APCLLOW=$PIECE(X,U)
SET APCLHIGH=$PIECE(X,U,2)
+2 IF "^RX^PATIENT ED TOPIC^HEALTH FACTORS^PROVIDER^OTHER^ADA CODE^"[(U_APCLANAM_U)
DO YCON
+3 QUIT
X ;EP;EVALUATE X FOR PROPER INTERNAL VALUE
+1 IF APCLANAM="OTHER"
IF APCLCANN=0
Begin DoDot:1
+2 IF '+Y
SET X=Y(0,0)
+3 IF '$TEST
SET X=+Y
+4 IF $GET(APCLTFNA)="COMMUNITY"
SET X=$PIECE(^AUTTCOM(X,0),U)
End DoDot:1
QUIT
+5 IF APCLANAM="OTHER"
IF APCLCANN=1
SET X=Y(0,0)
QUIT
+6 IF APCLANAM="RX"
SET X=+Y
QUIT
+7 IF APCLANAM="PATIENT ED TOPIC"
SET X=+Y
QUIT
+8 IF APCLANAM="ADA CODE"
SET X=+Y
QUIT
+9 IF APCLANAM="HEALTH FACTORS"
SET X=+Y
QUIT
+10 IF APCLANAM="PROBLEM LIST DIAGNOSIS"
SET X=Y(0,0)
QUIT
+11 IF APCLANAM="PROVIDER"
SET X=+Y
QUIT
+12 IF APCLANAM="CURRENT COMMUNITY"
SET X=$PIECE(^AUTTCOM(+Y,0),U)
+13 QUIT
LABTAX ;EP;PROCESS LAB TAXONOMIES
+1 SET APCLTNAM="DM AUDIT "_APCLX_" TAX"
+2 SET APCLTDA=$ORDER(^ATXLAB("B",APCLTNAM,0))
+3 IF 'APCLTDA
DO LABTADD
+4 IF 'APCLTDA
QUIT
+5 DO LABTEST
+6 QUIT
LABTADD ;EP;ADD NEW LAB TAXONOMY
+1 DO CLEAR^VALM1
+2 SET DIR(0)="FO^3:30"
+3 SET DIR("A")="Taxonomy Name"
+4 WRITE !
+5 DO DIR^APCLDIC
+6 IF Y=""
SET APCLQUIT=""
QUIT
+7 IF $DATA(^ATXLAB("B",Y))
WRITE !!,"The ",Y," taxonomy already exists."
GOTO LABTADD
+8 SET (X,APCLTNAM)=Y
+9 SET APCLTNAM=Y
+10 WRITE !!,"The ",APCLTNAM," Lab Taxonomy does not exist on this system"
+11 SET DIR(0)="YO"
+12 SET DIR("A")="Do you want to create it now"
+13 SET DIR("B")="NO"
+14 WRITE !
+15 DO DIR^APCLDIC
+16 IF +Y'=1
SET APCLTDA=""
QUIT
+17 SET X=APCLTNAM
+18 SET DIC="^ATXLAB("
+19 SET DIC(0)="L"
+20 SET DIC("DR")=".02////"_($PIECE(APCLTNAM," TAX")_" TEST TAX")_";.05////"_DUZ_";.06////"_DT_";.08////B;.09////60"
+21 DO FILE^APCLDIC
+22 SET APCLTDA=+Y
+23 QUIT
YCON ;CONVERT IEN TO EXTERNAL FORMAT FOR DISPLAY
+1 IF APCLANAM="OTHER"
DO OTHER
QUIT
+2 IF APCLANAM="RX"
Begin DoDot:1
+3 NEW XX
+4 SET XX=APCLLOW
+5 SET APCLLOW=$PIECE($GET(^PSDRUG(+APCLLOW,0)),U)
+6 SET APCLHIGH=""
+7 ;IHS/CIM/THL PATCH 9
IF $ORDER(^PSDRUG(+XX,1,0))
Begin DoDot:2
+8 NEW X,Y,Z
+9 SET X=0
+10 FOR
SET X=$ORDER(^PSDRUG(XX,1,X))
IF 'X
QUIT
Begin DoDot:3
+11 SET Z="("
+12 SET Y=$PIECE($GET(^PSDRUG(XX,1,X,0)),U)
+13 IF Y[""
SET APCLHIGH=$SELECT($GET(Y)'["(":Z,1:"")_Y_", "
End DoDot:3
+14 IF $LENGTH(APCLHIGH)>41
SET APCLHIGH=$EXTRACT($GET(APCLHIGH),1,40)_", "
+15 IF $EXTRACT(APCLHIGH,$LENGTH(APCLHIGH)-1,$LENGTH(APCLHIGH))=", "
SET APCLHIGH=$EXTRACT(APCLHIGH,1,$LENGTH(APCLHIGH)-2)_")"
+16 ;IHS/CIM/THL PATCH 9 END
End DoDot:2
+17 IF $GET(APCLHIGH)
SET APCLHIGH=$PIECE($GET(^PSDRUG(+APCLHIGH,0)),U)
+18 SET APCLHIGH=APCLHIGH_" ien: "_+XX
+19 DO YCON1
End DoDot:1
QUIT
+20 IF APCLANAM="PATIENT ED TOPIC"
Begin DoDot:1
+21 SET APCLLOW=$PIECE($GET(^AUTTEDT(+APCLLOW,0)),U)
+22 SET APCLHIGH=$PIECE($GET(^AUTTEDT(+APCLHIGH,0)),U)
+23 DO YCON1
End DoDot:1
QUIT
+24 IF APCLANAM="HEALTH FACTORS"
Begin DoDot:1
+25 SET APCLLOW=$PIECE($GET(^AUTTHF(+APCLLOW,0)),U)
+26 SET APCLHIGH=$PIECE($GET(^AUTTHF(+APCLHIGH,0)),U)
+27 DO YCON1
End DoDot:1
QUIT
+28 IF APCLANAM="ADA CODE"
Begin DoDot:1
+29 SET APCLLOW=$PIECE($GET(^AUTTADA(+APCLLOW,0)),U)
+30 SET APCLHIGH=$PIECE($GET(^AUTTADA(+APCLHIGH,0)),U)
+31 DO YCON1
End DoDot:1
QUIT
+32 IF APCLANAM="PROVIDER"
Begin DoDot:1
+33 ;S APCLLOW=$P($G(^DIC(16,+APCLLOW,0)),U)
+34 SET APCLLOW=$$VAL^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:200,1:6),APCLLOW,.01)
+35 ;S APCLHIGH=$P($G(^DIC(16,+APCLHIGH,0)),U)
+36 IF APCLHIGH]""
SET APCLHIGH=$$VAL^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:200,1:6),APCLHIGH,.01)
End DoDot:1
YCON1 IF APCLHIGH=APCLLOW
SET APCLHIGH=""
+1 QUIT
OTHER ;PROCESS FOR DISPLAY
+1 IF APCLCANN=1
QUIT
+2 IF 'APCLLOW
QUIT
+3 IF APCLTFNA="ADA CODE"
Begin DoDot:1
+4 SET APCLHIGH=$PIECE($GET(^AUTTADA(+APCLLOW,0)),U,2)
+5 SET APCLLOW=$PIECE($GET(^AUTTADA(+APCLLOW,0)),U)
End DoDot:1
QUIT
+6 NEW X
+7 SET X=$GET(^DIC(APCLFILE,0,"GL"))
+8 IF X=""
QUIT
+9 IF $EXTRACT(X,$LENGTH(X))="("
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+10 IF '$TEST
IF $EXTRACT(X,$LENGTH(X))=","
SET X=$EXTRACT(X,1,$LENGTH(X)-1)_")"
+11 IF '$TEST
SET X=X_")"
+12 SET APCLLOW=$PIECE($GET(@X@(+APCLLOW,0)),U)
+13 SET APCLHIGH=$PIECE($GET(@X@(+APCLHIGH,0)),U)
+14 DO YCON1
+15 QUIT
LABTEST ;EP;
+1 DO VALM^APCLTAX0("APCL LAB TAXONOMY DISPLAY")
+2 QUIT
TAXHEAD ;EP;PRINT HEADER FOR TAXONOMY MANAGEMENT
+1 WRITE @IOF
TAXHEAD1 NEW X
+1 FOR X="RPMS PATIENT CARE COMPONENT","TAXONOMY MANAGEMENT"
Begin DoDot:1
+2 WRITE !?(80-$LENGTH(X))\2,X
End DoDot:1
+3 QUIT
DXHEAD ;PRINT HEADER FOR TAXONOMY MANAGEMENT
+1 WRITE @IOF
+2 DO TAXHEAD1
+3 NEW X
+4 FOR X="Diagnosti/Medication Taxonomies"
+5 WRITE !?(80-$LENGTH(X))\2,X
+6 QUIT
LABHEAD ;EP;PRINT HEADER FOR TAXONOMY MANAGEMENT
+1 WRITE @IOF
+2 NEW X
+3 FOR X="Laboratory Taxonomies"
Begin DoDot:1
+4 WRITE !?(80-$LENGTH(X))\2,X
End DoDot:1
+5 QUIT
TAXDH ;DISPLAY HEADER FOR TAXONOMY SYSTEM
+1 QUIT
RXCLASS ;EP;ALLOW ADD OF ALL MEDS OF THE SAME DRUG CLASSIFICATION
+1 IF '$PIECE($GET(^PSDRUG(APCLRXDA,"ND")),U,6)
QUIT
SET APCLRXVC=$PIECE(^("ND"),U,6)
+2 SET DIR(0)="YO"
+3 SET DIR("A",1)="Add all Medications with the same"
+4 SET DIR("A")="VA Classification to this taxonomy"
+5 SET DIR("B")="NO"
+6 WRITE !
+7 DO DIR^APCLDIC
+8 IF Y'=1
QUIT
+9 NEW APCLX,APCLY,APCLZ
+10 SET APCLX=0
+11 FOR
SET APCLX=$ORDER(^PSDRUG("VAC",APCLRXVC,APCLX))
IF 'APCLX
QUIT
Begin DoDot:1
+12 SET X=APCLX
+13 IF $DATA(^ATXAX(APCLTDA,21,"B",X))
QUIT
+14 SET DA(1)=APCLTDA
+15 SET DIC="^ATXAX("_APCLTDA_",21,"
+16 SET DIC(0)="L"
+17 SET DIC("DR")=".02////"_$PIECE(APCL("HIGH"),U)
+18 IF '$DATA(^ATXAX(APCLTDA,21,0))
SET ^ATXAX(APCLTDA,21,0)="^9002226.02101A"
+19 DO FILE^APCLDIC
End DoDot:1
+20 QUIT
LAB ;EP;
+1 DO VALM^APCLTAX0("APCL LAB TAXONOMY LIST")
+2 QUIT
SLAB ;EP;SELECT LAB TAXONOMY TO EDIT
+1 IF '$GET(APCLJ)
QUIT
+2 SET DIR(0)="NO^1:"_APCLJ
+3 SET DIR("A")="Edit which Lab Taxonomy"
+4 WRITE !
+5 DO DIR^APCLDIC
+6 IF '+Y
SET APCLQUIT=""
QUIT
+7 SET APCLTDA=+APCLJ(Y)
+8 SET APCLTNAM=$PIECE(APCLJ(Y),U,2)
+9 DO LABTEST
+10 QUIT
LABH ;LAB TAXONOMY HEADER
+1 DO VALM^APCLTAX0("APCL LAB TAXONOMY LIST")
+2 QUIT
+3 WRITE @IOF
+4 WRITE !?10,"Select one of the LAB Taxonomies"
+5 WRITE !?10,"or ADD a NEW Lab Taxonomy"
+6 WRITE !!?5,"Select one of the following"
+7 WRITE !
+8 SET J=0
+9 SET X="DM AUDIT "
+10 FOR
SET X=$ORDER(^ATXLAB("B",X))
IF X=""!(X'["DM AUDIT")
QUIT
Begin DoDot:1
+11 SET Y=0
+12 FOR
SET Y=$ORDER(^ATXLAB("B",X,Y))
IF 'Y
QUIT
Begin DoDot:2
+13 SET J=J+1
+14 WRITE !?10,$JUSTIFY(J,2),?15,$PIECE($PIECE(X,"DM AUDIT ",2)," TAX")
+15 SET J(J)=Y_U_X
End DoDot:2
End DoDot:1
+16 SET J=J+1
+17 SET APCLJ=J
+18 WRITE !?10,$JUSTIFY(J,2),?15,"Add NEW Lab Taxonomy"
+19 QUIT
TABACK SET APCLGO="TAX"
+1 DO BACK^APCLTAX0
+2 QUIT
