Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8D3C

BGP8D3C.m

Go to the documentation of this file.
  1. BGP8D3C ; IHS/CMI/LAB - VARIOUS UTILS ;
  1. ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1. ;
  1. FIRSTPDX(P,BDATE,EDATE) ;EP
  1. NEW BGPG,G,Y,X,T,E,BGPR
  1. K BGPG
  1. S Y="BGPG("
  1. S BDATE=$G(BDATE)
  1. I BDATE="" S BDATE=$P(^DPT(P,0),U,3)
  1. S BGPR=""
  1. S X=P_"^FIRST DX [BGP PREGNANCY DIAGNOSES 2;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) S BGPR=$P(BGPG(1),U)
  1. K BGPG
  1. S BGPG=$$FIRSTPRC^BGP8UTL1(P,"BGP PREGNANCY ICD PROCEDURES",BDATE,EDATE)
  1. I BGPG]"",$P(BGPG,U,3)<BGPR S BGPR=$P(BGPG,U,3)
  1. S X=$$FIRSTCPT^BGP8UTL1(P,"BGP PREGNANCY CPT CODES",BDATE,EDATE)
  1. I X,$P(X,U,1)<BGPR S BGPR=$P(X,U,1)
  1. Q BGPR
  1. LASTVD(P,BDATE,EDATE) ;EP
  1. I '$D(^AUPNVSIT("AC",P)) Q ""
  1. NEW VISIT
  1. S A="VISIT(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1. I '$D(VISIT(1)) Q ""
  1. S (X,G)=0 F S X=$O(VISIT(X)) Q:X'=+X!(G) S V=$P(VISIT(X),U,5) D
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:'$P(^AUPNVSIT(V,0),U,9)
  1. .Q:$P(^AUPNVSIT(V,0),U,11)
  1. .Q:'$D(^AUPNVPRV("AD",V))
  1. .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1. .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1. .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1. .S G=1
  1. .Q
  1. Q G
  1. IZOSTER(P,BDATE,EDATE,FORE) ;EP
  1. NEW BGPLPNU,BGPG,X,E,R,BD,ED,G,%,BGPX,BGPSHIN,RED,RBD
  1. S BGPLPNU=""
  1. S BD=BDATE
  1. S ED=EDATE
  1. S EDATE=$$FMTE^XLFDT(EDATE)
  1. S BDATE=$$FMTE^XLFDT(BDATE)
  1. S X=P_"^LAST IMM 121;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
  1. I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 121"
  1. S X=P_"^LAST IMM 188;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
  1. I $D(BGPG(1)),$P(BGPLPNU,U,1)<$P(BGPG(1),U) S BGPLPNU=$P(BGPG(1),U,1)_U_"Imm 188"
  1. S %=$$CPT^BGP8DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. S %=$$TRAN^BGP8DU(P,BD,ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. I BGPLPNU]"" Q BGPLPNU_U_1
  1. ;
  1. K BGPSHIN,BGPX
  1. ;get all immunizations
  1. S C="187"
  1. D GETIMMS^BGP7D32(P,ED,C,.BGPX)
  1. ;go through and set into array if 10 days apart
  1. S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPSHIN(X)=""
  1. ;now get cpts
  1. S RED=9999999-ED,RBD=9999999-$$DOB^AUPNPAT(P),G=0
  1. F S RED=$O(^AUPNVSIT("AA",P,RED)) Q:RED=""!($P(RED,".")>RBD) D
  1. .S V=0 F S V=$O(^AUPNVSIT("AA",P,RED,V)) Q:V'=+V D
  1. ..Q:'$D(^AUPNVSIT(V,0))
  1. ..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
  1. ...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,"."))=""
  1. ..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
  1. ...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,"."))=""
  1. ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1. S X="",Y="",C=0 F S X=$O(BGPSHIN(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<11 K BGPSHIN(X) Q
  1. .S Y=X
  1. ;now count them and see if there are 2 of them
  1. S BGPSHIN=0,X=0 F S X=$O(BGPSHIN(X)) Q:X'=+X S BGPSHIN=BGPSHIN+1
  1. I BGPSHIN>1 Q U_"2 Zoster/Shingrix"_U_1
  1. ;CONTRA
  1. ;
  1. F BGPZ=121,188,187 S X=$$ANIMCONT^BGP8D31(P,BGPZ,ED) Q:X]""
  1. I X]"" Q X_U_3
  1. ;NMI
  1. S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",121,0)),$$DOB^AUPNPAT(P),ED)
  1. I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
  1. S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",188,0)),$$DOB^AUPNPAT(P),ED)
  1. I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
  1. S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",187,0)),$$DOB^AUPNPAT(P),ED)
  1. I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
  1. S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP ZOSTER IZ CPTS",0)),"N")
  1. I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
  1. S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP ZOSTER SHINGRIX CPTS",0)),"N")
  1. I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
  1. Q ""
  1. ;
  1. PPSV23(P,BDATE,EDATE,FORE) ;EP
  1. NEW BGPG,T1,BGPLPNU,I,X,CVX,T,D,BGPZ,G,B
  1. K BGPG
  1. S BGPLPNU=""
  1. S T1=$O(^ATXAX("B","BGP PPSV23 CVX CODES",0))
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S I=$P($G(^AUPNVIMM(X,0)),U,1)
  1. .I 'I Q
  1. .S CVX=$P($G(^AUTTIMM(I,0)),U,3)
  1. .Q:CVX=""
  1. .I '$D(^ATXAX(T1,21,"B",CVX)) Q ;NOT IN TAXONOMY
  1. .S D=$P($$VALI^XBDIQ1(9000010.11,X,1201),".")
  1. .I D="" S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .I $P(BGPLPNU,U,1)<D S BGPLPNU=D_U_"Imm "_CVX
  1. K BGPG S %=P_"^LAST DX [BGP PNEUMO IZ DXS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1. 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)
  1. S %=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PPSV23 CPT CODES",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. S %=$$TRAN^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PPSV23 CPT CODES",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. I BGPLPNU]"" Q BGPLPNU_U_1
  1. Q ""
  1. PCV13(P,BDATE,EDATE,FORE) ;EP
  1. NEW BGPG,T1,BGPLPNU,I,X,CVX,T,D,BGPZ,G,B
  1. K BGPG
  1. S BGPLPNU=""
  1. S T1=$O(^ATXAX("B","BGP PCV13 CVX CODES",0))
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S I=$P($G(^AUPNVIMM(X,0)),U,1)
  1. .I 'I Q
  1. .S CVX=$P($G(^AUTTIMM(I,0)),U,3)
  1. .Q:CVX=""
  1. .I '$D(^ATXAX(T1,21,"B",CVX)) Q ;NOT IN TAXONOMY
  1. .S D=$P($$VALI^XBDIQ1(9000010.11,X,1201),".")
  1. .I D="" S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .I $P(BGPLPNU,U,1)<D S BGPLPNU=D_U_"Imm "_CVX
  1. S %=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. S %=$$TRAN^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP PNEUMO CONJUGATE CPTS",0)),5)
  1. I $P(BGPLPNU,U,1)<$P(%,U,1) S BGPLPNU=$P(%,U,1)_U_"CPT "_$P(%,U,2)
  1. I BGPLPNU]"" Q BGPLPNU_U_1
  1. Q ""