BGP7D36.m

BGP7D36 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:03 PM 28 May 2015 4:23 PM ;

 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29

 ;

MEN(P,EDATE) ;EP

 NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 K BGPMENI

 ;get all immunizations

 S C="32^108^114^136^147"

 D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 ;go through and set into array if 10 days apart

 I $O(BGPX(0)) Q 1_U_"Meningococcal"

 ;now get cpts

 S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),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=90733!(Y=90734) S BGPMENI(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=90733!(Y=90734) S BGPMENI(9999999-$P(ED,"."))=""

 I $D(BGPMENI) Q 1_U_"Meningococcal"

 ;check for Evidence of desease and Contraindications and if yes, then quit

 F BGPZ=32,108,114,136,147 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"Contra Meningococcal"

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=32,108,114,136,147  D

 .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 F BGPIMM=90733,90734 D

 .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 ;now check Refusals in imm pkg

 ;F BGPIMM=32,108,114,136,147 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q 3_U_"Ref imm pkg Meningococcal"

 Q ""

 ;

HPV(P,EDATE) ;EP

 NEW BGPC,BGPG,BGPX,BGPHPV,C,X,ED,BD,V,G,R,BGPIMM,Y,Z,B,BGPNMI

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 ;get all immunizations

 S C="62^118^137^165"

 D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 ;go through and set into array if 10 days apart

 S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHPV(X)=""

 ;now get cpts

 S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),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) S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650)!(Z=90651) S BGPHPV(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 Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650)!(Z=90651) S BGPHPV(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(BGPHPV(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

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

 .S Y=X

 ;now count them and see if there are 4 of them

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

 I BGPHPV>2 Q 1_U_"3 HPV"

 ;check for Evidence of desease and Contraindications and if yes, then quit

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=62,118,137,165  D

 .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"

 F BGPIMM=90649,90650,90651 D

 .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI HPV",1:"Ref HPV")

 ;now check Refusals in imm pkg

 ;F BGPIMM=62,118 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"

 F BGPZ=62,118,137,165 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"Contra HPV"

 Q ""

AGE(P,BGPZ,BGPDT) ;EP

 ;---> Return Patient's Age.

 ;---> Parameters:

 ;     1 - DFN  (req) IEN in PATIENT File.

 ;     2 - BGPZ  (opt) APCLZ=1,2,3  1=years, 2=months, 3=days.

 ;                               2 will be assumed if not passed.

 ;     3 - APCLDT (opt) Date on which Age should be calculated.

 ;

 N BGPDOB,X,X1,X2  S:$G(BGPZ)="" BGPZ=2

 Q:'$G(P) ""

 I '$D(^DPT(P,0)) Q ""

 S BGPDOB=$P(^DPT(P,0),U,3)

 Q:'BGPDOB ""

 S:'$G(DT) DT=$$DT^XLFDT

 S:'$G(BGPDT) BGPDT=DT

 Q:BGPDT<BGPDOB ""

 ;

 ;---> Age in Years.

 N BGPAGEY,BGPAGEM,BGPD1,BGPD2,BGPM1,BGPM2,BGPY1,BGPY2

 S BGPM1=$E(BGPDOB,4,7),BGPM2=$E(BGPDT,4,7)

 S BGPY1=$E(BGPDOB,1,3),BGPY2=$E(BGPDT,1,3)

 S BGPAGEY=BGPY2-BGPY1 S:BGPM2<BGPM1 BGPAGEY=BGPAGEY-1

 S:BGPAGEY<1 BGPAGEY="<1"

 Q:BGPZ=1 BGPAGEY

 ;

 ;---> Age in Months.

 S BGPD1=$E(BGPM1,3,4),BGPM1=$E(BGPM1,1,2)

 S BGPD2=$E(BGPM2,3,4),BGPM2=$E(BGPM2,1,2)

 S BGPAGEM=12*BGPAGEY

 I BGPM2=BGPM1&(BGPD2<BGPD1) S BGPAGEM=BGPAGEM+12

 I BGPM2>BGPM1 S BGPAGEM=BGPAGEM+BGPM2-BGPM1

 I BGPM2<BGPM1 S BGPAGEM=BGPAGEM+BGPM2+(12-BGPM1)

 S:BGPD2<BGPD1 BGPAGEM=BGPAGEM-1

 Q:BGPZ=2 BGPAGEM

 ;

 ;---> Age in Days.

 S X1=BGPDT,X2=BGPDOB

 D ^%DTC

 Q X

 ;

 ;

BGP7D36   ; IHS/CMI/LAB - measure C 06 Nov 2009 2:03 PM 28 May 2015 4:23 PM ;

 +1       ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29

 +2       ;

MEN(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G

 +2       ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 +3        KILL BGPMENI

 +4       ;get all immunizations

 +5        SET C="32^108^114^136^147"

 +6        DO GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 +7       ;go through and set into array if 10 days apart

 +8        IF $ORDER(BGPX(0))

               QUIT 1_U_"Meningococcal"

 +9       ;now get cpts

 +10       SET ED=9999999-EDATE-1

           SET BD=9999999-$$DOB^AUPNPAT(P)

           SET G=0

 +11       FOR 

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)

                   QUIT 

               Begin DoDot:1

 +12               SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V

                           QUIT 

                       Begin DoDot:2

 +13                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT 

 +14                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVCPT("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +15                               SET Y=$PIECE(^AUPNVCPT(X,0),U)

                                   SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Y=90733!(Y=90734)

                                       SET BGPMENI(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +16                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVTC("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +17                               SET Y=$PIECE(^AUPNVTC(X,0),U,7)

                                   IF 'Y

                                       QUIT 

                                   SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Y=90733!(Y=90734)

                                       SET BGPMENI(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       IF $DATA(BGPMENI)

               QUIT 1_U_"Meningococcal"

 +19      ;check for Evidence of desease and Contraindications and if yes, then quit

 +20       FOR BGPZ=32,108,114,136,147

               SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +21       IF X]""

               QUIT 4_U_"Contra Meningococcal"

 +22      ;now go to Refusals

 +23       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +24       FOR BGPIMM=32,108,114,136,147

               Begin DoDot:1

 +25               SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT 

 +26               SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))

                       IF X'=+X

                           QUIT 

                       SET Y=0

                       FOR 

                           SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))

                           IF Y'=+Y

                               QUIT 

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +27       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 +28       FOR BGPIMM=90733,90734

               Begin DoDot:1

 +29               SET I=+$$CODEN^ICPTCOD(BGPIMM)

                   IF 'I

                       QUIT 

 +30               SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))

                       IF X'=+X

                           QUIT 

                       SET Y=0

                       FOR 

                           SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))

                           IF Y'=+Y

                               QUIT 

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +31       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 +32      ;now check Refusals in imm pkg

 +33      ;F BGPIMM=32,108,114,136,147 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +34      ;I R Q 3_U_"Ref imm pkg Meningococcal"

 +35       QUIT ""

 +36      ;

