Routine: BGPMUD07

BGPMUD07 ; IHS/MSC/SAT - MU measure NQF0027 ;12-JUL-2011 15:43;DU

 ;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106

 ;code to collect meaningful use report SMOKING CESSATION MEDICAL ASSIST

ENTRY ;EP

 ; expects:

 ;  DFN      = patient code from VA PATIENT file

 ;  BGPBDATE = begin date of report

 ;  BGPEDATE = end date of report

 ;  BGPPROV   = provider code from NEW PERSON file

 ;  BGPMUTF  = timeframe variable - "C"=current year; "P"=previous year; "B"=baseline year

 ; Print Routine:     P27ENT^BGPMUDP?

 ; Delimited Routine: D27ENT^BGPMUDD?

 N BGPDEN,BGPNUM1,BGPNUM2,BGPNOT1,BGPNOT2,BGPDT,BGPAGEE,VIEN

 N BGPHFI

 N END,HF,N2CPT,START,TOPC,TOPCL,TOPIEN,VPEDD,VPEDIEN

 S HF=0

 S (BGPDEN,BGPNUM1,BGPNUM2,BGPNOT1,BGPNOT2)=0

 S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 ;quit if not 18 by the end of the reporting period

 Q:BGPAGEE<18

 ;look for 1 outpatient encounter with the EP back to 730 days prior to the end of the reporting period

 S START=9999999-$$FMADD^XLFDT(BGPEDATE,-730),END=9999999-BGPEDATE

 S FIRST=END-0.1 F  S FIRST=$O(^AUPNVSIT("AA",DFN,FIRST)) Q:FIRST=""!($P(FIRST,".",1)>START)  D  Q:+BGPDEN

 .S VIEN=0 F  S VIEN=$O(^AUPNVSIT("AA",DFN,FIRST,VIEN)) Q:'+VIEN  D  Q:+BGPDEN

 ..S BGPDT=$P($P($G(^AUPNVSIT(VIEN,0)),U,1),".",1)

 ..;Check provider, determine if there are visits with E&M codes

 ..I $$PRV^BGPMUUT1(VIEN,BGPPROV) D

 ...S X=$$VSTCPT^BGPMUUT1(DFN,VIEN,"BGPMU CTRL HIGH BP EM")

 ...I +X S BGPDEN=1_U_"EN:"_$$DATE^BGPMUUTL(BGPDT)

 ...I '+BGPDEN D

 ....S X=$$VSTPOV^BGPMUUT3(DFN,VIEN,"BGPMU ENC OUTPATIENT ICD")

 ....I +X S BGPDEN=1_U_"EN:"_$$DATE^BGPMUUTL(BGPDT)

 ;quit if visits with E&M code(s) not found for given DFN

 Q:'+BGPDEN

 ;check numerator 1

 S HF=$$HF(DFN,"BGPMU TOB SMOKER HF")

 S BGPDENT=""

 I +HF D

 .S BGPNUM1="M:"_$P(HF,U,2)_" "_$$DATE^BGPMUUTL($P(HF,U,4))  ;patient is in numerator 1

 .S BGPNUM1=1_U_$$FL(BGPNUM1,17,";")

 .S BGPDENT="HF:"_$$DATE^BGPMUUTL($P(HF,U,4))

 I 'BGPNUM1 D

 .S HF=$$HF(DFN,"BGPMU TOB NON-USER HF")

 .S BGPNOT1="NM:"_$S(+HF:$P(HF,U,2)_" "_$$DATE^BGPMUUTL($P(HF,U,4)),1:"")

 .S BGPNOT1=1_U_$$FL(BGPNOT1,17,";")

 ;check numerator 2

 I +BGPNUM1 D

 .S N2CPT=$$CPT^BGPMUUT1(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE,"BGPMU TOBACCO USE CESS COUNSEL")

 .I +N2CPT S BGPNUM2=1_U_"M:"_$P(N2CPT,U,2)_" "_$$DATE^BGPMUUTL($P(N2CPT,U,3))

 .I '+BGPNUM2 D

 ..S START=9999999-$$FMADD^XLFDT(BGPEDATE,-365)

 ..S END=9999999-BGPEDATE

 ..S VPEDD=END-1 F  S VPEDD=$O(^AUPNVPED("AA",DFN,VPEDD)) Q:VPEDD=""  D

 ...S VPEDIEN=0 F  S VPEDIEN=$O(^AUPNVPED("AA",DFN,VPEDD,VPEDIEN)) Q:VPEDIEN=""  D

 ....S TOPIEN=$P(^AUPNVPED(VPEDIEN,0),U,1)

 ....Q:TOPIEN=""

 ....S TOPC=$P(^AUTTEDT(TOPIEN,0),U,2)

 ....S TOPCL=$L(TOPC)

 ....I ("TO"=$E(TOPC,1,2))!("TO"=$E(TOPC,TOPCL-1,TOPCL))!("SHS"=$E(TOPC,TOPCL-2,TOPCL)) S BGPNUM2="M:"_TOPC_" "_$$DATE^BGPMUUTL((9999999-VPEDD)),BGPNUM2=1_U_$$FL(BGPNUM2,17,";")

 S:'+BGPNUM2 BGPNOT2=1_U_"NM:"

 D TOTAL(DFN)

 ; check these

 K BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y,TERMINAL,NORMAL,FOLLOW,EXCEPT

