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

BUD1RP6W.m

Go to the documentation of this file. 
  1. BUD1RP6W ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2011 4:03 PM ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1.  ;
  1.  ;
  1. ROTACONT(P,C,ED) ;EP - ANALPHYLAXIS/IMMUNE DEF
  1.  NEW X
  1.  S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:D=""
  1.  .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
  1.  .I $P(^BICONT(R,0),U,1)["Immune" S G=D_U_$P(^BICONT(R,0),U,1)
  1.  .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
  1.  Q G
  1. ROTA(P,BDATE,EDATE) ;EP
  1.  ;check for a contraindication from DOB to 2nd birthday
  1.  NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
  1.  ;now check for evidence of disease
  1.  S X=$$LASTDXI^BUD1UTL1(P,"008.61",$$DOB^AUPNPAT(P),EDATE)
  1.  I X]"" Q "1^ROTAVIRUS Evidence: "_$P(X,U,2)_" on "_$$DATE^BUD1UTL1($P(X,U,3))
  1.  S X=$$LASTDX^BUD1UTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
  1.  I X]"" Q "1^ROTAVIRUS Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUD1UTL1($P(X,U,3))
  1.  I $$PLCODE^BUD1DU(P,"008.61") Q "1^ROTAVIRUS Evidence: 008.61 on Problem List"
  1.  S X=$$PLTAX^BUD1DU(P,"BUD ROTA CONTRA DXS") I X Q "1^ROTAVIRUS Contraindication: "_$P(X,U,2)_" on Problem List"
  1.  F BUDZ=119,74,116,122 S X=$$ROTACONT(P,BUDZ,EDATE) Q:X]""
  1.  I X]"" Q "1^ROTAVIRUS Contraindication IM package: "_$$DATE^BUD1UTL1($P(X,U))_" "_$P(X,U,2)
  1.  S G=""
  1.  S X=0 F  S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G)  D
  1.  .;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE  ;entered after 2ND birthday
  1.  .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
  1.  .Q:'$$ANAREACT^BUD1RP6C(X)  ;quit if anaphylactic is not a reaction/sign/symptom
  1.  .I N["NEOMYCIN" S G="1^ROTAVIRUS Contraindiction: "_$$DATE^BUD1UTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_"  Allergy Tracking: "_N
  1.  I G]"" Q G
  1.  ;now get imms and see if there are 3
  1.  K BUDC,BUDG,BUDX
  1.  K BUDOPV,BUDAPOV
  1.  S BUDOPV2=0
  1. ROTAIMM ;get all immunizations
  1.  S C="119"
  1.  K BUDX D GETIMMS^BUD1RP6C(P,BDATE,EDATE,C,.BUDX)
  1.  ;now get cpt codes
  1.  S X=0 F  S X=$O(BUDX(X)) Q:X'=+X  S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
  1.  ;now get cpts
  1.  S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90681 D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,".")))
  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) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90681 D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,".")))
  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(BUDOPV(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 BUDOPV(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 4 of them
  1.  S BUDOPV=0,X=0 F  S X=$O(BUDOPV(X)) Q:X'=+X  S BUDOPV=BUDOPV+1
  1.  I BUDOPV>1 S Y="1^ROTA 2: total #: "_BUDOPV,X="" F  S X=$O(BUDOPV(X)) Q:X'=+X  S Y=Y_"  "_BUDOPV(X)
  1.  I BUDOPV>1 Q Y
  1.  I BUDOPV=1 S BUDOPV2=2
  1.  ;NOW TRY FOR 3 DOSE
  1.  K BUDC,BUDG,BUDX
  1.  K BUDOPV,BUDAPOV
  1. ROT3IMM ;get all immunizations
  1.  S C="74^116^122"
  1.  K BUDX D GETIMMS^BUD1RP6C(P,BDATE,EDATE,C,.BUDX)
  1.  ;now get cpt codes
  1.  S X=0 F  S X=$O(BUDX(X)) Q:X'=+X  S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
  1.  ;now get cpts
  1.  S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90680 D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,".")))
  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) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90680 D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,".")))
  1.  ..S X=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$$VAL^XBDIQ1(9000010.07,X,.01) I Y="008.61" D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="POV: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="POV: "_Y_" on "_$$DATE^BUD1UTL1((9999999-$P(ED,".")))
  1.  S (X,Y)="",C=0 F  S X=$O(BUDOPV(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 BUDOPV(X) Q
  1.  .S Y=X
  1.  ;now count them and see if there are 3 of them
  1.  S BUDOPV=0,X=0 F  S X=$O(BUDOPV(X)) Q:X'=+X  S BUDOPV=BUDOPV+1
  1.  I BUDOPV>2 S Y="1^ROTA: total #: "_BUDOPV,X="" F  S X=$O(BUDOPV(X)) Q:X'=+X  S Y=Y_"  "_BUDOPV(X)
  1.  I BUDOPV>2 Q Y
  1.  S BUDOPV=BUDOPV+BUDOPV2
  1.  I BUDOPV>2 S Y="1^ROTA: total #: "_BUDOPV,X="" F  S X=$O(BUDOPV(X)) Q:X'=+X  S Y=Y_"  "_BUDOPV(X)
  1.  I BUDOPV>2 Q Y
  1.  Q "0^"_(3-BUDOPV)_" ROTAVIRUS"