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

BUD0RP6Y.m

Go to the documentation of this file. 
  1. BUD0RP6Y ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2010 4:03 PM ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1.  ;
  1. HEP(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. HEPCONT ;check allergy tracking
  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^BUD0RP6C(X)  ;quit if anaphylactic is not a reaction/sign/symptom
  1.  .I N["BAKER'S YEAST"!(N["BAKERS YEAST")!(N["YEAST") S G="1^HEP B Contraindiction: "_$$DATE^BUD0UTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_"  Allergy Tracking: "_N
  1.  I G]"" Q G
  1.  ;now check immunization package
  1.  F BUDZ=8,42,43,44,45,51,102,104,110,132 S X=$$ANCONT^BUD0RP6C(P,BUDZ,EDATE) Q:X]""
  1.  I X]"" Q "1^HEP B Contraindication IM package: "_$$DATE^BUD0UTL1($P(X,U))_" "_$P(X,U,2)
  1.  ;now check for evidence of disease
  1. HEPEVID ;
  1.  K BUDG S %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  I $D(BUDG(1)) Q "1^HEP B Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U))
  1.  S X=$$PLTAX^BUD0DU(P,"BGP HEP EVIDENCE") I X Q "1^HEP B Evidence: Problem List "_$P(X,U,2)
  1.  ;now get imms and see if there are 3
  1.  K BUDC,BUDG,BUDX
  1.  K BUDOPV,BUDAPOV
  1. HEPIMM ;get all immunizations
  1.  S C="8^42^43^44^45^51^102^104^110^132"
  1.  K BUDX D GETIMMS^BUD0RP6C(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) D
  1.  ....I Y=90723!(Y=90740)!(Y=90744)!(Y=90747)!(Y=90748) S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((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) D
  1.  ....I Y=90723!(Y=90740)!(Y=90744)!(Y=90747)!(Y=90748) S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((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>2 S Y="1^HEP B: 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)_" HEP B"
  1.  ;
  1. HIB(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.  F BUDZ=17,22,46,47,48,49,50,51,102,120,132 S X=$$ANCONT^BUD0RP6C(P,BUDZ,EDATE) Q:X]""
  1.  I X]"" Q "1^HIB Contraindication IM package: "_$$DATE^BUD0UTL1($P(X,U))_" "_$P(X,U,2)
  1. HIBEVID ;
  1.  K BUDG S %=P_"^LAST DX [BUD HIB EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  I $D(BUDG(1)) Q "1^HIB Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U))
  1.  S X=$$PLTAX^BUD0DU(P,"BUD HIB EVIDENCE") I X Q "1^HIB Evidence: Problem List "_$P(X,U,2)
  1.  ;now get imms and see if there are 3
  1.  K BUDC,BUDG,BUDX
  1.  K BUDOPV,BUDAPOV
  1. HIBIMM ;get all immunizations
  1.  S C="17^22^46^47^48^49^50^51^102^120^132"
  1.  K BUDX D GETIMMS^BUD0RP6C(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=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748) D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((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=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748) D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,".")))
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  ;K BUDG S %=P_"^ALL DX V03.81;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  ;I $D(BUDG(1)) S X=0 F  S X=$O(BUDG(X)) Q:X'=+X  S BUDOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U,1)),BUDAOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U,1))
  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>2 S Y="1^HIB: 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)_" HIB"
  1.  ;
  1. VAR(P,BDATE,EDATE) ;EP
  1.  ;first check for contraindications
  1. VARC ;
  1.  NEW BUDG,%,X,BUDZ,BUDC,BUDX,G,N
  1.  K BUDG S %=P_"^LAST DX [BUD MMR CONTRAINDICATIONS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  I $D(BUDG(1)) Q "1^Varicella CONTRA DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U))
  1.  S X=$$PLTAX^BUD0DU(P,"BUD MMR CONTRAINDICATIONS") I X Q "1^VAR CONTRA DX: "_$P(X,U,2)_" on Problem List"
  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^BUD0RP6C(X)  ;quit if anaphylactic is not a reaction/sign/symptom
  1.  .I N["NEOMYCIN" S G="1^VAR Contraindiction: "_$$DATE^BUD0UTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_"  Allergy Tracking: "_N
  1.  I G]"" Q G
  1.  F BUDZ=21,94 S X=$$MMRCONT^BUD0RP6C(P,BUDZ,EDATE) Q:X]""
  1.  I X]"" Q "1^Varicella Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUD0UTL1($P(X,U,1))_" Immunization Package"
  1. VAREVID ;
  1.  ;any evidence of VAR?
  1.  K BUDG S %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  I $D(BUDG(1)) Q "1^Varicella Evidence: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U))
  1.  S X=$$PLTAX^BUD0DU(P,"BGP VARICELLA EVIDENCE") I X Q "1^Varicella Evidence: Problem List "_$P(X,U,2)
  1. VARI ;
  1.  K BUDC,BUDG,BUDX
  1.  S BUDVAR=""  ;set to null for all
  1.  ;first gather up all cpt codes that relate in any way to dtap and store in ^TMP
  1.  ;get all immunizations
  1.  S C="21^94"
  1.  K BUDX D GETIMMS^BUD0RP6C(P,BDATE,EDATE,C,.BUDX)  ;before 2nd birthday
  1.  I $D(BUDX) S D=$O(BUDX(0)) Q "1^Varicella "_BUDX(D)  ;HAD 1 VAR
  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.  ..Q:'$D(^AUPNVCPT("AD",V))
  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="90710"!(Y="90716") S BUDVAR="Varicella CPT: "_Y_" on "_$$DATE^BUD0UTL1($P($P(^AUPNVSIT(V,0),U),"."))
  1.  I BUDVAR]"" Q "1^"_BUDVAR
  1.  ;
  1.  ;K BUDG S %=P_"^ALL DX V05.4;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  ;I $D(BUDG(1)) Q "Varicella DX: "_$P(BUDG(1),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U))
  1.  Q "0^1 VAR"
  1.  ;
  1. PNEU(P,BDATE,EDATE) ;EP
  1.  NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
  1.  ;now get imms and see if there are 4
  1.  K BUDC,BUDG,BUDX
  1.  F BUDZ=33,100,109,133 S X=$$ANCONT^BUD0RP6C(P,BUDZ,EDATE) Q:X]""
  1.  I X]"" Q "1^Pneumovax Contraindication IM package: "_$$DATE^BUD0UTL1($P(X,U))_" "_$P(X,U,2)
  1.  K BUDOPV,BUDAPOV
  1. PNEUIMM ;get all immunizations
  1.  S C="33^100^109^133"
  1.  K BUDX D GETIMMS^BUD0RP6C(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=90669!(Y=90670) D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((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=90669!(Y=90670) D
  1.  ....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUD0UTL1((9999999-$P(ED,".")))
  1.  ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
  1.  ;K BUDG S %=P_"^ALL DX V06.6;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  ;I $D(BUDG(1)) S X=0 F  S X=$O(BUDG(X)) Q:X'=+X  S BUDOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U,1)),BUDAOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U,1))
  1.  ;K BUDG S %=P_"^ALL DX V03.82;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  ;I $D(BUDG(1)) S X=0 F  S X=$O(BUDG(X)) Q:X'=+X  S BUDOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U,1)),BUDAOPV($P(BUDG(X),U))="POV: "_$P(BUDG(X),U,2)_" on "_$$DATE^BUD0UTL1($P(BUDG(1),U,1))
  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>3 S Y="1^Pneumovax: total #: "_BUDOPV,X="" F  S X=$O(BUDOPV(X)) Q:X'=+X  S Y=Y_"  "_BUDOPV(X)
  1.  I BUDOPV>3 Q Y
  1.  NEW X
  1.  S X=4-BUDOPV
  1.  Q "0^"_X_" PNEUMO"
  1.  ;