TOTAL(DFN) ;See where this patient ends up

 ;  BGPDSTR = Denominator string: encounter dates in FM format pieced by ";"

 ;  BGPNSTR = Numerator string: <health factor text> ";" <health factor edit date in FM format>

 ;if we got here, this patient is in the denominator

 N BGPDT,PTCNT,DENCT,NUMCT,NOTCT,TOTALS,PT1

 S TOTALS=$G(^TMP("BGPMU0027",$J,BGPMUTF,"TOT"))

 S NUMCT1=+$G(^TMP("BGPMU0027",$J,BGPMUTF,"NUM",1))

 S NUMCT2=+$G(^TMP("BGPMU0027",$J,BGPMUTF,"NUM",2))

 S NOTCT1=+$G(^TMP("BGPMU0027",$J,BGPMUTF,"NOT",1))

 S NOTCT2=+$G(^TMP("BGPMU0027",$J,BGPMUTF,"NOT",2))

 S DENCT=+$G(^TMP("BGPMU0027",$J,BGPMUTF,"DEN",1))

 S EXCCT=+$G(^TMP("BGPMU0027",$J,BGPMUTF,"EXC",1))

 S PTCNT=$P(TOTALS,U,1),PT1=$P(TOTALS,U,2)

 S PTCNT=PTCNT+1

 S PT1=PT1+1

 I BGPDEN D

 .S DENCT=DENCT+1 S ^TMP("BGPMU0027",$J,BGPMUTF,"DEN",1)=DENCT

 .S ^TMP("BGPMU0027",$J,"PAT",BGPMUTF,"DEN",1,DENCT)=DFN

 .I +BGPNUM1 D

 ..S NUMCT1=NUMCT1+1

 ..S ^TMP("BGPMU0027",$J,BGPMUTF,"NUM",1)=NUMCT1

 ..S ^TMP("BGPMU0027",$J,"PAT",BGPMUTF,"NUM",1,PT1)=DFN_U_$P(BGPDEN,U,2)_U_$P(BGPNUM1,U,2)

 .I '+BGPNUM1 D

 ..S NOTCT1=NOTCT1+1

 ..S ^TMP("BGPMU0027",$J,BGPMUTF,"NOT",1)=NOTCT1

 ..S ^TMP("BGPMU0027",$J,"PAT",BGPMUTF,"NOT",1,PT1)=DFN_U_$P(BGPDEN,U,2)_U_$P(BGPNOT1,U,2)

 .I +BGPNUM2 D

 ..S NUMCT2=NUMCT2+1

 ..S ^TMP("BGPMU0027",$J,BGPMUTF,"NUM",2)=NUMCT2

 ..S ^TMP("BGPMU0027",$J,"PAT",BGPMUTF,"NUM",2,PT1)=DFN_U_$P(BGPDEN,U,2)_U_$P(BGPNUM2,U,2)

 .I '+BGPNUM2 D

 ..S NOTCT2=NOTCT2+1

 ..S ^TMP("BGPMU0027",$J,BGPMUTF,"NOT",2)=NOTCT2

 ..S ^TMP("BGPMU0027",$J,"PAT",BGPMUTF,"NOT",2,PT1)=DFN_U_$P(BGPDEN,U,2)_";"_BGPDENT_U_$P(BGPNOT2,U,2)

 S ^TMP("BGPMU0027",$J,BGPMUTF,"TOT")=PTCNT_U_PT1

 ;Setup iCare array for patient

 S BGPICARE("MU.EP.0027.1",BGPMUTF)=1_U_+BGPNUM1_U_""_U_$P(BGPDEN,U,2)_";"_$P($G(BGPNUM1),U,2)

 S BGPICARE("MU.EP.0027.2",BGPMUTF)=1_U_+BGPNUM2_U_""_U_$P(BGPDEN,U,2)_";"_$P($G(BGPNUM2),U,2)

