BDMFTAX3 ; cmi/anch/maw - DMS TAXONOMY MANAGEMENT UTILITY ;
;;2.0;DIABETES MANAGEMENT SYSTEM;;AUG 11, 2006
;UTILITY PROGRAM TO MANAGE TAXONOMY CREATION AND EDITING
;
;IT IS NOW INCLUDED WITH PATCH #5 THOUGH DOES NOT APPEAR
;TO BE CALLED FROM ANY OTHER ROUTINE OR DICTIONARY OR
;MENU OPTION
;
TAX ;CREATE TAXONOMIES
;REMOVED CODE IN 2.0 DISTRIBUTION
Q
ZIS 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^BDMFDIC
Q:Y'=1
S (ZTRTN,BDMRTN)="TAXSET^BDMFTAX3"
S ZTDESC="UPDATE DIABETES SYSTEM TAXONOMIES"
D ^BDMFZIS
Q
TAXSET ;EP;TO UPDATE DIABETES SYSTEM STANDARD TAXONOMIES
D T1
K ^TMP("TAXONOMIES")
Q
T1 K BDMDA,BDMQUIT
;Removed Code from 2.0 Dist
Q
DX I $P(Z,";;",2)=11 D
.I '$D(^ATXAX(BDMDA,11,$P(Z,";;",4),0)) D
..S ^ATXAX(BDMDA,11,$P(Z,";;",4),0)=$P(Z,";;",5)
..S ^ATXAX(BDMDA,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_BDMFILE_U) D Q:'YY
..S YYY=$G(^DIC(BDMFILE,0,"GL"))
..Q:YYY=""
..I BDMFILE=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(BDMDA,21,"B",YY))
.I '$D(ZTQUEUED) U IO W !?10,"FILE DX ITEM: ",X," ",YY," ",ZZ
.S X=YY
.S DA=BDMDA
.S DA(1)=BDMDA
.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^BDMFDIC
Q
LAB I $P(Z,";;",2)=11 D Q
.I '$D(^ATXLAB(BDMDA,11,$P(Z,";;",4),0)) D
..S ^ATXLAB(BDMDA,11,$P(Z,";;",4),0)=$P(Z,";;",5)
..S ^ATXLAB(BDMDA,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 BDMDA(1)=BDMDA
.Q:$D(^ATXLAB(BDMDA,21,"B",YY))
.I '$D(ZTQUEUED) U IO W !?10,"FILE LAB ITEM: ",YY
.S X=YY
.S DA=BDMDA
.S DA(1)=BDMDA
.S DIC="^ATXLAB("_DA_",21,"
.S DIC(0)="L"
.S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"
.D FILE^BDMFDIC
.S BDMDA(1)=+Y
I $G(BDMDA),$G(BDMDA(1)),$P(Z,";;",2)=21,$P(Z,";;",6)="SOURCE" D
.I $D(^ATXLAB(BDMDA,21,BDMDA(1))),'$D(^ATXLAB(BDMDA,21,BDMDA(1),11,$P(Z,";;",5),0)) D
..S ^ATXLAB(BDMDA,21,BDMDA(1),11,$P(Z,";;",5),0)=$P(Z,";;",7)
..I '$D(ZTQUEUED) U IO W !?10,"FILE LAB ITEM SOURCE: ",Z
Q
BDMFTAX3 ; cmi/anch/maw - DMS TAXONOMY MANAGEMENT UTILITY ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;;AUG 11, 2006
+2 ;UTILITY PROGRAM TO MANAGE TAXONOMY CREATION AND EDITING
+3 ;
+4 ;IT IS NOW INCLUDED WITH PATCH #5 THOUGH DOES NOT APPEAR
+5 ;TO BE CALLED FROM ANY OTHER ROUTINE OR DICTIONARY OR
+6 ;MENU OPTION
+7 ;
TAX ;CREATE TAXONOMIES
+1 ;REMOVED CODE IN 2.0 DISTRIBUTION
+2 QUIT
ZIS WRITE !!,"This process will update Taxonomies required by the"
+1 WRITE !,"DIABETES MANAGEMENT SYSTEM."
+2 WRITE !!,"Select the device on which to record taxonomies updated."
+3 WRITE !!,"Enter the name of a device for the report or"
+4 WRITE !,"enter '^' to exit the update process then press <ENTER>."
+5 SET DIR(0)="YO"
+6 SET DIR("A")="Do you want to proceed"
+7 SET DIR("B")="YES"
+8 WRITE !
+9 DO DIR^BDMFDIC
+10 IF Y'=1
QUIT
+11 SET (ZTRTN,BDMRTN)="TAXSET^BDMFTAX3"
+12 SET ZTDESC="UPDATE DIABETES SYSTEM TAXONOMIES"
+13 DO ^BDMFZIS
+14 QUIT
TAXSET ;EP;TO UPDATE DIABETES SYSTEM STANDARD TAXONOMIES
+1 DO T1
+2 KILL ^TMP("TAXONOMIES")
+3 QUIT
T1 KILL BDMDA,BDMQUIT
+1 ;Removed Code from 2.0 Dist
+2 QUIT
DX IF $PIECE(Z,";;",2)=11
Begin DoDot:1
+1 IF '$DATA(^ATXAX(BDMDA,11,$PIECE(Z,";;",4),0))
Begin DoDot:2
+2 SET ^ATXAX(BDMDA,11,$PIECE(Z,";;",4),0)=$PIECE(Z,";;",5)
+3 SET ^ATXAX(BDMDA,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_BDMFILE_U)
Begin DoDot:2
+11 SET YYY=$GET(^DIC(BDMFILE,0,"GL"))
+12 IF YYY=""
QUIT
+13 IF BDMFILE=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(BDMDA,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=BDMDA
+22 SET DA(1)=BDMDA
+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^BDMFDIC
End DoDot:1
+28 QUIT
LAB IF $PIECE(Z,";;",2)=11
Begin DoDot:1
+1 IF '$DATA(^ATXLAB(BDMDA,11,$PIECE(Z,";;",4),0))
Begin DoDot:2
+2 SET ^ATXLAB(BDMDA,11,$PIECE(Z,";;",4),0)=$PIECE(Z,";;",5)
+3 SET ^ATXLAB(BDMDA,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 BDMDA(1)=BDMDA
+16 IF $DATA(^ATXLAB(BDMDA,21,"B",YY))
QUIT
+17 IF '$DATA(ZTQUEUED)
USE IO
WRITE !?10,"FILE LAB ITEM: ",YY
+18 SET X=YY
+19 SET DA=BDMDA
+20 SET DA(1)=BDMDA
+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^BDMFDIC
+25 SET BDMDA(1)=+Y
End DoDot:1
+26 IF $GET(BDMDA)
IF $GET(BDMDA(1))
IF $PIECE(Z,";;",2)=21
IF $PIECE(Z,";;",6)="SOURCE"
Begin DoDot:1
+27 IF $DATA(^ATXLAB(BDMDA,21,BDMDA(1)))
IF '$DATA(^ATXLAB(BDMDA,21,BDMDA(1),11,$PIECE(Z,";;",5),0))
Begin DoDot:2
+28 SET ^ATXLAB(BDMDA,21,BDMDA(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
