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 ""