HF(DFN,TAX)  ;look in health factors for values in given taxonomy

 N BGPDT,BGPH,BGPHFN,BGPTOBN,BGPTOBU

 S TIEN="" S TIEN=$O(^ATXAX("B",TAX,TIEN)) Q:'TIEN 0

 S BGPHF=0  ;health factor found flag

 S END=9999999-BGPEDATE,START=9999999-$$FMADD^XLFDT(BGPEDATE,-365)

 S FIRST=END-0.1 F  S FIRST=$O(^AUPNVSIT("AA",DFN,FIRST)) Q:FIRST=""!($P(FIRST,".",1)>START)  D  Q:BGPHF

 .S VIEN=0 F  S VIEN=$O(^AUPNVSIT("AA",DFN,FIRST,VIEN)) Q:'+VIEN  D  Q:BGPHF

 ..S BGPIEN="" F  S BGPIEN=$O(^AUPNVHF("AD",VIEN,BGPIEN)) Q:'+BGPIEN  D

 ...S BGPDT=$P($P($G(^AUPNVSIT(VIEN,0)),U,1),".",1)

 ...S BGPHNOD=$G(^AUPNVHF(BGPIEN,0))

 ...S BGPHFI=$P(BGPHNOD,U,1)

 ...S BGPHFC=$P(^AUTTHF(BGPHFI,0),U,2)

 ...S BGPHFN=$P(^AUTTHF(BGPHFI,0),U,1)

 ...I $D(^ATXAX(TIEN,21,"B",BGPHFN)) S BGPHF=1_"^"_BGPHFN_"^"_BGPHFC_"^"_BGPDT

 Q BGPHF