HPV(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX,BGPHPV,C,X,ED,BD,V,G,R,BGPIMM,Y,Z,B,BGPNMI

 +2       ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 +3       ;get all immunizations

 +4        SET C="62^118^137^165"

 +5        DO GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 +6       ;go through and set into array if 10 days apart

 +7        SET X=0

           FOR 

               SET X=$ORDER(BGPX(X))

               IF X'=+X

                   QUIT 

               SET BGPHPV(X)=""

 +8       ;now get cpts

 +9        SET ED=9999999-EDATE

           SET BD=9999999-$$DOB^AUPNPAT(P)

           SET G=0

 +10       FOR 

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)

                   QUIT 

               Begin DoDot:1

 +11               SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V

                           QUIT 

                       Begin DoDot:2

 +12                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT 

 +13                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVCPT("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +14                               SET Y=$PIECE(^AUPNVCPT(X,0),U)

                                   SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Z=90649!(Z=90650)!(Z=90651)

                                       SET BGPHPV(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +15                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVTC("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +16                               SET Y=$PIECE(^AUPNVTC(X,0),U,7)

                                   IF 'Y

                                       QUIT 

                                   SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Z=90649!(Z=90650)!(Z=90651)

                                       SET BGPHPV(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +17      ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones

 +18       SET X=""

           SET Y=""

           SET C=0

           FOR 

               SET X=$ORDER(BGPHPV(X))

               IF X'=+X

                   QUIT 

               SET C=C+1

               Begin DoDot:1

 +19               IF C=1

                       SET Y=X

                       QUIT 

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

                       KILL BGPHPV(X)

                       QUIT 

 +21               SET Y=X

               End DoDot:1

 +22      ;now count them and see if there are 4 of them

 +23       SET BGPHPV=0

           SET X=0

           FOR 

               SET X=$ORDER(BGPHPV(X))

               IF X'=+X

                   QUIT 

               SET BGPHPV=BGPHPV+1

 +24       IF BGPHPV>2

               QUIT 1_U_"3 HPV"

 +25      ;check for Evidence of desease and Contraindications and if yes, then quit

 +26      ;now go to Refusals

 +27       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +28       FOR BGPIMM=62,118,137,165

               Begin DoDot:1

 +29               SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT 

 +30               SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))

                       IF X'=+X

                           QUIT 

                       SET Y=0

                       FOR 

                           SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))

                           IF Y'=+Y

                               QUIT 

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +31       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" HPV"

 +32       FOR BGPIMM=90649,90650,90651

               Begin DoDot:1

 +33               SET I=+$$CODEN^ICPTCOD(BGPIMM)

                   IF 'I

                       QUIT 

 +34               SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))

                       IF X'=+X

                           QUIT 

                       SET Y=0

                       FOR 

                           SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))

                           IF Y'=+Y

                               QUIT 

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +35       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI HPV",1:"Ref HPV")

 +36      ;now check Refusals in imm pkg

 +37      ;F BGPIMM=62,118 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +38      ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"

 +39       FOR BGPZ=62,118,137,165

               SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +40       IF X]""

               QUIT 4_U_"Contra HPV"

 +41       QUIT ""

