BGP8D3A ;IHS/CMI/LAB - MEASURE LOGIC;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
SEALDEV(P,BDATE,EDATE) ;EP
NEW BGPG,BGPX,BGPC,%,X,V,T
S BGPC=0
K BGPG
S %=P_"^ALL ADA 0007;DURING "_$$DATE^BGP8UTL(BDATE)_"-"_$$DATE^BGP8UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
S %="",X=0
F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) S %=1_U_$$DATE^BGP8UTL($P(BGPG(1),U,1))_" RPMS DENTAL 0007"
Q %
TF(P,BDATE,EDATE) ;EP
NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
K BGPG,BGPZ S BGPC=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S Z=$O(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPC>3) S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y!(G>0)!($P(BGPC,U,1)>3) D
..S A=$P($G(^AUPNVDEN(Y,0)),U) D
...I $D(^ATXAX(Z,21,"B",A)) S T=1 S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=G+1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3))_"|RPMS DENTAL "_$$VAL^XBDIQ1(9000010.05,Y,.01)
...Q
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..I $$ICD^BGP8UTL2(A,$O(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1) S T=1 S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=G+1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVCPT(Y,0),U,3))_"|CDT "_$$VAL^XBDIQ1(9000010.18,Y,.01) ;one per visit
.Q:G ;one per visit
.S Y=0,G=0 F S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..Q:'$D(^AUPNVTC(Y,0))
..S I=$P(^AUPNVTC(Y,0),U,7)
..Q:I=""
..I $$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1) S T=1 S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=G+1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVTC(Y,0),U,3))_"|CDT/TRAN "_$$VAL^XBDIQ1(9000010.33,Y,.07) ;one per visit
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..S A=$P($G(^AUPNVPOV(Y,0)),U) I A D
...I $$ICD^BGP8UTL2(A,$O(^ATXAX("B","BGP TOPICAL FLUORIDE DXS",0)),9) S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3))_"|POV "_$$VAL^XBDIQ1(9000010.07,Y,.01) ;one per visit
...Q
I BGPC Q BGPC
Q ""
SEAL(P,BDATE,EDATE) ;EP
NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,BGPCNT
K BGPG,BGPX
S BGPCNT=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S BGPC=0
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
...I A'=1351,A'=1352 Q
...S G=1
...S T=$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1
...S S=$P(^AUPNVDEN(Y,0),U,5)
...I S]"" D
....I $G(BGPX(S))<2 D
.....I T=1 S BGPX(S)=$G(BGPX(S))+T
.....I T'=1 S T=$S(T>(2-$G(BGPX(S))):(2-$G(BGPX(S))),1:T),BGPX(S)=$G(BGPX(S))+T ;only first 2 per tooth
.....S BGPCNT=BGPCNT+1 S BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL "_A_" ("_T_")"
...I S="" S BGPX("NO OS")=$G(BGPX("NO OS"))+T,BGPCNT=BGPCNT+1,BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL "_A_"("_T_")"
...Q
.Q:G ;had ADA1351/1352 codes so skip cpts/0007
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..S A=$P($$CPT^ICPTCOD(A),U,2) I A="D1351" D
...S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1
...S BGPX("CPT")=$G(BGPX("CPT"))+T,BGPCNT=BGPCNT+1,BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVCPT(Y,0),U,3)))="CDT D1351 ("_T_")"
S X="" F S X=$O(BGPX(X)) Q:X="" I X'="CPT" S BGPC=BGPC+$S(BGPX(X)>2:2,1:BGPX(X))
S BGPC=BGPC+$G(BGPX("CPT"))
S BGPSEAL=BGPC
Q
SEALR(P,BDATE,EDATE) ;EP
NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,BGPCNT
K BGPG,BGPX
S BGPCNT=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S BGPC=0
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
...I A'=1353 Q
...S G=1
...S T=1 ;$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1 DOESN'T MATTER HOW MANY, WE ARE ONLY COUNTING 1 PER TOOTH
...S S=$P(^AUPNVDEN(Y,0),U,5)
...I S]"" D
....I $G(BGPX(S))<1 D
.....S BGPX(S)=$G(BGPX(S))+1
.....S BGPCNT=BGPCNT+1 S BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL "_A_" ("_T_")"
...I S="" S BGPX("NO OS")=$G(BGPX("NO OS"))+T,BGPCNT=BGPCNT+1,BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL 1353 ("_T_")"
...Q
.Q:G ;had ADA1353 SO SKIP CPTS
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..S A=$P($$CPT^ICPTCOD(A),U,2) I A="D1353" D
...S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1
...S BGPX("CPT")=$G(BGPX("CPT"))+T,BGPCNT=BGPCNT+1,BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVCPT(Y,0),U,3)))="CDT D1353 ("_T_")"
S X="" F S X=$O(BGPX(X)) Q:X="" I X'="CPT" S BGPC=BGPC+$S(BGPX(X)>1:1,1:BGPX(X))
S BGPC=BGPC+$G(BGPX("CPT"))
S BGPSEALR=BGPC
Q
HIGHR(P,EDATE) ;EP
;must have 2 dx in past 3 years, then check problem list before EDATE
NEW BGPG,Y,X,G,V,BDATE,C,D
S BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
S Y="BGPG(",G="",C=0
S X=P_"^ALL DX [BGP HIGH RISK FLU DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G HRPL
K Y S X=0,G=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S D=$P(BGPG(X),U,1)
.Q:$D(Y(D)) ;already had one on that day
.S Y(D)=""
.S C=C+1
.I C>1 S G=1
I G Q G
HRPL ;
S G=""
S T=$O(^ATXAX("B","BGP HIGH RISK FLU DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.I EDATE,$P(^AUPNPROB(X,0),U,13)>EDATE Q
.I $P(^AUPNPROB(X,0),U,13)="" Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after beginning of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:'$$ICD^BGP8UTL2(Y,T,9)
.S G=1
.Q
Q G
DTAP(P,BDATE,EDATE) ;EP
K BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM,D
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPVARI
;get all immunizations
;S C="115"
;D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
S BGPX=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"IMMUNIZATION",115)
I BGPX S BGPX=$P(BGPX,U,2)_U_$$DATE^BGP8UTL($P(BGPX,U,2))_" Imm 115"
;go through and set into array if 10 days apart
;now add in LAST cpt codes if on different dates
S C=+$$CODEN^ICPTCOD(90715)
S D=$$CPTI^BGP8DU(P,BDATE,EDATE,C)
I $P(D,U,2)>$P(BGPX,U,1) S BGPX=$P(D,U,2)_U_$$DATE^BGP8UTL($P(D,U,2))_" CPT 90715"
I BGPX Q 1_U_$P(BGPX,U,2)
;I $D(BGPVARI) Q 1_U_$$DATE^BGP8UTL($O(BGPVARI(9999999),-1))_" CPT 90715"
F BGPZ=115 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
I X]"" Q 2_U_$$DATE^BGP8UTL($P(X,U,1))_" "_$P(X,U,2)
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=115 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S R=D ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q 2_U_$$DATE^BGP8UTL(R)_" "_"NMI Dtap"
S R="",B=+$$CODEN^ICPTCOD(90715)
S G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
I G Q 2_U_$$DATE^BGP8UTL($P(G,U,2))_" "_"NMI Dtap 90715"
Q ""
DTAPTD(P,BDATE,EDATE) ;EP
NEW BDM,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,TK,BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM,T
K TDD
D LASTTDN ;get td from v imm
S LTD=$O(TDD(0))
I LTD]"" S LTD=(9999999-LTD)_U_$$DATE^BGP8UTL(9999999-LTD)_" Imm "_TDD(LTD)
;now check cpt codes
S T=$O(^ATXAX("B","BGP CPT TDAP/TD",0))
S BGPVARI=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
I $P(BGPVARI,U,1)>$P(LTD,U,1) S LTD=$P(BGPVARI,U,1)_U_$$DATE^BGP8UTL($P(BGPVARI,U,1))_" CPT "_$P(BGPVARI,U,2)
K BGPG S %=P_"^LAST DX [BGP TD IZ DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U,1)>$P(LTD,U,1) S LTD=$P(BGPG(1),U,1)_U_$$DATE^BGP8UTL($P(BGPG(1),U))_" DX V06.5"
I LTD Q 1_U_$P(LTD,U,2)
F BGPZ=115,9,113,138,139 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 2_U_$$DATE^BGP8UTL($P(X,U,1))_" "_$P(X,U,2)
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=115,9,113,138,139 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S R=D ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q 2_U_$$DATE^BGP8UTL(R)_" NMI Dtap/Td"
S R="",B=+$$CODEN^ICPTCOD(90715)
S G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
I G Q 2_U_$$DATE^BGP8UTL($P(G,U,2))_" "_"NMI Dtap 90715"
S R="",B=+$$CODEN^ICPTCOD(90714)
S G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
I G Q 2_U_$$DATE^BGP8UTL($P(G,U,2))_" "_"NMI Dtap 90714"
S R="",B=+$$CODEN^ICPTCOD(90718)
S G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
I G Q 2_U_$$DATE^BGP8UTL($P(G,U,2))_" "_"NMI Dtap 90718"
Q ""
;
LASTTDN ;
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Y=$P(^AUTTIMM(Y,0),U,3)
.S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.I D<BDATE Q ;too early
.I D>EDATE Q ;after time frame
.I Y=9 S TDD(9999999-D)=9 Q
.I Y=113 S TDD(9999999-D)=113 Q
.I Y=115 S TDD(9999999-D)=115 Q
.I Y=138 S TDD(9999999-D)=138 Q
.I Y=139 S TDD(9999999-D)=139 Q
Q
;;
HIGHRP(P,EDATE) ;EP
;must have 2 dx in past 3 years, then check problem list before EDATE
NEW BGPG,Y,X,G,V,BDATE,C,D
S BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
S Y="BGPG(",G="",C=0
S X=P_"^ALL DX [BGP HIGH RISK PNEUMO DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G HRPL
K Y S X=0,G=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S D=$P(BGPG(X),U,1)
.Q:$D(Y(D)) ;already had one on that day
.S Y(D)=""
.S C=C+1
.I C>1 S G=1
I G Q G
HRPLP ;
S G=""
S T=$O(^ATXAX("B","BGP HIGH RISK PNEUMO DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.I EDATE,$P(^AUPNPROB(X,0),U,13)>EDATE Q
.I $P(^AUPNPROB(X,0),U,13)="" Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after beginning of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:'$$ICD^BGP8UTL2(Y,T,9)
.S G=1
.Q
Q G
GA(P,BDATE,EDATE) ;EP
NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R,BGPC,BGPGA,BGPGASSC
K BGPG,BGPZ S BGPC=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S Z=$O(^ATXAX("B","BGP GEN ANESTHESIA ADA CODES",0))
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) D
...I $D(^ATXAX(Z,21,"B",A)) S BGPZ(V)=""
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..I $$ICD^BGP8UTL2(A,$O(^ATXAX("B","BGP CPT DENT GEN ANESTHESIA",0)),1) S BGPZ(V)=""
;ARRAY BGPZ has all visits with general anesthesia
S BGPGA=0 S X=0 F S X=$O(BGPZ(X)) Q:X'=+X S BGPGA=BGPGA+1
;LOOP THROUGH THESES VISITS AND SEE IF THEY HAVE A SSC
S Z=$O(^ATXAX("B","BGP SSC ADA CODES",0))
S V=0 F S V=$O(BGPZ(V)) Q:V'=+V D
.S Y=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) D
...I $D(^ATXAX(Z,21,"B",A)) S BGPZ(V)=1
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..I $$ICD^BGP8UTL2(A,$O(^ATXAX("B","BGP CPT DENTAL SSC",0)),1) S BGPZ(V)=1
I 'BGPGA Q ""
S BGPGASSC=0,X=0 F S X=$O(BGPZ(X)) Q:X'=+X I BGPZ(X) S BGPGASSC=BGPGASSC+1
S Z="",X=0 F S X=$O(BGPZ(X)) Q:X'=+X S:Z]"" Z=Z_"; " S Z=Z_$$DATE^BGP8UTL($$VD^APCLV(X))_": GEN ANESTH"_$S(BGPZ(X):", SSC",1:"")
Q BGPGA_U_BGPGASSC_U_Z
BGP8D3A ;IHS/CMI/LAB - MEASURE LOGIC;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
SEALDEV(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPX,BGPC,%,X,V,T
+2 SET BGPC=0
+3 KILL BGPG
+4 SET %=P_"^ALL ADA 0007;DURING "_$$DATE^BGP8UTL(BDATE)_"-"_$$DATE^BGP8UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+5 SET %=""
SET X=0
+6 FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
SET %=1_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U,1))_" RPMS DENTAL 0007"
+7 QUIT %
TF(P,BDATE,EDATE) ;EP
+1 NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
+2 KILL BGPG,BGPZ
SET BGPC=0
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET Z=$ORDER(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+7 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPC>3)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+8 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y!(G>0)!($PIECE(BGPC,U,1)>3)
QUIT
Begin DoDot:2
+9 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
Begin DoDot:3
+10 IF $DATA(^ATXAX(Z,21,"B",A))
SET T=1
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=G+1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3))_"|RPMS DENTAL "_$$VAL^XBDIQ1(9000010.05,Y,.01)
+11 QUIT
End DoDot:3
End DoDot:2
+12 IF G
QUIT
+13 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+14 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+15 IF 'A
QUIT
+16 ;one per visit
IF $$ICD^BGP8UTL2(A,$ORDER(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1)
SET T=1
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=G+1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVCPT(Y,0),U,3))_"|CDT "_$$VAL^XBDIQ1(9000010.18,Y,.01)
End DoDot:2
+17 ;one per visit
IF G
QUIT
+18 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVTC("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+19 IF '$DATA(^AUPNVTC(Y,0))
QUIT
+20 SET I=$PIECE(^AUPNVTC(Y,0),U,7)
+21 IF I=""
QUIT
+22 ;one per visit
IF $$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1)
SET T=1
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=G+1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVTC(Y,0),U,3))_"|CDT/TRAN "_$$VAL^XBDIQ1(9000010.33,Y,.07)
End DoDot:2
+23 IF G
QUIT
+24 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+25 SET A=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF A
Begin DoDot:3
+26 ;one per visit
IF $$ICD^BGP8UTL2(A,$ORDER(^ATXAX("B","BGP TOPICAL FLUORIDE DXS",0)),9)
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVPOV(Y,0),U,3))_"|POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)
+27 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF BGPC
QUIT BGPC
+29 QUIT ""
SEAL(P,BDATE,EDATE) ;EP
+1 NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,BGPCNT
+2 KILL BGPG,BGPX
+3 SET BGPCNT=0
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
+6 SET BGPC=0
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
IF A
SET A=$PIECE($GET(^AUTTADA(A,0)),U)
Begin DoDot:3
+11 IF A'=1351
IF A'=1352
QUIT
+12 SET G=1
+13 SET T=$PIECE($GET(^AUPNVDEN(Y,0)),U,4)
IF T=""!(T=0)
SET T=1
+14 SET S=$PIECE(^AUPNVDEN(Y,0),U,5)
+15 IF S]""
Begin DoDot:4
+16 IF $GET(BGPX(S))<2
Begin DoDot:5
+17 IF T=1
SET BGPX(S)=$GET(BGPX(S))+T
+18 ;only first 2 per tooth
IF T'=1
SET T=$SELECT(T>(2-$GET(BGPX(S))):(2-$GET(BGPX(S))),1:T)
SET BGPX(S)=$GET(BGPX(S))+T
+19 SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL "_A_" ("_T_")"
End DoDot:5
End DoDot:4
+20 IF S=""
SET BGPX("NO OS")=$GET(BGPX("NO OS"))+T
SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL "_A_"("_T_")"
+21 QUIT
End DoDot:3
End DoDot:2
+22 ;had ADA1351/1352 codes so skip cpts/0007
IF G
QUIT
+23 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+24 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+25 IF 'A
QUIT
+26 SET A=$PIECE($$CPT^ICPTCOD(A),U,2)
IF A="D1351"
Begin DoDot:3
+27 SET T=$PIECE($GET(^AUPNVCPT(Y,0)),U,16)
IF T=""!(T=0)
SET T=1
+28 SET BGPX("CPT")=$GET(BGPX("CPT"))+T
SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVCPT(Y,0),U,3)))="CDT D1351 ("_T_")"
End DoDot:3
End DoDot:2
End DoDot:1
+29 SET X=""
FOR
SET X=$ORDER(BGPX(X))
IF X=""
QUIT
IF X'="CPT"
SET BGPC=BGPC+$SELECT(BGPX(X)>2:2,1:BGPX(X))
+30 SET BGPC=BGPC+$GET(BGPX("CPT"))
+31 SET BGPSEAL=BGPC
+32 QUIT
SEALR(P,BDATE,EDATE) ;EP
+1 NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,BGPCNT
+2 KILL BGPG,BGPX
+3 SET BGPCNT=0
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
+6 SET BGPC=0
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
IF A
SET A=$PIECE($GET(^AUTTADA(A,0)),U)
Begin DoDot:3
+11 IF A'=1353
QUIT
+12 SET G=1
+13 ;$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1 DOESN'T MATTER HOW MANY, WE ARE ONLY COUNTING 1 PER TOOTH
SET T=1
+14 SET S=$PIECE(^AUPNVDEN(Y,0),U,5)
+15 IF S]""
Begin DoDot:4
+16 IF $GET(BGPX(S))<1
Begin DoDot:5
+17 SET BGPX(S)=$GET(BGPX(S))+1
+18 SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL "_A_" ("_T_")"
End DoDot:5
End DoDot:4
+19 IF S=""
SET BGPX("NO OS")=$GET(BGPX("NO OS"))+T
SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3)))="RPMS DENTAL 1353 ("_T_")"
+20 QUIT
End DoDot:3
End DoDot:2
+21 ;had ADA1353 SO SKIP CPTS
IF G
QUIT
+22 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+23 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+24 IF 'A
QUIT
+25 SET A=$PIECE($$CPT^ICPTCOD(A),U,2)
IF A="D1353"
Begin DoDot:3
+26 SET T=$PIECE($GET(^AUPNVCPT(Y,0)),U,16)
IF T=""!(T=0)
SET T=1
+27 SET BGPX("CPT")=$GET(BGPX("CPT"))+T
SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVCPT(Y,0),U,3)))="CDT D1353 ("_T_")"
End DoDot:3
End DoDot:2
End DoDot:1
+28 SET X=""
FOR
SET X=$ORDER(BGPX(X))
IF X=""
QUIT
IF X'="CPT"
SET BGPC=BGPC+$SELECT(BGPX(X)>1:1,1:BGPX(X))
+29 SET BGPC=BGPC+$GET(BGPX("CPT"))
+30 SET BGPSEALR=BGPC
+31 QUIT
HIGHR(P,EDATE) ;EP
+1 ;must have 2 dx in past 3 years, then check problem list before EDATE
+2 NEW BGPG,Y,X,G,V,BDATE,C,D
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
+4 SET Y="BGPG("
SET G=""
SET C=0
+5 SET X=P_"^ALL DX [BGP HIGH RISK FLU DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
GOTO HRPL
+7 KILL Y
SET X=0
SET G=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET D=$PIECE(BGPG(X),U,1)
+9 ;already had one on that day
IF $DATA(Y(D))
QUIT
+10 SET Y(D)=""
+11 SET C=C+1
+12 IF C>1
SET G=1
End DoDot:1
+13 IF G
QUIT G
HRPL ;
+1 SET G=""
+2 SET T=$ORDER(^ATXAX("B","BGP HIGH RISK FLU DXS",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+5 ;if added to pl after beginning of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+6 SET Y=$PIECE(^AUPNPROB(X,0),U)
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+10 SET G=1
+11 QUIT
End DoDot:1
+12 QUIT G
DTAP(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM,D
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPVARI
+4 ;get all immunizations
+5 ;S C="115"
+6 ;D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)
+7 SET BGPX=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"IMMUNIZATION",115)
+8 IF BGPX
SET BGPX=$PIECE(BGPX,U,2)_U_$$DATE^BGP8UTL($PIECE(BGPX,U,2))_" Imm 115"
+9 ;go through and set into array if 10 days apart
+10 ;now add in LAST cpt codes if on different dates
+11 SET C=+$$CODEN^ICPTCOD(90715)
+12 SET D=$$CPTI^BGP8DU(P,BDATE,EDATE,C)
+13 IF $PIECE(D,U,2)>$PIECE(BGPX,U,1)
SET BGPX=$PIECE(D,U,2)_U_$$DATE^BGP8UTL($PIECE(D,U,2))_" CPT 90715"
+14 IF BGPX
QUIT 1_U_$PIECE(BGPX,U,2)
+15 ;I $D(BGPVARI) Q 1_U_$$DATE^BGP8UTL($O(BGPVARI(9999999),-1))_" CPT 90715"
+16 FOR BGPZ=115
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
+17 IF X]""
QUIT 2_U_$$DATE^BGP8UTL($PIECE(X,U,1))_" "_$PIECE(X,U,2)
+18 ;now go to Refusals
+19 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+20 FOR BGPIMM=115
Begin DoDot:1
+21 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+22 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
Begin DoDot:2
+23 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+24 ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
SET R=D
End DoDot:2
End DoDot:1
+25 IF R
QUIT 2_U_$$DATE^BGP8UTL(R)_" "_"NMI Dtap"
+26 SET R=""
SET B=+$$CODEN^ICPTCOD(90715)
+27 SET G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
+28 IF G
QUIT 2_U_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_"NMI Dtap 90715"
+29 QUIT ""
DTAPTD(P,BDATE,EDATE) ;EP
+1 NEW BDM,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,TK,BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM,T
+2 KILL TDD
+3 ;get td from v imm
DO LASTTDN
+4 SET LTD=$ORDER(TDD(0))
+5 IF LTD]""
SET LTD=(9999999-LTD)_U_$$DATE^BGP8UTL(9999999-LTD)_" Imm "_TDD(LTD)
+6 ;now check cpt codes
+7 SET T=$ORDER(^ATXAX("B","BGP CPT TDAP/TD",0))
+8 SET BGPVARI=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
+9 IF $PIECE(BGPVARI,U,1)>$PIECE(LTD,U,1)
SET LTD=$PIECE(BGPVARI,U,1)_U_$$DATE^BGP8UTL($PIECE(BGPVARI,U,1))_" CPT "_$PIECE(BGPVARI,U,2)
+10 KILL BGPG
SET %=P_"^LAST DX [BGP TD IZ DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+11 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U,1)>$PIECE(LTD,U,1)
SET LTD=$PIECE(BGPG(1),U,1)_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_" DX V06.5"
+12 IF LTD
QUIT 1_U_$PIECE(LTD,U,2)
+13 FOR BGPZ=115,9,113,138,139
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+14 IF X]""
QUIT 2_U_$$DATE^BGP8UTL($PIECE(X,U,1))_" "_$PIECE(X,U,2)
+15 ;now go to Refusals
+16 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+17 FOR BGPIMM=115,9,113,138,139
Begin DoDot:1
+18 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+19 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
Begin DoDot:2
+20 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+21 ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
SET R=D
End DoDot:2
End DoDot:1
+22 IF R
QUIT 2_U_$$DATE^BGP8UTL(R)_" NMI Dtap/Td"
+23 SET R=""
SET B=+$$CODEN^ICPTCOD(90715)
+24 SET G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
+25 IF G
QUIT 2_U_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_"NMI Dtap 90715"
+26 SET R=""
SET B=+$$CODEN^ICPTCOD(90714)
+27 SET G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
+28 IF G
QUIT 2_U_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_"NMI Dtap 90714"
+29 SET R=""
SET B=+$$CODEN^ICPTCOD(90718)
+30 SET G=$$NMIREF^BGP8UTL1(P,81,B,$$DOB^AUPNPAT(P),EDATE)
+31 IF G
QUIT 2_U_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_"NMI Dtap 90718"
+32 QUIT ""
+33 ;
LASTTDN ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^AUPNVIMM(X,0),U)
IF 'Y
QUIT
+3 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+4 SET Y=$PIECE(^AUTTIMM(Y,0),U,3)
+5 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
IF 'D
QUIT
+6 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+7 ;too early
IF D<BDATE
QUIT
+8 ;after time frame
IF D>EDATE
QUIT
+9 IF Y=9
SET TDD(9999999-D)=9
QUIT
+10 IF Y=113
SET TDD(9999999-D)=113
QUIT
+11 IF Y=115
SET TDD(9999999-D)=115
QUIT
+12 IF Y=138
SET TDD(9999999-D)=138
QUIT
+13 IF Y=139
SET TDD(9999999-D)=139
QUIT
End DoDot:1
+14 QUIT
+15 ;;
HIGHRP(P,EDATE) ;EP
+1 ;must have 2 dx in past 3 years, then check problem list before EDATE
+2 NEW BGPG,Y,X,G,V,BDATE,C,D
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
+4 SET Y="BGPG("
SET G=""
SET C=0
+5 SET X=P_"^ALL DX [BGP HIGH RISK PNEUMO DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
GOTO HRPL
+7 KILL Y
SET X=0
SET G=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET D=$PIECE(BGPG(X),U,1)
+9 ;already had one on that day
IF $DATA(Y(D))
QUIT
+10 SET Y(D)=""
+11 SET C=C+1
+12 IF C>1
SET G=1
End DoDot:1
+13 IF G
QUIT G
HRPLP ;
+1 SET G=""
+2 SET T=$ORDER(^ATXAX("B","BGP HIGH RISK PNEUMO DXS",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+5 ;if added to pl after beginning of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+6 SET Y=$PIECE(^AUPNPROB(X,0),U)
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+10 SET G=1
+11 QUIT
End DoDot:1
+12 QUIT G
GA(P,BDATE,EDATE) ;EP
+1 NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R,BGPC,BGPGA,BGPGASSC
+2 KILL BGPG,BGPZ
SET BGPC=0
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET Z=$ORDER(^ATXAX("B","BGP GEN ANESTHESIA ADA CODES",0))
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+7 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+8 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+9 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
Begin DoDot:3
+10 IF $DATA(^ATXAX(Z,21,"B",A))
SET BGPZ(V)=""
End DoDot:3
End DoDot:2
+11 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+12 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+13 IF 'A
QUIT
+14 IF $$ICD^BGP8UTL2(A,$ORDER(^ATXAX("B","BGP CPT DENT GEN ANESTHESIA",0)),1)
SET BGPZ(V)=""
End DoDot:2
End DoDot:1
+15 ;ARRAY BGPZ has all visits with general anesthesia
+16 SET BGPGA=0
SET X=0
FOR
SET X=$ORDER(BGPZ(X))
IF X'=+X
QUIT
SET BGPGA=BGPGA+1
+17 ;LOOP THROUGH THESES VISITS AND SEE IF THEY HAVE A SSC
+18 SET Z=$ORDER(^ATXAX("B","BGP SSC ADA CODES",0))
+19 SET V=0
FOR
SET V=$ORDER(BGPZ(V))
IF V'=+V
QUIT
Begin DoDot:1
+20 SET Y=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+21 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
Begin DoDot:3
+22 IF $DATA(^ATXAX(Z,21,"B",A))
SET BGPZ(V)=1
End DoDot:3
End DoDot:2
+23 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+24 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+25 IF 'A
QUIT
+26 IF $$ICD^BGP8UTL2(A,$ORDER(^ATXAX("B","BGP CPT DENTAL SSC",0)),1)
SET BGPZ(V)=1
End DoDot:2
End DoDot:1
+27 IF 'BGPGA
QUIT ""
+28 SET BGPGASSC=0
SET X=0
FOR
SET X=$ORDER(BGPZ(X))
IF X'=+X
QUIT
IF BGPZ(X)
SET BGPGASSC=BGPGASSC+1
+29 SET Z=""
SET X=0
FOR
SET X=$ORDER(BGPZ(X))
IF X'=+X
QUIT
IF Z]""
SET Z=Z_"; "
SET Z=Z_$$DATE^BGP8UTL($$VD^APCLV(X))_": GEN ANESTH"_$SELECT(BGPZ(X):", SSC",1:"")
+30 QUIT BGPGA_U_BGPGASSC_U_Z