FL(STRING,WIDTH,DELIM) ;

 N FLI,TSTRING

 S:$G(DELIM)="" DELIM="^"

 S RETURN=""

 Q:$L(STRING)<=WIDTH STRING

 S TSTRING=STRING

 S TSTRINGL=$L(TSTRING)

 F  Q:TSTRING=""  D

 .S TSA=0

 .I WIDTH>=$L(TSTRING) S RETURN=RETURN_DELIM_TSTRING,TSTRING=""

 .Q:TSTRING=""

 .I $E(TSTRING,1,WIDTH)'[" " D

 ..S RETURN=$S(RETURN'="":RETURN_DELIM,1:"")_$E(TSTRING,1,WIDTH)

 ..S TSTRING=$E(TSTRING,WIDTH+1,TSTRINGL)

 ..S TSTRINGL=$L(TSTRING)

 ..S TSA=1

 .Q:TSA

 .S FLI=WIDTH

 .F  Q:FLI<1  D

 ..I $E(TSTRING,FLI)=" " D

 ...S RETURN=$S(RETURN'="":RETURN_DELIM,1:"")_$E(TSTRING,1,FLI-1)

 ...S TSTRING=$E(TSTRING,FLI+1,TSTRINGL)

 ...S TSTRINGL=$L(TSTRING)

 ...S FLI=1

 ..S FLI=FLI-1

 Q RETURN

TEST ; debug target

 ;S U="^"

 ;S DT=$$DT^XLFDT()

 ;S DFN=184            ;  DFN      = patient code from VA PATIENT file

 ;S BGPBDATE=3100930   ;  BGPBDATE = begin date of report

 ;S BGPEDATE=3110801   ;  BGPEDATE = end date of report

 ;S BGPPROV=2          ;  BGPPROV   = provider code from NEW PERSON file

 ;S BGPMUTF="C"        ;  BGPMUTF  = timeframe variable - "C"=current year; "P"=previous year; "B"=baseline year

 ;D ENTRY

 ;S ZSAT=$$HF(175,"BGPMU TOB SMOKER HF")

 ;W ZSAT

BGPMUD07  ; IHS/MSC/SAT - MU measure NQF0027 ;12-JUL-2011 15:43;DU

 +1       ;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106

 +2       ;code to collect meaningful use report SMOKING CESSATION MEDICAL ASSIST

ENTRY     ;EP

 +1       ; expects:

 +2       ;  DFN      = patient code from VA PATIENT file

 +3       ;  BGPBDATE = begin date of report

 +4       ;  BGPEDATE = end date of report

 +5       ;  BGPPROV   = provider code from NEW PERSON file

 +6       ;  BGPMUTF  = timeframe variable - "C"=current year; "P"=previous year; "B"=baseline year

 +7       ; Print Routine:     P27ENT^BGPMUDP?

 +8       ; Delimited Routine: D27ENT^BGPMUDD?

 +9        NEW BGPDEN,BGPNUM1,BGPNUM2,BGPNOT1,BGPNOT2,BGPDT,BGPAGEE,VIEN

 +10       NEW BGPHFI

 +11       NEW END,HF,N2CPT,START,TOPC,TOPCL,TOPIEN,VPEDD,VPEDIEN

 +12       SET HF=0

 +13       SET (BGPDEN,BGPNUM1,BGPNUM2,BGPNOT1,BGPNOT2)=0

 +14       SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)

 +15      ;quit if not 18 by the end of the reporting period

 +16       IF BGPAGEE<18

               QUIT

 +17      ;look for 1 outpatient encounter with the EP back to 730 days prior to the end of the reporting period

 +18       SET START=9999999-$$FMADD^XLFDT(BGPEDATE,-730)

           SET END=9999999-BGPEDATE

 +19       SET FIRST=END-0.1

FOR

               SET FIRST=$ORDER(^AUPNVSIT("AA",DFN,FIRST))

               IF FIRST=""!($PIECE(FIRST,".",1)>START)

                   QUIT

               Begin DoDot:1

 +20               SET VIEN=0

FOR

                       SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,FIRST,VIEN))

                       IF '+VIEN

                           QUIT

                       Begin DoDot:2

 +21                       SET BGPDT=$PIECE($PIECE($GET(^AUPNVSIT(VIEN,0)),U,1),".",1)

 +22      ;Check provider, determine if there are visits with E&M codes

 +23                       IF $$PRV^BGPMUUT1(VIEN,BGPPROV)

                               Begin DoDot:3

 +24                               SET X=$$VSTCPT^BGPMUUT1(DFN,VIEN,"BGPMU CTRL HIGH BP EM")

 +25                               IF +X

                                       SET BGPDEN=1_U_"EN:"_$$DATE^BGPMUUTL(BGPDT)

 +26                               IF '+BGPDEN

                                       Begin DoDot:4

 +27                                       SET X=$$VSTPOV^BGPMUUT3(DFN,VIEN,"BGPMU ENC OUTPATIENT ICD")

 +28                                       IF +X

                                               SET BGPDEN=1_U_"EN:"_$$DATE^BGPMUUTL(BGPDT)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

                       IF +BGPDEN

                           QUIT

               End DoDot:1

               IF +BGPDEN

                   QUIT

 +29      ;quit if visits with E&M code(s) not found for given DFN

 +30       IF '+BGPDEN

               QUIT

 +31      ;

 +32      ;check numerator 1

 +33       SET HF=$$HF(DFN,"BGPMU TOB SMOKER HF")

 +34       SET BGPDENT=""

 +35       IF +HF

               Begin DoDot:1

 +36      ;patient is in numerator 1

                   SET BGPNUM1="M:"_$PIECE(HF,U,2)_" "_$$DATE^BGPMUUTL($PIECE(HF,U,4))

 +37               SET BGPNUM1=1_U_$$FL(BGPNUM1,17,";")

 +38               SET BGPDENT="HF:"_$$DATE^BGPMUUTL($PIECE(HF,U,4))

               End DoDot:1

 +39       IF 'BGPNUM1

               Begin DoDot:1

 +40               SET HF=$$HF(DFN,"BGPMU TOB NON-USER HF")

 +41               SET BGPNOT1="NM:"_$SELECT(+HF:$PIECE(HF,U,2)_" "_$$DATE^BGPMUUTL($PIECE(HF,U,4)),1:"")

 +42               SET BGPNOT1=1_U_$$FL(BGPNOT1,17,";")

               End DoDot:1

 +43      ;

 +44      ;check numerator 2

 +45       IF +BGPNUM1

               Begin DoDot:1

 +46               SET N2CPT=$$CPT^BGPMUUT1(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE,"BGPMU TOBACCO USE CESS COUNSEL")

 +47               IF +N2CPT

                       SET BGPNUM2=1_U_"M:"_$PIECE(N2CPT,U,2)_" "_$$DATE^BGPMUUTL($PIECE(N2CPT,U,3))

 +48               IF '+BGPNUM2

                       Begin DoDot:2

 +49                       SET START=9999999-$$FMADD^XLFDT(BGPEDATE,-365)

 +50                       SET END=9999999-BGPEDATE

 +51                       SET VPEDD=END-1

