BGP8D3C ; IHS/CMI/LAB - VARIOUS UTILS ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
FIRSTPDX(P,BDATE,EDATE) ;EP
NEW BGPG,G,Y,X,T,E,BGPR
K BGPG
S Y="BGPG("
S BDATE=$G(BDATE)
I BDATE="" S BDATE=$P(^DPT(P,0),U,3)
S BGPR=""
S X=P_"^FIRST DX [BGP PREGNANCY DIAGNOSES 2;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) S BGPR=$P(BGPG(1),U)
K BGPG
S BGPG=$$FIRSTPRC^BGP8UTL1(P,"BGP PREGNANCY ICD PROCEDURES",BDATE,EDATE)
I BGPG]"",$P(BGPG,U,3)<BGPR S BGPR=$P(BGPG,U,3)
S X=$$FIRSTCPT^BGP8UTL1(P,"BGP PREGNANCY CPT CODES",BDATE,EDATE)
I X,$P(X,U,1)<BGPR S BGPR=$P(X,U,1)
Q BGPR
LASTVD(P,BDATE,EDATE) ;EP
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW VISIT
S A="VISIT(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(VISIT(1)) Q ""
S (X,G)=0 F S X=$O(VISIT(X)) Q:X'=+X!(G) S V=$P(VISIT(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S G=1
.Q
Q G
IZOSTER(P,BDATE,EDATE,FORE) ;EP
NEW BGPLPNU,BGPG,X,E,R,BD,ED,G,%,BGPX,BGPSHIN,RED,RBD
S BGPLPNU=""
S BD=BDATE
S ED=EDATE
S EDATE=$$FMTE^XLFDT(EDATE)
S BDATE=$$FMTE^XLFDT(BDATE)
S X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 121"
S X=P_"^LAST IMM 188;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 188"
S %=$$CPT^BGP8DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
S %=$$TRAN^BGP8DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
I BGPLPNU]"" Q BGPLPNU_U_1
;
K BGPSHIN,BGPX
;get all immunizations
S C="187"
D GETIMMS^BGP7D32(P,ED,C,.BGPX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPSHIN(X)=""
;now get cpts
S RED=9999999-ED,RBD=9999999-$$DOB^AUPNPAT(P),G=0
F S RED=$O(^AUPNVSIT("AA",P,RED)) Q:RED=""!($P(RED,".")>RBD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,RED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U) I $$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),1) S BGPSHIN(9999999-$P(RED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) I $$ICD^BGP8UTL2(Y,$O(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),1) S BGPSHIN(9999999-$P(RED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPSHIN(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPSHIN(X) Q
.S Y=X
;now count them and see if there are 2 of them
S BGPSHIN=0,X=0 F S X=$O(BGPSHIN(X)) Q:X'=+X S BGPSHIN=BGPSHIN+1
I BGPSHIN>1 Q U_"2 Zoster/Shingrix"_U_1
;CONTRA
;
F BGPZ=121,188,187 S X=$$ANIMCONT^BGP8D31(P,BGPZ,ED) Q:X]""
I X]"" Q X_U_3
;NMI
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",188,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",187,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),"N")
I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),"N")
I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
Q ""
;
PPSV23(P,BDATE,EDATE,FORE) ;EP
NEW BGPG,T1,BGPLPNU,I,X,CVX,T,D,BGPZ,G,B
K BGPG
S BGPLPNU=""
S T1=$O(^ATXAX("B","BGP PPSV23 CVX CODES",0))
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNVIMM(X,0)),U,1)
.I 'I Q
.S CVX=$P($G(^AUTTIMM(I,0)),U,3)
.Q:CVX=""
.I '$D(^ATXAX(T1,21,"B",CVX)) Q ;NOT IN TAXONOMY
.S D=$P($$VALI^XBDIQ1(9000010.11,X,1201),".")
.I D="" S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
.Q:D<BDATE
.Q:D>EDATE
.I $P(BGPLPNU,U,1)<D S BGPLPNU=D_U_"Imm "_CVX
K BGPG S %=P_"^LAST DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"POV "_$P(BGPG(1),U,2)
S %=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PPSV23 CPT CODES",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
S %=$$TRAN^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PPSV23 CPT CODES",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
I BGPLPNU]"" Q BGPLPNU_U_1
Q ""
PCV13(P,BDATE,EDATE,FORE) ;EP
NEW BGPG,T1,BGPLPNU,I,X,CVX,T,D,BGPZ,G,B
K BGPG
S BGPLPNU=""
S T1=$O(^ATXAX("B","BGP PCV13 CVX CODES",0))
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNVIMM(X,0)),U,1)
.I 'I Q
.S CVX=$P($G(^AUTTIMM(I,0)),U,3)
.Q:CVX=""
.I '$D(^ATXAX(T1,21,"B",CVX)) Q ;NOT IN TAXONOMY
.S D=$P($$VALI^XBDIQ1(9000010.11,X,1201),".")
.I D="" S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
.Q:D<BDATE
.Q:D>EDATE
.I $P(BGPLPNU,U,1)<D S BGPLPNU=D_U_"Imm "_CVX
S %=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
S %=$$TRAN^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
I BGPLPNU]"" Q BGPLPNU_U_1
Q ""
BGP8D3C ; IHS/CMI/LAB - VARIOUS UTILS ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
FIRSTPDX(P,BDATE,EDATE) ;EP
+1 NEW BGPG,G,Y,X,T,E,BGPR
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET BDATE=$GET(BDATE)
+5 IF BDATE=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 SET BGPR=""
+7 SET X=P_"^FIRST DX [BGP PREGNANCY DIAGNOSES 2;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+8 IF $DATA(BGPG(1))
SET BGPR=$PIECE(BGPG(1),U)
+9 KILL BGPG
+10 SET BGPG=$$FIRSTPRC^BGP8UTL1(P,"BGP PREGNANCY ICD PROCEDURES",BDATE,EDATE)
+11 IF BGPG]""
IF $PIECE(BGPG,U,3)<BGPR
SET BGPR=$PIECE(BGPG,U,3)
+12 SET X=$$FIRSTCPT^BGP8UTL1(P,"BGP PREGNANCY CPT CODES",BDATE,EDATE)
+13 IF X
IF $PIECE(X,U,1)<BGPR
SET BGPR=$PIECE(X,U,1)
+14 QUIT BGPR
LASTVD(P,BDATE,EDATE) ;EP
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 NEW VISIT
+3 SET A="VISIT("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(VISIT(1))
QUIT ""
+5 SET (X,G)=0
FOR
SET X=$ORDER(VISIT(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(VISIT(X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+10 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+11 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 QUIT G
IZOSTER(P,BDATE,EDATE,FORE) ;EP
+1 NEW BGPLPNU,BGPG,X,E,R,BD,ED,G,%,BGPX,BGPSHIN,RED,RBD
+2 SET BGPLPNU=""
+3 SET BD=BDATE
+4 SET ED=EDATE
+5 SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
+7 SET X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 121"
+9 SET X=P_"^LAST IMM 188;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+10 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"Imm 188"
+11 SET %=$$CPT^BGP8DU(P,BD,ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
+12 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+13 SET %=$$TRAN^BGP8DU(P,BD,ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
+14 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+15 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+16 ;
+17 KILL BGPSHIN,BGPX
+18 ;get all immunizations
+19 SET C="187"
+20 DO GETIMMS^BGP7D32(P,ED,C,.BGPX)
+21 ;go through and set into array if 10 days apart
+22 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPSHIN(X)=""
+23 ;now get cpts
+24 SET RED=9999999-ED
SET RBD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+25 FOR
SET RED=$ORDER(^AUPNVSIT("AA",P,RED))
IF RED=""!($PIECE(RED,".")>RBD)
QUIT
Begin DoDot:1
+26 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,RED,V))
IF V'=+V
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+29 SET Y=$PIECE(^AUPNVCPT(X,0),U)
IF $$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),1)
SET BGPSHIN(9999999-$PIECE(RED,"."))=""
End DoDot:3
+30 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+31 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF $$ICD^BGP8UTL2(Y,$ORDER(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),1)
SET BGPSHIN(9999999-$PIECE(RED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+33 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPSHIN(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+34 IF C=1
SET Y=X
QUIT
+35 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPSHIN(X)
QUIT
+36 SET Y=X
End DoDot:1
+37 ;now count them and see if there are 2 of them
+38 SET BGPSHIN=0
SET X=0
FOR
SET X=$ORDER(BGPSHIN(X))
IF X'=+X
QUIT
SET BGPSHIN=BGPSHIN+1
+39 IF BGPSHIN>1
QUIT U_"2 Zoster/Shingrix"_U_1
+40 ;CONTRA
+41 ;
+42 FOR BGPZ=121,188,187
SET X=$$ANIMCONT^BGP8D31(P,BGPZ,ED)
IF X]""
QUIT
+43 IF X]""
QUIT X_U_3
+44 ;NMI
+45 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
+46 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+47 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",188,0)),$$DOB^AUPNPAT(P),ED)
+48 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+49 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",187,0)),$$DOB^AUPNPAT(P),ED)
+50 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+51 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),"N")
+52 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+53 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),"N")
+54 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+55 QUIT ""
+56 ;
PPSV23(P,BDATE,EDATE,FORE) ;EP
+1 NEW BGPG,T1,BGPLPNU,I,X,CVX,T,D,BGPZ,G,B
+2 KILL BGPG
+3 SET BGPLPNU=""
+4 SET T1=$ORDER(^ATXAX("B","BGP PPSV23 CVX CODES",0))
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET I=$PIECE($GET(^AUPNVIMM(X,0)),U,1)
+7 IF 'I
QUIT
+8 SET CVX=$PIECE($GET(^AUTTIMM(I,0)),U,3)
+9 IF CVX=""
QUIT
+10 ;NOT IN TAXONOMY
IF '$DATA(^ATXAX(T1,21,"B",CVX))
QUIT
+11 SET D=$PIECE($$VALI^XBDIQ1(9000010.11,X,1201),".")
+12 IF D=""
SET D=$$VD^APCLV($PIECE(^AUPNVIMM(X,0),U,3))
+13 IF D<BDATE
QUIT
+14 IF D>EDATE
QUIT
+15 IF $PIECE(BGPLPNU,U,1)<D
SET BGPLPNU=D_U_"Imm "_CVX
End DoDot:1
+16 KILL BGPG
SET %=P_"^LAST DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+17 IF $DATA(BGPG(1))
IF $PIECE(BGPLPNU,U,1)<$PIECE(BGPG(1),U)
SET BGPLPNU=$PIECE(BGPG(1),U,1)_U_"POV "_$PIECE(BGPG(1),U,2)
+18 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP PPSV23 CPT CODES",0)),5)
+19 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+20 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP PPSV23 CPT CODES",0)),5)
+21 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+22 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+23 QUIT ""
PCV13(P,BDATE,EDATE,FORE) ;EP
+1 NEW BGPG,T1,BGPLPNU,I,X,CVX,T,D,BGPZ,G,B
+2 KILL BGPG
+3 SET BGPLPNU=""
+4 SET T1=$ORDER(^ATXAX("B","BGP PCV13 CVX CODES",0))
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET I=$PIECE($GET(^AUPNVIMM(X,0)),U,1)
+7 IF 'I
QUIT
+8 SET CVX=$PIECE($GET(^AUTTIMM(I,0)),U,3)
+9 IF CVX=""
QUIT
+10 ;NOT IN TAXONOMY
IF '$DATA(^ATXAX(T1,21,"B",CVX))
QUIT
+11 SET D=$PIECE($$VALI^XBDIQ1(9000010.11,X,1201),".")
+12 IF D=""
SET D=$$VD^APCLV($PIECE(^AUPNVIMM(X,0),U,3))
+13 IF D<BDATE
QUIT
+14 IF D>EDATE
QUIT
+15 IF $PIECE(BGPLPNU,U,1)<D
SET BGPLPNU=D_U_"Imm "_CVX
End DoDot:1
+16 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
+17 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+18 SET %=$$TRAN^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
+19 IF $PIECE(BGPLPNU,U,1)<$PIECE(%,U,1)
SET BGPLPNU=$PIECE(%,U,1)_U_"CPT "_$PIECE(%,U,2)
+20 IF BGPLPNU]""
QUIT BGPLPNU_U_1
+21 QUIT ""