AGE(P,BGPZ,BGPDT) ;EP

 +1       ;---> Return Patient's Age.

 +2       ;---> Parameters:

 +3       ;     1 - DFN  (req) IEN in PATIENT File.

 +4       ;     2 - BGPZ  (opt) APCLZ=1,2,3  1=years, 2=months, 3=days.

 +5       ;                               2 will be assumed if not passed.

 +6       ;     3 - APCLDT (opt) Date on which Age should be calculated.

 +7       ;

 +8        NEW BGPDOB,X,X1,X2

           IF $GET(BGPZ)=""

               SET BGPZ=2

 +9        IF '$GET(P)

               QUIT ""

 +10       IF '$DATA(^DPT(P,0))

               QUIT ""

 +11       SET BGPDOB=$PIECE(^DPT(P,0),U,3)

 +12       IF 'BGPDOB

               QUIT ""

 +13       IF '$GET(DT)

               SET DT=$$DT^XLFDT

 +14       IF '$GET(BGPDT)

               SET BGPDT=DT

 +15       IF BGPDT<BGPDOB

               QUIT ""

 +16      ;

 +17      ;---> Age in Years.

 +18       NEW BGPAGEY,BGPAGEM,BGPD1,BGPD2,BGPM1,BGPM2,BGPY1,BGPY2

 +19       SET BGPM1=$EXTRACT(BGPDOB,4,7)

           SET BGPM2=$EXTRACT(BGPDT,4,7)

 +20       SET BGPY1=$EXTRACT(BGPDOB,1,3)

           SET BGPY2=$EXTRACT(BGPDT,1,3)

 +21       SET BGPAGEY=BGPY2-BGPY1

           IF BGPM2<BGPM1

               SET BGPAGEY=BGPAGEY-1

 +22       IF BGPAGEY<1

               SET BGPAGEY="<1"

 +23       IF BGPZ=1

               QUIT BGPAGEY

 +24      ;

 +25      ;---> Age in Months.

 +26       SET BGPD1=$EXTRACT(BGPM1,3,4)

           SET BGPM1=$EXTRACT(BGPM1,1,2)

 +27       SET BGPD2=$EXTRACT(BGPM2,3,4)

           SET BGPM2=$EXTRACT(BGPM2,1,2)

 +28       SET BGPAGEM=12*BGPAGEY

 +29       IF BGPM2=BGPM1&(BGPD2<BGPD1)

               SET BGPAGEM=BGPAGEM+12

 +30       IF BGPM2>BGPM1

               SET BGPAGEM=BGPAGEM+BGPM2-BGPM1

 +31       IF BGPM2<BGPM1

               SET BGPAGEM=BGPAGEM+BGPM2+(12-BGPM1)

 +32       IF BGPD2<BGPD1

               SET BGPAGEM=BGPAGEM-1

 +33       IF BGPZ=2

               QUIT BGPAGEM

 +34      ;

 +35      ;---> Age in Days.

 +36       SET X1=BGPDT

           SET X2=BGPDOB

 +37       DO ^%DTC

 +38       QUIT X

 +39      ;

 +40      ;