FOR

                               SET VPEDD=$ORDER(^AUPNVPED("AA",DFN,VPEDD))

                               IF VPEDD=""

                                   QUIT

                               Begin DoDot:3

 +52                               SET VPEDIEN=0

FOR

                                       SET VPEDIEN=$ORDER(^AUPNVPED("AA",DFN,VPEDD,VPEDIEN))

                                       IF VPEDIEN=""

                                           QUIT

                                       Begin DoDot:4

 +53                                       SET TOPIEN=$PIECE(^AUPNVPED(VPEDIEN,0),U,1)

 +54                                       IF TOPIEN=""

                                               QUIT

 +55                                       SET TOPC=$PIECE(^AUTTEDT(TOPIEN,0),U,2)

 +56                                       SET TOPCL=$LENGTH(TOPC)

 +57                                       IF ("TO"=$EXTRACT(TOPC,1,2))!("TO"=$EXTRACT(TOPC,TOPCL-1,TOPCL))!("SHS"=$EXTRACT(TOPC,TOPCL-2,TOPCL))

                                               SET BGPNUM2="M:"_TOPC_" "_$$DATE^BGPMUUTL((9999999-VPEDD))

                                               SET BGPNUM2=1_U_$$FL(BGPNUM2,17,";")

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +58       IF '+BGPNUM2

               SET BGPNOT2=1_U_"NM:"

 +59      ;

 +60       DO TOTAL(DFN)

 +61      ; check these

 +62       KILL BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y,TERMINAL,NORMAL,FOLLOW,EXCEPT

 +63       QUIT

 +64      ;

