BUDARP6W ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 4:03 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
;
;
ROTACONT(P,C,ED) ;EP - ANALPHYLAXIS/IMMUNE DEF
NEW X
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
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"
.I $P(^BICONT(R,0),U,1)["Immune" S G=D_U_$P(^BICONT(R,0),U,1)
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"
Q G
ROTA(P,BDATE,EDATE) ;EP
;check for a contraindication from DOB to 2nd birthday
NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
;now check for evidence of disease
S X=$$LASTDXI^BUDAUTL1(P,"008.61",$$DOB^AUPNPAT(P),EDATE)
I X]"" Q "1^ROTAVIRUS Evidence: "_$P(X,U,2)_" on "_$$DATE^BUDAUTL1($P(X,U,3))
S X=$$LASTDX^BUDAUTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
I X]"" Q "1^ROTAVIRUS Contraindication: "_$P(X,U,2)_" on "_$$DATE^BUDAUTL1($P(X,U,3))
I $$PLCODE^BUDADU(P,"008.61") Q "1^ROTAVIRUS Evidence: 008.61 on Problem List"
S X=$$PLTAX^BUDADU(P,"BUD ROTA CONTRA DXS") I X Q "1^ROTAVIRUS Contraindication: "_$P(X,U,2)_" on Problem List"
F BUDZ=119,74,116,122 S X=$$ROTACONT(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^ROTAVIRUS Contraindication IM package: "_$$DATE^BUDAUTL1($P(X,U))_" "_$P(X,U,2)
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.Q:'$$ANAREACT^BUDARP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["NEOMYCIN" S G="1^ROTAVIRUS Contraindiction: "_$$DATE^BUDAUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
;now get imms and see if there are 3
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
S BUDOPV2=0
ROTAIMM ;get all immunizations
S C="119"
K BUDX D GETIMMS^BUDARP6C(P,BDATE,EDATE,C,.BUDX)
;now get cpt codes
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
;now get cpts
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90681 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90681 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
;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(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+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)
I BUDOPV>1 Q Y
I BUDOPV=1 S BUDOPV2=2
;NOW TRY FOR 3 DOSE
K BUDC,BUDG,BUDX
K BUDOPV,BUDAPOV
ROT3IMM ;get all immunizations
S C="74^116^122"
K BUDX D GETIMMS^BUDARP6C(P,BDATE,EDATE,C,.BUDX)
;now get cpt codes
S X=0 F S X=$O(BUDX(X)) Q:X'=+X S BUDOPV(X)=BUDX(X),BUDAPOV(X)=BUDX(X)
;now get cpts
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90680 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90680 D
....S BUDOPV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
..S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X D
...S Y=$$VAL^XBDIQ1(9000010.07,X,.01) I Y="008.61" D
....S BUDOPV(9999999-$P(ED,"."))="POV: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,"."))),BUDAPOV(9999999-$P(ED,"."))="POV: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$P(ED,".")))
S (X,Y)="",C=0 F S X=$O(BUDOPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q
.S Y=X
;now count them and see if there are 3 of them
S BUDOPV=0,X=0 F S X=$O(BUDOPV(X)) Q:X'=+X S BUDOPV=BUDOPV+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)
I BUDOPV>2 Q Y
S BUDOPV=BUDOPV+BUDOPV2
I BUDOPV>2 S Y="1^ROTA: total #: "_BUDOPV,X="" F S X=$O(BUDOPV(X)) Q:X'=+X S Y=Y_" "_BUDOPV(X)
I BUDOPV>2 Q Y
Q "0^"_(3-BUDOPV)_" ROTAVIRUS"
BUDARP6W ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 4:03 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
+4 ;
+5 ;
ROTACONT(P,C,ED) ;EP - ANALPHYLAXIS/IMMUNE DEF
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Anaphylaxis"
+9 IF $PIECE(^BICONT(R,0),U,1)["Immune"
SET G=D_U_$PIECE(^BICONT(R,0),U,1)
+10 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Neomycin Allergy"
End DoDot:1
+11 QUIT G
ROTA(P,BDATE,EDATE) ;EP
+1 ;check for a contraindication from DOB to 2nd birthday
+2 NEW X,G,N,BUDG,BUDX,BUDC,BUDOPV,BUDAPOV,C,BD,ED,V,Y,E
+3 ;now check for evidence of disease
+4 SET X=$$LASTDXI^BUDAUTL1(P,"008.61",$$DOB^AUPNPAT(P),EDATE)
+5 IF X]""
QUIT "1^ROTAVIRUS Evidence: "_$PIECE(X,U,2)_" on "_$$DATE^BUDAUTL1($PIECE(X,U,3))
+6 SET X=$$LASTDX^BUDAUTL1(P,"BUD ROTA CONTRA DXS",$$DOB^AUPNPAT(P),EDATE)
+7 IF X]""
QUIT "1^ROTAVIRUS Contraindication: "_$PIECE(X,U,2)_" on "_$$DATE^BUDAUTL1($PIECE(X,U,3))
+8 IF $$PLCODE^BUDADU(P,"008.61")
QUIT "1^ROTAVIRUS Evidence: 008.61 on Problem List"
+9 SET X=$$PLTAX^BUDADU(P,"BUD ROTA CONTRA DXS")
IF X
QUIT "1^ROTAVIRUS Contraindication: "_$PIECE(X,U,2)_" on Problem List"
+10 FOR BUDZ=119,74,116,122
SET X=$$ROTACONT(P,BUDZ,EDATE)
IF X]""
QUIT
+11 IF X]""
QUIT "1^ROTAVIRUS Contraindication IM package: "_$$DATE^BUDAUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+12 SET G=""
+13 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+14 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+15 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+16 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT^BUDARP6C(X)
QUIT
+17 IF N["NEOMYCIN"
SET G="1^ROTAVIRUS Contraindiction: "_$$DATE^BUDAUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+18 IF G]""
QUIT G
+19 ;now get imms and see if there are 3
+20 KILL BUDC,BUDG,BUDX
+21 KILL BUDOPV,BUDAPOV
+22 SET BUDOPV2=0
ROTAIMM ;get all immunizations
+1 SET C="119"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(P,BDATE,EDATE,C,.BUDX)
+3 ;now get cpt codes
+4 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDOPV(X)=BUDX(X)
SET BUDAPOV(X)=BUDX(X)
+5 ;now get cpts
+6 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+7 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90681
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90681
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+17 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 ;now count them and see if there are 4 of them
+22 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+23 IF BUDOPV>1
SET Y="1^ROTA 2: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+24 IF BUDOPV>1
QUIT Y
+25 IF BUDOPV=1
SET BUDOPV2=2
+26 ;NOW TRY FOR 3 DOSE
+27 KILL BUDC,BUDG,BUDX
+28 KILL BUDOPV,BUDAPOV
ROT3IMM ;get all immunizations
+1 SET C="74^116^122"
+2 KILL BUDX
DO GETIMMS^BUDARP6C(P,BDATE,EDATE,C,.BUDX)
+3 ;now get cpt codes
+4 SET X=0
FOR
SET X=$ORDER(BUDX(X))
IF X'=+X
QUIT
SET BUDOPV(X)=BUDX(X)
SET BUDAPOV(X)=BUDX(X)
+5 ;now get cpts
+6 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+7 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90680
Begin DoDot:4
+12 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90680
Begin DoDot:4
+15 SET BUDOPV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="CPT: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$$VAL^XBDIQ1(9000010.07,X,.01)
IF Y="008.61"
Begin DoDot:4
+18 SET BUDOPV(9999999-$PIECE(ED,"."))="POV: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
SET BUDAPOV(9999999-$PIECE(ED,"."))="POV: "_Y_" on "_$$DATE^BUDAUTL1((9999999-$PIECE(ED,".")))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDOPV(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;now count them and see if there are 3 of them
+24 SET BUDOPV=0
SET X=0
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET BUDOPV=BUDOPV+1
+25 IF BUDOPV>2
SET Y="1^ROTA: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+26 IF BUDOPV>2
QUIT Y
+27 SET BUDOPV=BUDOPV+BUDOPV2
+28 IF BUDOPV>2
SET Y="1^ROTA: total #: "_BUDOPV
SET X=""
FOR
SET X=$ORDER(BUDOPV(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDOPV(X)
+29 IF BUDOPV>2
QUIT Y
+30 QUIT "0^"_(3-BUDOPV)_" ROTAVIRUS"
