BDMDC1D ; IHS/CMI/LAB - BDM Continuation of BDMDC1C 1/11/2014 1:54:57 PM ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53
;
;
;
MICRO ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM(1)) S %1="" D ACRATIOM^BDMDC1C Q %1
D SETN
NEW % S %=$P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)
S %1=$S(%="":"No result",%["+":"Pos ",%[">":"Pos ",$E(%)="P":"Pos ",$E(%)="p":"Pos ",$E(%)="c":"No result ",$E(%)="C":"No result ",+%>29:"Pos ",1:"Neg ")
Q %1_%_" "_$$FMTE^XLFDT($P(BDM(N),U),"5")_" "_$P(BDM(N),U,3)
HGBA1C ;EP
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,G
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)="" ;no result
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["COMMENT"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
D SET3
;K X S (%,C,R)="" F S %=$O(BDM(%)) Q:%'=+%!(C>1) S C=C+1,X(9999999-$P(BDM(%),U),C)=$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)
;S %=0,R="" F S %=$O(X(%)) Q:%="" S V=0 F S V=$O(X(%,V)) Q:V="" S R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"
;separate those with a result and those without a result
;first put in reverse date order
S (N,C,R)=""
K BDMR
F S N=$O(BDM(N)) Q:N'=+N D
.S D=$P(BDM(N),U)
.S R=$P(BDM(N),U,2) I R="?" S R=""
.I R]"" S BDMR("R",(9999999-D),N)=BDM(N)
.I R="" S BDMR("NR",(9999999-D),N)=BDM(N)
S R=""
S D=0 F S D=$O(BDMR("R",D)) Q:D'=+D!(R]"") D
.S N=0 F S N=$O(BDMR("R",D,N)) Q:N'=+N!(R]"") D
..S R=BDMR("R",D,N)
I R]"" Q R
S D=0 F S D=$O(BDMR("NR",D)) Q:D'=+D!(R]"") D
.S N=0 F S N=$O(BDMR("NR",D,N)) Q:N'=+N!(R]"") D
..S R=BDMR("NR",D,N)
Q R
BS ;EP
NEW BDM,X,%,E,R,V,C
K BDM
S %=P_"^LAST 200 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I '$D(BDM(1)) Q ""
D SET3
S (%,C,R)="" F S %=$O(BDM(%)) Q:%=""!(C>2) S R=R_$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(%),U))_"^",C=C+1
Q R
;
FGLUCOSE ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(N),U),5)
G75 ;EP
I $G(F)="" S F="E"
NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
K BDM
S BDMC=0
S BDMOT=$O(^ATXAX("B","DM AUDIT 75GM 2HR LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",0))
D GATHER
I '$D(BDM(1)) Q ""
D SETN
I F="I" Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_"^"_$P(BDM(N),U)
Q $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(N),U),5)
;
GATHER ;
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($D(BDM)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,BDMOT)
...D SETV
...Q
I '$D(BDM(1)) Q
S D=$P(BDM(1),U),D=9999999-D
K BDM S BDMC=0
S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
..Q:'$D(^AUPNVLAB(X,0))
..I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D SETV Q
..Q:'BDMOT
..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
..Q:'$$LOINC(J,BDMOT)
..D SETV
..Q
Q
LOINC(A,B) ;EP - is loinc code A in taxonomy B
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
SETV ;
S BDMC=BDMC+1
S V=$P(^AUPNVLAB(X,0),U,3),BDMV=$P($P($G(^AUPNVSIT(V,0)),U),".") Q:'BDMV
S BDM(BDMC)=BDMV_"^"_$S($P(^AUPNVLAB(X,0),U,4)]"":$P(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
Q
SETN ;
S N="" NEW A,G S (A,G)=0 F S A=$O(BDM(A)) Q:A'=+A!(G) S R=$P(^AUPNVLAB(+$P(BDM(A),U,4),0),U,4) I R]"",$$UP^XLFSTR(R)'="COMMENT" S G=A
S N=$S(G:G,1:1)
Q
SET3 ;
NEW X,N1,N2,N3,A,T,G,N
K A
S X=0 F S X=$O(BDM(X)) Q:X'=+X S A($P(BDM(X),U),X)=""
NEW D S D=0 F S D=$O(A(D)) Q:D'=+D D
.S G=0,N=0 F S N=$O(A(D,N)) Q:N'=+N D
..I $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)]"",$$UP^XLFSTR($P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4))'="COMMENT" S G=1 Q
.I G S N=0 F S N=$O(A(D,N)) Q:N'=+N I $P(^AUPNVLAB(+$P(BDM(N),U,4),0),U,4)="" K BDM(N)
.Q
Q
BDMDC1D ; IHS/CMI/LAB - BDM Continuation of BDMDC1C 1/11/2014 1:54:57 PM ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53
+2 ;
+3 ;
+4 ;
MICRO ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+2 KILL BDM
SET BDMC=0
+3 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT MICROALBUMIN LOINC",0))
+4 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT MICROALBUMINURIA TAX",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+10 IF 'BDMOT
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 IF '$$LOINC(J,BDMOT)
QUIT
+13 DO SETV
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF '$DATA(BDM(1))
SET %1=""
DO ACRATIOM^BDMDC1C
QUIT %1
+16 DO SETN
+17 NEW %
SET %=$PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)
+18 SET %1=$SELECT(%="":"No result",%["+":"Pos ",%[">":"Pos ",$EXTRACT(%)="P":"Pos ",$EXTRACT(%)="p":"Pos ",$EXTRACT(%)="c":"No result ",$EXTRACT(%)="C":"No result ",+%>29:"Pos ",1:"Neg ")
+19 QUIT %1_%_" "_$$FMTE^XLFDT($PIECE(BDM(N),U),"5")_" "_$PIECE(BDM(N),U,3)
HGBA1C ;EP
+1 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V,G
+2 KILL BDM
+3 SET BDMC=0
+4 SET BDMOT=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+5 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+6 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 ;no result
IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+11 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+12 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["COMMENT"
QUIT
+13 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+14 IF 'BDMOT
QUIT
+15 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+16 IF '$$LOINC(J,BDMOT)
QUIT
+17 DO SETV
+18 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 DO SET3
+20 ;K X S (%,C,R)="" F S %=$O(BDM(%)) Q:%'=+%!(C>1) S C=C+1,X(9999999-$P(BDM(%),U),C)=$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)
+21 ;S %=0,R="" F S %=$O(X(%)) Q:%="" S V=0 F S V=$O(X(%,V)) Q:V="" S R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"
+22 ;separate those with a result and those without a result
+23 ;first put in reverse date order
+24 SET (N,C,R)=""
+25 KILL BDMR
+26 FOR
SET N=$ORDER(BDM(N))
IF N'=+N
QUIT
Begin DoDot:1
+27 SET D=$PIECE(BDM(N),U)
+28 SET R=$PIECE(BDM(N),U,2)
IF R="?"
SET R=""
+29 IF R]""
SET BDMR("R",(9999999-D),N)=BDM(N)
+30 IF R=""
SET BDMR("NR",(9999999-D),N)=BDM(N)
End DoDot:1
+31 SET R=""
+32 SET D=0
FOR
SET D=$ORDER(BDMR("R",D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+33 SET N=0
FOR
SET N=$ORDER(BDMR("R",D,N))
IF N'=+N!(R]"")
QUIT
Begin DoDot:2
+34 SET R=BDMR("R",D,N)
End DoDot:2
End DoDot:1
+35 IF R]""
QUIT R
+36 SET D=0
FOR
SET D=$ORDER(BDMR("NR",D))
IF D'=+D!(R]"")
QUIT
Begin DoDot:1
+37 SET N=0
FOR
SET N=$ORDER(BDMR("NR",D,N))
IF N'=+N!(R]"")
QUIT
Begin DoDot:2
+38 SET R=BDMR("NR",D,N)
End DoDot:2
End DoDot:1
+39 QUIT R
BS ;EP
+1 NEW BDM,X,%,E,R,V,C
+2 KILL BDM
+3 SET %=P_"^LAST 200 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+4 IF '$DATA(BDM(1))
QUIT ""
+5 DO SET3
+6 SET (%,C,R)=""
FOR
SET %=$ORDER(BDM(%))
IF %=""!(C>2)
QUIT
SET R=R_$PIECE(^AUPNVLAB(+$PIECE(BDM(%),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(%),U))_"^"
SET C=C+1
+7 QUIT R
+8 ;
FGLUCOSE ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(N),U),5)
G75 ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW BDM,X,%,E,R,V,BDMLT,BDMOT,B,D,L,J,BDMC,BDMV,V
+3 KILL BDM
+4 SET BDMC=0
+5 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT 75GM 2HR LOINC",0))
+6 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",0))
+7 DO GATHER
+8 IF '$DATA(BDM(1))
QUIT ""
+9 DO SETN
+10 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_"^"_$PIECE(BDM(N),U)
+11 QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(N),U),5)
+12 ;
GATHER ;
+1 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($DATA(BDM))
QUIT
Begin DoDot:1
+2 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+4 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+5 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+6 IF 'BDMOT
QUIT
+7 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+8 IF '$$LOINC(J,BDMOT)
QUIT
+9 DO SETV
+10 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 IF '$DATA(BDM(1))
QUIT
+12 SET D=$PIECE(BDM(1),U)
SET D=9999999-D
+13 KILL BDM
SET BDMC=0
+14 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+17 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
DO SETV
QUIT
+18 IF 'BDMOT
QUIT
+19 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+20 IF '$$LOINC(J,BDMOT)
QUIT
+21 DO SETV
+22 QUIT
End DoDot:2
End DoDot:1
+23 QUIT
LOINC(A,B) ;EP - is loinc code A in taxonomy B
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
SETV ;
+1 SET BDMC=BDMC+1
+2 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
SET BDMV=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF 'BDMV
QUIT
+3 SET BDM(BDMC)=BDMV_"^"_$SELECT($PIECE(^AUPNVLAB(X,0),U,4)]"":$PIECE(^AUPNVLAB(X,0),U,4),1:"")_"^"_$$VAL^XBDIQ1(9000010.09,X,.01)_"^"_X_";AUPNVLAB^"_V
+4 QUIT
SETN ;
+1 SET N=""
NEW A,G
SET (A,G)=0
FOR
SET A=$ORDER(BDM(A))
IF A'=+A!(G)
QUIT
SET R=$PIECE(^AUPNVLAB(+$PIECE(BDM(A),U,4),0),U,4)
IF R]""
IF $$UP^XLFSTR(R)'="COMMENT"
SET G=A
+2 SET N=$SELECT(G:G,1:1)
+3 QUIT
SET3 ;
+1 NEW X,N1,N2,N3,A,T,G,N
+2 KILL A
+3 SET X=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X
QUIT
SET A($PIECE(BDM(X),U),X)=""
+4 NEW D
SET D=0
FOR
SET D=$ORDER(A(D))
IF D'=+D
QUIT
Begin DoDot:1
+5 SET G=0
SET N=0
FOR
SET N=$ORDER(A(D,N))
IF N'=+N
QUIT
Begin DoDot:2
+6 IF $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)]""
IF $$UP^XLFSTR($PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4))'="COMMENT"
SET G=1
QUIT
End DoDot:2
+7 IF G
SET N=0
FOR
SET N=$ORDER(A(D,N))
IF N'=+N
QUIT
IF $PIECE(^AUPNVLAB(+$PIECE(BDM(N),U,4),0),U,4)=""
KILL BDM(N)
+8 QUIT
End DoDot:1
+9 QUIT