TOTAL(DFN) ;See where this patient ends up

 +1       ;  BGPDSTR = Denominator string: encounter dates in FM format pieced by ";"

 +2       ;  BGPNSTR = Numerator string: <health factor text> ";" <health factor edit date in FM format>

 +3       ;if we got here, this patient is in the denominator

 +4        NEW BGPDT,PTCNT,DENCT,NUMCT,NOTCT,TOTALS,PT1

 +5        SET TOTALS=$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"TOT"))

 +6        SET NUMCT1=+$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"NUM",1))

 +7        SET NUMCT2=+$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"NUM",2))

 +8        SET NOTCT1=+$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"NOT",1))

 +9        SET NOTCT2=+$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"NOT",2))

 +10       SET DENCT=+$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"DEN",1))

 +11       SET EXCCT=+$GET(^TMP("BGPMU0027",$JOB,BGPMUTF,"EXC",1))

 +12       SET PTCNT=$PIECE(TOTALS,U,1)

           SET PT1=$PIECE(TOTALS,U,2)

 +13       SET PTCNT=PTCNT+1

 +14       SET PT1=PT1+1

 +15       IF BGPDEN

               Begin DoDot:1

 +16               SET DENCT=DENCT+1

                   SET ^TMP("BGPMU0027",$JOB,BGPMUTF,"DEN",1)=DENCT

 +17               SET ^TMP("BGPMU0027",$JOB,"PAT",BGPMUTF,"DEN",1,DENCT)=DFN

 +18               IF +BGPNUM1

                       Begin DoDot:2

 +19                       SET NUMCT1=NUMCT1+1

 +20                       SET ^TMP("BGPMU0027",$JOB,BGPMUTF,"NUM",1)=NUMCT1

 +21                       SET ^TMP("BGPMU0027",$JOB,"PAT",BGPMUTF,"NUM",1,PT1)=DFN_U_$PIECE(BGPDEN,U,2)_U_$PIECE(BGPNUM1,U,2)

                       End DoDot:2

 +22               IF '+BGPNUM1

                       Begin DoDot:2

 +23                       SET NOTCT1=NOTCT1+1

 +24                       SET ^TMP("BGPMU0027",$JOB,BGPMUTF,"NOT",1)=NOTCT1

 +25                       SET ^TMP("BGPMU0027",$JOB,"PAT",BGPMUTF,"NOT",1,PT1)=DFN_U_$PIECE(BGPDEN,U,2)_U_$PIECE(BGPNOT1,U,2)

                       End DoDot:2

 +26               IF +BGPNUM2

                       Begin DoDot:2

 +27                       SET NUMCT2=NUMCT2+1

 +28                       SET ^TMP("BGPMU0027",$JOB,BGPMUTF,"NUM",2)=NUMCT2

 +29                       SET ^TMP("BGPMU0027",$JOB,"PAT",BGPMUTF,"NUM",2,PT1)=DFN_U_$PIECE(BGPDEN,U,2)_U_$PIECE(BGPNUM2,U,2)

                       End DoDot:2

 +30               IF '+BGPNUM2

                       Begin DoDot:2

 +31                       SET NOTCT2=NOTCT2+1

 +32                       SET ^TMP("BGPMU0027",$JOB,BGPMUTF,"NOT",2)=NOTCT2

 +33                       SET ^TMP("BGPMU0027",$JOB,"PAT",BGPMUTF,"NOT",2,PT1)=DFN_U_$PIECE(BGPDEN,U,2)_";"_BGPDENT_U_$PIECE(BGPNOT2,U,2)

                       End DoDot:2

               End DoDot:1

 +34      ;

 +35       SET ^TMP("BGPMU0027",$JOB,BGPMUTF,"TOT")=PTCNT_U_PT1

 +36      ;Setup iCare array for patient

 +37       SET BGPICARE("MU.EP.0027.1",BGPMUTF)=1_U_+BGPNUM1_U_""_U_$PIECE(BGPDEN,U,2)_";"_$PIECE($GET(BGPNUM1),U,2)

 +38       SET BGPICARE("MU.EP.0027.2",BGPMUTF)=1_U_+BGPNUM2_U_""_U_$PIECE(BGPDEN,U,2)_";"_$PIECE($GET(BGPNUM2),U,2)

 +39       QUIT

 +40      ;

HF(DFN,TAX) ;look in health factors for values in given taxonomy

 +1        NEW BGPDT,BGPH,BGPHFN,BGPTOBN,BGPTOBU

 +2        SET TIEN=""

           SET TIEN=$ORDER(^ATXAX("B",TAX,TIEN))

           IF 'TIEN

               QUIT 0

 +3       ;health factor found flag

           SET BGPHF=0

 +4        SET END=9999999-BGPEDATE

           SET START=9999999-$$FMADD^XLFDT(BGPEDATE,-365)

 +5        SET FIRST=END-0.1

FOR

               SET FIRST=$ORDER(^AUPNVSIT("AA",DFN,FIRST))

               IF FIRST=""!($PIECE(FIRST,".",1)>START)

                   QUIT

               Begin DoDot:1

 +6                SET VIEN=0

