Routine: BGP2D341

BGP2D341 ; IHS/CMI/LAB - measure C ;

 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

TEST ;EP

 ;NOW TEST FOR ALL POSSIBLE COMBINATIONS OF HAVING MET INDICATOR

 ;1 DTAP AND 3 EACH TET,PER,DIP

 ;kill off any dip or tet on same day as a dtap

 S BGPVAL=""

 S (X,Y)="",C=0 F  S X=$O(BGPDIP(X)) Q:X'=+X  I $D(BGPDTAP(X)) K BGPDIP(X)

 S (X,Y)="",C=0 F  S X=$O(BGPDIP(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDIP(X) Q

 .S Y=X

 S (X,Y)="",C=0 F  S X=$O(BGPTET(X)) Q:X'=+X  I $D(BGPDTAP(X)) K BGPTET(X)

 S (X,Y)="",C=0 F  S X=$O(BGPTET(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPTET(X) Q

 .S Y=X

 S BGPDIP=0,X=0 F  S X=$O(BGPDIP(X)) Q:X'=+X  S BGPDIP=BGPDIP+1

 S BGPTET=0,X=0 F  S X=$O(BGPTET(X)) Q:X'=+X  S BGPTET=BGPTET+1

 I BGPTET>2,BGPDIP>1,$O(BGPDTAP(0)) S BGPBAL=BGPCODE_U_"Dtap & 3 TET & 3 DIP" Q

DTPER ;is there 4 DT and 4 pertussis?

 D RESET^BGP2D34

 ;delete ones not 10 days apart

 S (X,Y)="",C=0 F  S X=$O(BGPDT(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDT(X) Q

 .S Y=X

 S (X,Y)="",C=0 F  S X=$O(BGPPER(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q

 .S Y=X

 S BGPDT=0,X=0 F  S X=$O(BGPDT(X)) Q:X'=+X  S BGPDT=BGPDT+1

 S BGPPER=0,X=0 F  S X=$O(BGPPER(X)) Q:X'=+X  S BGPPER=BGPPER+1

 I BGPPER>3,BGPDT>3 S BGPVAL=BGPCODE_U_"3 DT & 3 PER" Q

TDPER ;

 D RESET^BGP2D34

 S (X,Y)="",C=0 F  S X=$O(BGPTD(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPTD(X) Q

 .S Y=X

 S (X,Y)="",C=0 F  S X=$O(BGPPER(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q

 .S Y=X

 S BGPTD=0,X=0 F  S X=$O(BGPTD(X)) Q:X'=+X  S BGPTD=BGPTD+1

 S BGPPER=0,X=0 F  S X=$O(BGPPER(X)) Q:X'=+X  S BGPPER=BGPPER+1

 I BGPPER>3,BGPTD>3 S BGPVAL=BGPCODE_U_"3 TD & 3 PER" Q

 I BGPTD>2,$O(BGPDTAP(0)) S BGPVAL=BGPCODE_U_"Dtap & 3 Td" Q

DIPTETPE ;

 D RESET^BGP2D34

 S (X,Y)="",C=0 F  S X=$O(BGPPER(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPPER(X) Q

 .S Y=X

 S BGPPER=0,X=0 F  S X=$O(BGPPER(X)) Q:X'=+X  S BGPPER=BGPPER+1

 S (X,Y)="",C=0 F  S X=$O(BGPDIP(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPDIP(X) Q

 .S Y=X

 S (X,Y)="",C=0 F  S X=$O(BGPTET(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPTET(X) Q

 .S Y=X

 S BGPDIP=0,X=0 F  S X=$O(BGPDIP(X)) Q:X'=+X  S BGPDIP=BGPDIP+1

 S BGPTET=0,X=0 F  S X=$O(BGPTET(X)) Q:X'=+X  S BGPTET=BGPTET+1

 I BGPPER>3,BGPDIP>3,BGPTET>3 S BGPVAL=BGPCODE_U_"3 EACH DIP,TET,PER" Q

90700 ;;

90721 ;;

90723 ;;

90701 ;;

90711 ;;

90720 ;;

90702 ;;

90718 ;;

90719 ;;

90703 ;;

BGP2D341  ; IHS/CMI/LAB - measure C ;

 +1       ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

TEST      ;EP

 +1       ;NOW TEST FOR ALL POSSIBLE COMBINATIONS OF HAVING MET INDICATOR

 +2       ;1 DTAP AND 3 EACH TET,PER,DIP

 +3       ;kill off any dip or tet on same day as a dtap

 +4        SET BGPVAL=""

 +5        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPDIP(X))

               IF X'=+X

                   QUIT

               IF $DATA(BGPDTAP(X))

                   KILL BGPDIP(X)

 +6        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPDIP(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +7                IF C=1

                       SET Y=X

                       QUIT

 +8                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPDIP(X)

                       QUIT

 +9                SET Y=X

               End DoDot:1

 +10       SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPTET(X))

               IF X'=+X

                   QUIT

               IF $DATA(BGPDTAP(X))

                   KILL BGPTET(X)

 +11       SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPTET(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +12               IF C=1

                       SET Y=X

                       QUIT

 +13               IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPTET(X)

                       QUIT

 +14               SET Y=X

               End DoDot:1

 +15       SET BGPDIP=0

           SET X=0

FOR

               SET X=$ORDER(BGPDIP(X))

               IF X'=+X

                   QUIT

               SET BGPDIP=BGPDIP+1

 +16       SET BGPTET=0

           SET X=0

FOR

               SET X=$ORDER(BGPTET(X))

               IF X'=+X

                   QUIT

               SET BGPTET=BGPTET+1

 +17       IF BGPTET>2

               IF BGPDIP>1

                   IF $ORDER(BGPDTAP(0))

                       SET BGPBAL=BGPCODE_U_"Dtap & 3 TET & 3 DIP"

                       QUIT

DTPER     ;is there 4 DT and 4 pertussis?

 +1        DO RESET^BGP2D34

 +2       ;delete ones not 10 days apart

 +3        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPDT(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +4                IF C=1

                       SET Y=X

                       QUIT

 +5                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPDT(X)

                       QUIT

 +6                SET Y=X

               End DoDot:1

 +7        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPPER(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +8                IF C=1

                       SET Y=X

                       QUIT

 +9                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPPER(X)

                       QUIT

 +10               SET Y=X

               End DoDot:1

 +11       SET BGPDT=0

           SET X=0

FOR

               SET X=$ORDER(BGPDT(X))

               IF X'=+X

                   QUIT

               SET BGPDT=BGPDT+1

 +12       SET BGPPER=0

           SET X=0

FOR

               SET X=$ORDER(BGPPER(X))

               IF X'=+X

                   QUIT

               SET BGPPER=BGPPER+1

 +13       IF BGPPER>3

               IF BGPDT>3

                   SET BGPVAL=BGPCODE_U_"3 DT & 3 PER"

                   QUIT

TDPER     ;

 +1        DO RESET^BGP2D34

 +2        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPTD(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +3                IF C=1

                       SET Y=X

                       QUIT

 +4                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPTD(X)

                       QUIT

 +5                SET Y=X

               End DoDot:1

 +6        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPPER(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +7                IF C=1

                       SET Y=X

                       QUIT

 +8                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPPER(X)

                       QUIT

 +9                SET Y=X

               End DoDot:1

 +10       SET BGPTD=0

           SET X=0

FOR

               SET X=$ORDER(BGPTD(X))

               IF X'=+X

                   QUIT

               SET BGPTD=BGPTD+1

 +11       SET BGPPER=0

           SET X=0

FOR

               SET X=$ORDER(BGPPER(X))

               IF X'=+X

                   QUIT

               SET BGPPER=BGPPER+1

 +12       IF BGPPER>3

               IF BGPTD>3

                   SET BGPVAL=BGPCODE_U_"3 TD & 3 PER"

                   QUIT

 +13       IF BGPTD>2

               IF $ORDER(BGPDTAP(0))

                   SET BGPVAL=BGPCODE_U_"Dtap & 3 Td"

                   QUIT

DIPTETPE  ;

 +1        DO RESET^BGP2D34

 +2        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPPER(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +3                IF C=1

                       SET Y=X

                       QUIT

 +4                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPPER(X)

                       QUIT

 +5                SET Y=X

               End DoDot:1

 +6        SET BGPPER=0

           SET X=0

FOR

               SET X=$ORDER(BGPPER(X))

               IF X'=+X

                   QUIT

               SET BGPPER=BGPPER+1

 +7        SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPDIP(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +8                IF C=1

                       SET Y=X

                       QUIT

 +9                IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPDIP(X)

                       QUIT

 +10               SET Y=X

               End DoDot:1

 +11       SET (X,Y)=""

           SET C=0

FOR

               SET X=$ORDER(BGPTET(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +12               IF C=1

                       SET Y=X

                       QUIT

 +13               IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPTET(X)

                       QUIT

 +14               SET Y=X

               End DoDot:1

 +15       SET BGPDIP=0

           SET X=0

FOR

               SET X=$ORDER(BGPDIP(X))

               IF X'=+X

                   QUIT

               SET BGPDIP=BGPDIP+1

 +16       SET BGPTET=0

           SET X=0

FOR

               SET X=$ORDER(BGPTET(X))

               IF X'=+X

                   QUIT

               SET BGPTET=BGPTET+1

 +17       IF BGPPER>3

               IF BGPDIP>3

                   IF BGPTET>3

                       SET BGPVAL=BGPCODE_U_"3 EACH DIP,TET,PER"

                       QUIT

 +18       QUIT

90700     ;;

90721     ;;

90723     ;;

90701     ;;

90711     ;;

90720     ;;

90702     ;;

90718     ;;

90719     ;;

90703     ;;

BGP2D341.m