APCLTAX3 ; IHS/CMI/LAB - DMS TAXONOMY MANAGEMENT UTILITY ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;UTILITY PROGRAM TO MANAGE TAXONOMY CREATION AND EDITING
TAX ;CREATE TAXONOMIES
K ^TMP("TAXONOMIES",$J)
S APCLJ=0
S Y="S APCLJ=APCLJ+1 S ^TMP(""TAXONOMIES"",$J,APCLJ)=XX W ""."""
F A="DM AUDIT","SURVEILLANCE","APCH DM" D
.S AA=A
.F S A=$O(^ATXAX("B",A)) Q:A'[AA D
..S B=0
..F S B=$O(^ATXAX("B",A,B)) Q:'B D
...S XX=" ;;0;;AX;;"_^ATXAX(B,0)
...X Y
...S C=0
...F S C=$O(^ATXAX(B,11,C)) Q:'C D
....S XX=" ;;11;;AX;;"_C_";;"_^ATXAX(B,11,C,0)
....X Y
...S C=0
...F S C=$O(^ATXAX(B,21,C)) Q:C D
....S (YY,YYY)=+$P(^ATXAX(B,0),U,15)
....S XX=" ;;21;;AX;;"_C_";;"_^ATXAX(B,21,C,0),ZZ=$P(^(0),U)
....I YY,"^9999999.31^80^80.1^"'[(U_YY_U) D
.....S YY=$G(^DIC(YY,0,"GL"))
.....Q:YY=""
.....S YY=$P($G(@(YY_+ZZ_",0)")),U)
.....S:YY]"" XX=XX_";;"_YY
....I YYY=50,$P($G(^PSDRUG(ZZ,2)),U,4)["-" S $P(XX,";;",10)=$P(^(2),U,4)
....X Y
S (A,AA)="DM AUDIT"
F S A=$O(^ATXLAB("B",A)) Q:A'[AA D
.S B=0
.F S B=$O(^ATXLAB("B",A,B)) Q:'B D
..S XX=" ;;0;;LAB;;"_^ATXLAB(B,0)
..X Y
..S C=0
..F S C=$O(^ATXLAB(B,11,C)) Q:'C D
...S XX=" ;;11;;LAB;;"_C_";;"_^ATXLAB(B,11,C,0)
...X Y
..S C=0
..F S C=$O(^ATXLAB(B,21,C)) Q:C D
...S XX=" ;;21;;LAB;;"_C_";;"_^ATXLAB(B,21,C,0),ZZ=$P(^(0),U)
...S YY=$P($G(^LAB(60,+ZZ,0)),U)
...S XX=XX_";;"_$P($G(^LAB(60,+ZZ,0)),U)_";;"_$P($G(^(0)),U,12)
...X Y
...S D=0
...F S D=$O(^ATXLAB(B,21,C,11,D)) Q:'D D
....S YY=$P(^ATXLAB(B,0),U,9)
....S XX=" ;;21;;LAB;;"_C_";;"_D_";;SOURCE;;"_^ATXLAB(B,21,C,11,D,0)
....X Y
Q
ZIS ;EP;
W !!,"This process will update Taxonomies required by the"
W !,"DIABETES MANAGEMENT SYSTEM."
W !!,"Select the device on which to record taxonomies updated."
W !!,"Enter the name of a device for the report or"
W !,"enter '^' to exit the update process then press <ENTER>."
S DIR(0)="YO"
S DIR("A")="Do you want to proceed"
S DIR("B")="YES"
W !
D DIR^APCLDIC
Q:Y'=1
D TAXSET
Q
TAXSET ;EP;TO UPDATE DIABETES SYSTEM STANDARD TAXONOMIES
D T1
K ^TMP("TAXONOMIES",$J)
Q
T1 K APCLDA,APCLQUIT
S APCLJ=0
F S APCLJ=$O(^TMP("TAXONOMIES",$J,APCLJ)) Q:'APCLJ S Z=^TMP("TAXONOMIES",$J,APCLJ) D
.I $P(Z,";;",2)=0 D Q
..S X=$P($P(Z,";;",4),U)
..S APCLILE=$P($P(Z,";;",4),U,$S($P(Z,";;",3)="AX":15,1:9))
..S (APCLDIC,DIC)=$S($P(Z,";;",3)="AX":"^ATXAX(",1:"^ATXLAB(")
..I $D(@(DIC_"""B"","""_X_""")")) S APCLDA=$O(^(X,0)) Q
..I '$D(ZTQUEUED) U IO W !,"FILE NEW TAXONOMY: ",X
..S DIC(0)="L"
..D FILE^APCLDIC
..S APCLDA=+Y
..S @(APCLDIC_APCLDA_",0)")=$P(Z,";;",4,99),$P(^(0),U,5)=DUZ
..S DA=APCLDA
..S DIK=APCLDIC
..D IX1^APCLDIC
.Q:'$G(APCLDA)
.I $P(Z,";;",3)'="LAB" D DX
.I $P(Z,";;",3)="LAB" D LAB
Q
DX I $P(Z,";;",2)=11 D
.I '$D(^ATXAX(APCLDA,11,$P(Z,";;",4),0)) D
..S ^ATXAX(APCLDA,11,$P(Z,";;",4),0)=$P(Z,";;",5)
..S ^ATXAX(APCLDA,11,0)="^^"_$P(Z,";;",4)_"^"_$P(Z,";;",4)_"^"_DT
..I '$D(ZTQUEUED) U IO W !,"FILE DX DESCRIPTION: ",Z
I $P(Z,";;",2)=21 D
.S X=$P(Z,";;",6)
.S:X="" X=$P(Z,";;",5)
.Q:X=""
.S YY=$P(X,U),ZZ=$P(X,U,2)
.I YY]"","^9999999.31^80^80.1^"'[(U_APCLILE_U) D Q:'YY
..S YYY=$G(^DIC(APCLILE,0,"GL"))
..Q:YYY=""
..I APCLILE=50,$P(Z,";;",10)]"" S YY=$P(Z,";;",10),YY=$TR(YY,"-",""),YY=$O(^PSDRUG("ZNDC",YY,0)) Q:$D(^PSDRUG(+YY,0))
..S YY=$P(X,U)
..S YY=$O(@(YYY_"""B"","""_YY_""",0)"))
..I ZZ]"" S ZZ=$O(@(YYY_"""B"","""_ZZ_""",0)"))
.S:ZZ="" ZZ=YY
.Q:$D(^ATXAX(APCLDA,21,"B",YY))
.I '$D(ZTQUEUED) U IO W !?10,"FILE DX ITEM: ",X," ",YY," ",ZZ
.S X=YY
.S DA=APCLDA
.S DA(1)=APCLDA
.S DIC="^ATXAX("_DA_",21,"
.I $G(ZZ)]"" S DIC("DR")=".02////"_ZZ K ZZ
.S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"
.S DIC(0)="L"
.D FILE^APCLDIC
Q
LAB I $P(Z,";;",2)=11 D Q
.I '$D(^ATXLAB(APCLDA,11,$P(Z,";;",4),0)) D
..S ^ATXLAB(APCLDA,11,$P(Z,";;",4),0)=$P(Z,";;",5)
..S ^ATXLAB(APCLDA,11,0)="^^"_$P(Z,";;",4)_"^"_$P(Z,";;",4)_"^"_DT
..I '$D(ZTQUEUED) U IO W !,"FILE LAB DESCRIPTION: ",Z
I $P(Z,";;",2)=21,$P(Z,";;",6)'="SOURCE" D
.S YY=$P(Z,";;",5)
.I $P($G(^LAB(60,YY,0)),U,12)=$P(Z,";;",7)
.E D
..S YY=$P(Z,";;",6)
..Q:YY=""
..S YY=$O(^LAB(60,"B",YY,0))
..I 'YY,$D(^LAB(60,+$P(Z,";;",5),0)),$E($P(^(0),U),1,5)=$E($P(Z,";;",6),1,5) S YY=$P(Z,";;",5)
.Q:'YY
.Q:'$D(^LAB(60,YY,0))
.S APCLDA(1)=APCLDA
.Q:$D(^ATXLAB(APCLDA,21,"B",YY))
.I '$D(ZTQUEUED) U IO W !?10,"FILE LAB ITEM: ",YY
.S X=YY
.S DA=APCLDA
.S DA(1)=APCLDA
.S DIC="^ATXLAB("_DA_",21,"
.S DIC(0)="L"
.S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"
.D FILE^APCLDIC
.S APCLDA(1)=+Y
I $G(APCLDA),$G(APCLDA(1)),$P(Z,";;",2)=21,$P(Z,";;",6)="SOURCE" D
.I $D(^ATXLAB(APCLDA,21,APCLDA(1))),'$D(^ATXLAB(APCLDA,21,APCLDA(1),11,$P(Z,";;",5),0)) D
..S ^ATXLAB(APCLDA,21,APCLDA(1),11,$P(Z,";;",5),0)=$P(Z,";;",7)
..I '$D(ZTQUEUED) U IO W !?10,"FILE LAB ITEM SOURCE: ",Z
Q
APCLTAX3 ; 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 ;CREATE TAXONOMIES
+1 KILL ^TMP("TAXONOMIES",$JOB)
+2 SET APCLJ=0
+3 SET Y="S APCLJ=APCLJ+1 S ^TMP(""TAXONOMIES"",$J,APCLJ)=XX W ""."""
+4 FOR A="DM AUDIT","SURVEILLANCE","APCH DM"
Begin DoDot:1
+5 SET AA=A
+6 FOR
SET A=$ORDER(^ATXAX("B",A))
IF A'[AA
QUIT
Begin DoDot:2
+7 SET B=0
+8 FOR
SET B=$ORDER(^ATXAX("B",A,B))
IF 'B
QUIT
Begin DoDot:3
+9 SET XX=" ;;0;;AX;;"_^ATXAX(B,0)
+10 XECUTE Y
+11 SET C=0
+12 FOR
SET C=$ORDER(^ATXAX(B,11,C))
IF 'C
QUIT
Begin DoDot:4
+13 SET XX=" ;;11;;AX;;"_C_";;"_^ATXAX(B,11,C,0)
+14 XECUTE Y
End DoDot:4
+15 SET C=0
+16 FOR
SET C=$ORDER(^ATXAX(B,21,C))
IF C
QUIT
Begin DoDot:4
+17 SET (YY,YYY)=+$PIECE(^ATXAX(B,0),U,15)
+18 SET XX=" ;;21;;AX;;"_C_";;"_^ATXAX(B,21,C,0)
SET ZZ=$PIECE(^(0),U)
+19 IF YY
IF "^9999999.31^80^80.1^"'[(U_YY_U)
Begin DoDot:5
+20 SET YY=$GET(^DIC(YY,0,"GL"))
+21 IF YY=""
QUIT
+22 SET YY=$PIECE($GET(@(YY_+ZZ_",0)")),U)
+23 IF YY]""
SET XX=XX_";;"_YY
End DoDot:5
+24 IF YYY=50
IF $PIECE($GET(^PSDRUG(ZZ,2)),U,4)["-"
SET $PIECE(XX,";;",10)=$PIECE(^(2),U,4)
+25 XECUTE Y
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 SET (A,AA)="DM AUDIT"
+27 FOR
SET A=$ORDER(^ATXLAB("B",A))
IF A'[AA
QUIT
Begin DoDot:1
+28 SET B=0
+29 FOR
SET B=$ORDER(^ATXLAB("B",A,B))
IF 'B
QUIT
Begin DoDot:2
+30 SET XX=" ;;0;;LAB;;"_^ATXLAB(B,0)
+31 XECUTE Y
+32 SET C=0
+33 FOR
SET C=$ORDER(^ATXLAB(B,11,C))
IF 'C
QUIT
Begin DoDot:3
+34 SET XX=" ;;11;;LAB;;"_C_";;"_^ATXLAB(B,11,C,0)
+35 XECUTE Y
End DoDot:3
+36 SET C=0
+37 FOR
SET C=$ORDER(^ATXLAB(B,21,C))
IF C
QUIT
Begin DoDot:3
+38 SET XX=" ;;21;;LAB;;"_C_";;"_^ATXLAB(B,21,C,0)
SET ZZ=$PIECE(^(0),U)
+39 SET YY=$PIECE($GET(^LAB(60,+ZZ,0)),U)
+40 SET XX=XX_";;"_$PIECE($GET(^LAB(60,+ZZ,0)),U)_";;"_$PIECE($GET(^(0)),U,12)
+41 XECUTE Y
+42 SET D=0
+43 FOR
SET D=$ORDER(^ATXLAB(B,21,C,11,D))
IF 'D
QUIT
Begin DoDot:4
+44 SET YY=$PIECE(^ATXLAB(B,0),U,9)
+45 SET XX=" ;;21;;LAB;;"_C_";;"_D_";;SOURCE;;"_^ATXLAB(B,21,C,11,D,0)
+46 XECUTE Y
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT
ZIS ;EP;
+1 WRITE !!,"This process will update Taxonomies required by the"
+2 WRITE !,"DIABETES MANAGEMENT SYSTEM."
+3 WRITE !!,"Select the device on which to record taxonomies updated."
+4 WRITE !!,"Enter the name of a device for the report or"
+5 WRITE !,"enter '^' to exit the update process then press <ENTER>."
+6 SET DIR(0)="YO"
+7 SET DIR("A")="Do you want to proceed"
+8 SET DIR("B")="YES"
+9 WRITE !
+10 DO DIR^APCLDIC
+11 IF Y'=1
QUIT
+12 DO TAXSET
+13 QUIT
TAXSET ;EP;TO UPDATE DIABETES SYSTEM STANDARD TAXONOMIES
+1 DO T1
+2 KILL ^TMP("TAXONOMIES",$JOB)
+3 QUIT
T1 KILL APCLDA,APCLQUIT
+1 SET APCLJ=0
+2 FOR
SET APCLJ=$ORDER(^TMP("TAXONOMIES",$JOB,APCLJ))
IF 'APCLJ
QUIT
SET Z=^TMP("TAXONOMIES",$JOB,APCLJ)
Begin DoDot:1
+3 IF $PIECE(Z,";;",2)=0
Begin DoDot:2
+4 SET X=$PIECE($PIECE(Z,";;",4),U)
+5 SET APCLILE=$PIECE($PIECE(Z,";;",4),U,$SELECT($PIECE(Z,";;",3)="AX":15,1:9))
+6 SET (APCLDIC,DIC)=$SELECT($PIECE(Z,";;",3)="AX":"^ATXAX(",1:"^ATXLAB(")
+7 IF $DATA(@(DIC_"""B"","""_X_""")"))
SET APCLDA=$ORDER(^(X,0))
QUIT
+8 IF '$DATA(ZTQUEUED)
USE IO
WRITE !,"FILE NEW TAXONOMY: ",X
+9 SET DIC(0)="L"
+10 DO FILE^APCLDIC
+11 SET APCLDA=+Y
+12 SET @(APCLDIC_APCLDA_",0)")=$PIECE(Z,";;",4,99)
SET $PIECE(^(0),U,5)=DUZ
+13 SET DA=APCLDA
+14 SET DIK=APCLDIC
+15 DO IX1^APCLDIC
End DoDot:2
QUIT
+16 IF '$GET(APCLDA)
QUIT
+17 IF $PIECE(Z,";;",3)'="LAB"
DO DX
+18 IF $PIECE(Z,";;",3)="LAB"
DO LAB
End DoDot:1
+19 QUIT
DX IF $PIECE(Z,";;",2)=11
Begin DoDot:1
+1 IF '$DATA(^ATXAX(APCLDA,11,$PIECE(Z,";;",4),0))
Begin DoDot:2
+2 SET ^ATXAX(APCLDA,11,$PIECE(Z,";;",4),0)=$PIECE(Z,";;",5)
+3 SET ^ATXAX(APCLDA,11,0)="^^"_$PIECE(Z,";;",4)_"^"_$PIECE(Z,";;",4)_"^"_DT
+4 IF '$DATA(ZTQUEUED)
USE IO
WRITE !,"FILE DX DESCRIPTION: ",Z
End DoDot:2
End DoDot:1
+5 IF $PIECE(Z,";;",2)=21
Begin DoDot:1
+6 SET X=$PIECE(Z,";;",6)
+7 IF X=""
SET X=$PIECE(Z,";;",5)
+8 IF X=""
QUIT
+9 SET YY=$PIECE(X,U)
SET ZZ=$PIECE(X,U,2)
+10 IF YY]""
IF "^9999999.31^80^80.1^"'[(U_APCLILE_U)
Begin DoDot:2
+11 SET YYY=$GET(^DIC(APCLILE,0,"GL"))
+12 IF YYY=""
QUIT
+13 IF APCLILE=50
IF $PIECE(Z,";;",10)]""
SET YY=$PIECE(Z,";;",10)
SET YY=$TRANSLATE(YY,"-","")
SET YY=$ORDER(^PSDRUG("ZNDC",YY,0))
IF $DATA(^PSDRUG(+YY,0))
QUIT
+14 SET YY=$PIECE(X,U)
+15 SET YY=$ORDER(@(YYY_"""B"","""_YY_""",0)"))
+16 IF ZZ]""
SET ZZ=$ORDER(@(YYY_"""B"","""_ZZ_""",0)"))
End DoDot:2
IF 'YY
QUIT
+17 IF ZZ=""
SET ZZ=YY
+18 IF $DATA(^ATXAX(APCLDA,21,"B",YY))
QUIT
+19 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,"FILE DX ITEM: ",X," ",YY," ",ZZ
+20 SET X=YY
+21 SET DA=APCLDA
+22 SET DA(1)=APCLDA
+23 SET DIC="^ATXAX("_DA_",21,"
+24 IF $GET(ZZ)]""
SET DIC("DR")=".02////"_ZZ
KILL ZZ
+25 IF '$DATA(^ATXAX(DA,21,0))
SET ^ATXAX(DA,21,0)="^9002226.02101A"
+26 SET DIC(0)="L"
+27 DO FILE^APCLDIC
End DoDot:1
+28 QUIT
LAB IF $PIECE(Z,";;",2)=11
Begin DoDot:1
+1 IF '$DATA(^ATXLAB(APCLDA,11,$PIECE(Z,";;",4),0))
Begin DoDot:2
+2 SET ^ATXLAB(APCLDA,11,$PIECE(Z,";;",4),0)=$PIECE(Z,";;",5)
+3 SET ^ATXLAB(APCLDA,11,0)="^^"_$PIECE(Z,";;",4)_"^"_$PIECE(Z,";;",4)_"^"_DT
+4 IF '$DATA(ZTQUEUED)
USE IO
WRITE !,"FILE LAB DESCRIPTION: ",Z
End DoDot:2
End DoDot:1
QUIT
+5 IF $PIECE(Z,";;",2)=21
IF $PIECE(Z,";;",6)'="SOURCE"
Begin DoDot:1
+6 SET YY=$PIECE(Z,";;",5)
+7 IF $PIECE($GET(^LAB(60,YY,0)),U,12)=$PIECE(Z,";;",7)
+8 IF '$TEST
Begin DoDot:2
+9 SET YY=$PIECE(Z,";;",6)
+10 IF YY=""
QUIT
+11 SET YY=$ORDER(^LAB(60,"B",YY,0))
+12 IF 'YY
IF $DATA(^LAB(60,+$PIECE(Z,";;",5),0))
IF $EXTRACT($PIECE(^(0),U),1,5)=$EXTRACT($PIECE(Z,";;",6),1,5)
SET YY=$PIECE(Z,";;",5)
End DoDot:2
+13 IF 'YY
QUIT
+14 IF '$DATA(^LAB(60,YY,0))
QUIT
+15 SET APCLDA(1)=APCLDA
+16 IF $DATA(^ATXLAB(APCLDA,21,"B",YY))
QUIT
+17 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,"FILE LAB ITEM: ",YY
+18 SET X=YY
+19 SET DA=APCLDA
+20 SET DA(1)=APCLDA
+21 SET DIC="^ATXLAB("_DA_",21,"
+22 SET DIC(0)="L"
+23 IF '$DATA(^ATXLAB(DA,21,0))
SET ^ATXLAB(DA,21,0)="^9002228.02101PA"
+24 DO FILE^APCLDIC
+25 SET APCLDA(1)=+Y
End DoDot:1
+26 IF $GET(APCLDA)
IF $GET(APCLDA(1))
IF $PIECE(Z,";;",2)=21
IF $PIECE(Z,";;",6)="SOURCE"
Begin DoDot:1
+27 IF $DATA(^ATXLAB(APCLDA,21,APCLDA(1)))
IF '$DATA(^ATXLAB(APCLDA,21,APCLDA(1),11,$PIECE(Z,";;",5),0))
Begin DoDot:2
+28 SET ^ATXLAB(APCLDA,21,APCLDA(1),11,$PIECE(Z,";;",5),0)=$PIECE(Z,";;",7)
+29 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,"FILE LAB ITEM SOURCE: ",Z
End DoDot:2
End DoDot:1
+30 QUIT