FOR

                       SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,FIRST,VIEN))

                       IF '+VIEN

                           QUIT

                       Begin DoDot:2

 +7                        SET BGPIEN=""

FOR

                               SET BGPIEN=$ORDER(^AUPNVHF("AD",VIEN,BGPIEN))

                               IF '+BGPIEN

                                   QUIT

                               Begin DoDot:3

 +8                                SET BGPDT=$PIECE($PIECE($GET(^AUPNVSIT(VIEN,0)),U,1),".",1)

 +9                                SET BGPHNOD=$GET(^AUPNVHF(BGPIEN,0))

 +10                               SET BGPHFI=$PIECE(BGPHNOD,U,1)

 +11                               SET BGPHFC=$PIECE(^AUTTHF(BGPHFI,0),U,2)

 +12                               SET BGPHFN=$PIECE(^AUTTHF(BGPHFI,0),U,1)

 +13                               IF $DATA(^ATXAX(TIEN,21,"B",BGPHFN))

                                       SET BGPHF=1_"^"_BGPHFN_"^"_BGPHFC_"^"_BGPDT

                               End DoDot:3

                       End DoDot:2

                       IF BGPHF

                           QUIT

               End DoDot:1

               IF BGPHF

                   QUIT

 +14       QUIT BGPHF

 +15      ;

FL(STRING,WIDTH,DELIM) ;

 +1        NEW FLI,TSTRING

 +2        IF $GET(DELIM)=""

               SET DELIM="^"

 +3        SET RETURN=""

 +4        IF $LENGTH(STRING)<=WIDTH

               QUIT STRING

 +5        SET TSTRING=STRING

 +6        SET TSTRINGL=$LENGTH(TSTRING)

 +7        FOR

               IF TSTRING=""

                   QUIT

               Begin DoDot:1

 +8                SET TSA=0

 +9                IF WIDTH>=$LENGTH(TSTRING)

                       SET RETURN=RETURN_DELIM_TSTRING

                       SET TSTRING=""

 +10               IF TSTRING=""

                       QUIT

 +11               IF $EXTRACT(TSTRING,1,WIDTH)'[" "

                       Begin DoDot:2

 +12                       SET RETURN=$SELECT(RETURN'="":RETURN_DELIM,1:"")_$EXTRACT(TSTRING,1,WIDTH)

 +13                       SET TSTRING=$EXTRACT(TSTRING,WIDTH+1,TSTRINGL)

 +14                       SET TSTRINGL=$LENGTH(TSTRING)

 +15                       SET TSA=1

                       End DoDot:2

 +16               IF TSA

                       QUIT

 +17               SET FLI=WIDTH

 +18               FOR

                       IF FLI<1

                           QUIT

                       Begin DoDot:2

 +19                       IF $EXTRACT(TSTRING,FLI)=" "

                               Begin DoDot:3

 +20                               SET RETURN=$SELECT(RETURN'="":RETURN_DELIM,1:"")_$EXTRACT(TSTRING,1,FLI-1)

 +21                               SET TSTRING=$EXTRACT(TSTRING,FLI+1,TSTRINGL)

 +22                               SET TSTRINGL=$LENGTH(TSTRING)

 +23                               SET FLI=1

                               End DoDot:3

 +24                       SET FLI=FLI-1

                       End DoDot:2

               End DoDot:1

 +25       QUIT RETURN

 +26      ;

TEST      ; debug target

 +1       ;S U="^"

 +2       ;S DT=$$DT^XLFDT()

 +3       ;S DFN=184            ;  DFN      = patient code from VA PATIENT file

 +4       ;S BGPBDATE=3100930   ;  BGPBDATE = begin date of report

 +5       ;S BGPEDATE=3110801   ;  BGPEDATE = end date of report

 +6       ;S BGPPROV=2          ;  BGPPROV   = provider code from NEW PERSON file

 +7       ;S BGPMUTF="C"        ;  BGPMUTF  = timeframe variable - "C"=current year; "P"=previous year; "B"=baseline year

 +8       ;D ENTRY

 +9       ;S ZSAT=$$HF(175,"BGPMU TOB SMOKER HF")

 +10      ;W ZSAT

 +11       QUIT

BGPMUD07.m