APCLP613.m

APCLP613 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;LORI - ADD V04,81

 ;

 ;cmi/anch/maw 9/12/2007 code set versioning in PLDMDXS,IFG,IGT,MS,ABNG

 ;

BPS(P,BDATE,EDATE,F) ;EP ;

 I $G(F)="" S F="E"

 NEW X,APCL,E,APCLL,APCLLL,APCLV

 S APCLLL=0,APCLV=""

 K APCL

 S X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 S APCLL=0 F  S APCLL=$O(APCL(APCLL)) Q:APCLL'=+APCLL!(APCLLL=3)  S APCLBP=$P($G(APCL(APCLL)),U,2) D

 .Q:$$CLINIC^APCLV($P(APCL(APCLL),U,5),"C")=30

 .S APCLLL=APCLLL+1

 .I F="E" S $P(APCLV,";",APCLLL)=APCLBP_"  "_$$FMTE^XLFDT($P(APCL(APCLL),U))

 .I F="I" S $P(APCLV,";",APCLLL)=$P(APCLBP," ")

 Q APCLV

HTNDX(P,EDATE) ;EP - is HTN on problem list

 I '$G(P) Q ""

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

 NEW %,APCL,E

 K APCL

 S %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES" S E=$$START1^APCLDF(%,"APCL(")

 I $D(APCL(1)) Q "Yes"

 K APCL

 S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") I $D(APCL(3)) Q "Yes"

 Q "No"

LASTHT(P,EDATE,F) ;PEP - return last ht and date

 I 'P Q ""

 I $G(F)="" S F="E"

 I '$D(^AUPNVSIT("AC",P)) Q ""

 NEW %,APCLARRY,H,E,W

 S %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2)

 I H="" Q H

 S H=$J(H,4,1)

 I F="I" Q H

 Q H_" inches "_$$FMTE^XLFDT($P(APCLARRY(1),U))

LASTWC(P,EDATE,F) ;PEP - return last ht and date

 I 'P Q ""

 I $G(F)="" S F="E"

 I '$D(^AUPNVSIT("AC",P)) Q ""

 S BDATE=$$FMADD^XLFDT(EDATE,-365)

 NEW %,APCLARRY,H,E,W

 S %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2)

 Q H_"  "_$$FMTE^XLFDT($P($G(APCLARRY(1)),U))

LASTWT(P,EDATE,F) ;PEP - return last wt

 I 'P Q ""

 I $G(F)="" S F="E"

 S BDATE=$$FMADD^XLFDT(EDATE,-365)

 NEW %,APCLARRY,E,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX,W,H,APCLC

 NEW APCLV221 S APCLV221=$O(^ICD9("BA","V22.1 ",""))

 K APCL S APCLW="" S APCLX=P_"^LAST 30 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(APCLX,"APCL(")

 S APCLC=0,APCLN=0 F  S APCLN=$O(APCL(APCLN)) Q:APCLN'=+APCLN!(APCLC>2)  D

 . S APCLZ=$P(APCL(APCLN),U,5)

 . I '$D(^AUPNVPOV("AD",APCLZ)) S APCLC=APCLC+1,APCLW=APCLW_"|"_$P(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($P(APCL(APCLN),U)) Q

 . S APCLD=0 F  S APCLD=$O(^AUPNVPOV("AD",APCLZ,APCLD)) Q:'APCLD!(APCLW]"")  D

 .. I $P(^AUPNVPOV(APCLD,0),U)'=APCLV221 S APCLC=APCLC+1,APCLW=APCLW_"|"_$P(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($P(APCL(APCLN),U))

 ..Q

 Q $S(F="E":APCLW,1:+APCLW)

CMSFDX(P,R,T) ;EP - return date/dx of dm in register

 I '$G(P) Q ""

 I '$G(R) Q ""

 I $G(T)="" Q ""

 NEW D1,Y,X,D,G S (G,X)=0,(D,Y)="" F  S X=$O(^ACM(44,"C",P,X)) Q:X'=+X!(G)  I $P(^ACM(44,X,0),U,4)=R D

 .S D=$P($G(^ACM(44,X,"SV")),U,2),D1=D,D=$$FMTE^XLFDT(D)

 .S Y=$$VAL^XBDIQ1(9002244,X,.01)

 Q $S(T="D":$G(D),T="DX":$G(Y),T="ID":$G(D1),1:"")

 ;

PLDMDOO(P,F) ;EP

 I '$G(P) Q ""

 I $G(F)="" S F="E"

 NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))

 I 'T Q ""

 NEW D,X,I S D="",X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P(^AUPNPROB(X,0),U)

 .I $$ICD^ATXCHK(I,T,9) D

 ..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""

 ..Q

 .Q

 S D=$O(D(0)) Q $S(F="E":$$FMTE^XLFDT(D),1:$O(D(0)))

PLDMDXS(P) ;EP - get all DM dxs from problem list

 I '$G(P) Q ""

 NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))

 I 'T Q "<diabetes taxonomy missing>"

 NEW D,X,I S D="",X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P(^AUPNPROB(X,0),U)

 .;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U)  ;cmi/anch/maw 9/12/2007 orig line

 .I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q

 Q D

 ;

FRSTDMDX(P,F) ;EP return date of first dm dx

 I '$G(P) Q ""

 I $G(F)="" S F="E"

 NEW X,E,APCL,Y

 S Y="APCL("

 S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(APCL(1)),U)

 Q $S(F="E":$$FMTE^XLFDT(Y),1:Y)

LASTDMDX(P,D) ;EP - last pcc dm dx

 I '$G(P) Q ""

 NEW X,E,APCL,Y

 S Y="APCL("

 S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) Q "Type 2"

 K APCL S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) Q "Type 1"

 Q ""

 ;

IFG(P,APCLRET) ;EP

 K APCLRET

 NEW APCLC,APCL

 S APCLC=0

 K APCL

 ;look at problem list then povs

 ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 ;look for first and last pov

 S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P(^AUPNPROB(X,0),U)

 .;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 .S I=$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q:I'="790.21"

 .S APCLC=APCLC+1,APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 .Q

 ;now look at first and last pov

 S Y="APCL("

 S X=P_"^LAST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="Last POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 K APCL S X=P_"^FIRST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="First POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 Q

IGT(P,APCLRET) ;EP

 K APCLRET

 NEW APCLC,APCL

 S APCLC=0

 K APCL

 ;look at problem list then povs

 ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 ;look for first and last pov

 S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P(^AUPNPROB(X,0),U)

 .;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 .S I=$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q:I'="790.22"

 .S APCLC=APCLC+1,APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 .Q

 ;now look at first and last pov

 S Y="APCL("

 S X=P_"^LAST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="Last POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 K APCL S X=P_"^FIRST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="First POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 Q

MS(P,APCLRET) ;EP

 K APCLRET

 NEW APCLC,APCL

 S APCLC=0

 K APCL

 ;look at problem list then povs

 ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 ;look for first and last pov

 S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P(^AUPNPROB(X,0),U)

 .;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 .S I=$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q:I'="277.7"

 .S APCLC=APCLC+1,APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 .Q

 ;now look at first and last pov

 S Y="APCL("

 S X=P_"^LAST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="Last POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 K APCL S X=P_"^FIRST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="First POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 Q

ABNG(P,APCLRET) ;EP

 K APCLRET

 NEW APCLC

 S APCLC=0

 ;look at problem list then povs

 ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 ;look for first and last pov

 S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D

 .S I=$P(^AUPNPROB(X,0),U)

 .;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 .S I=$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q:I'="790.29"

 .S APCLC=APCLC+1,APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 .Q

 ;now look at first and last pov

 S Y="APCL("

 S X=P_"^LAST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="Last POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 K APCL S X=P_"^FIRST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) S APCLC=APCLC+1,APCLRET(APCLC)="First POV in PCC: "_$P(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($P(APCL(1),U))

 Q

APCLP613  ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;LORI - ADD V04,81

 +3       ;

 +4       ;cmi/anch/maw 9/12/2007 code set versioning in PLDMDXS,IFG,IGT,MS,ABNG

 +5       ;

BPS(P,BDATE,EDATE,F) ;EP ;

 +1        IF $GET(F)=""

               SET F="E"

 +2        NEW X,APCL,E,APCLL,APCLLL,APCLV

 +3        SET APCLLL=0

           SET APCLV=""

 +4        KILL APCL

 +5        SET X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(X,"APCL(")

 +6        SET APCLL=0

           FOR 

               SET APCLL=$ORDER(APCL(APCLL))

               IF APCLL'=+APCLL!(APCLLL=3)

                   QUIT 

               SET APCLBP=$PIECE($GET(APCL(APCLL)),U,2)

               Begin DoDot:1

 +7                IF $$CLINIC^APCLV($PIECE(APCL(APCLL),U,5),"C")=30

                       QUIT 

 +8                SET APCLLL=APCLLL+1

 +9                IF F="E"

                       SET $PIECE(APCLV,";",APCLLL)=APCLBP_"  "_$$FMTE^XLFDT($PIECE(APCL(APCLL),U))

 +10               IF F="I"

                       SET $PIECE(APCLV,";",APCLLL)=$PIECE(APCLBP," ")

               End DoDot:1

 +11       QUIT APCLV

HTNDX(P,EDATE) ;EP - is HTN on problem list

 +1        IF '$GET(P)

               QUIT ""

 +2        IF '$DATA(^DPT(P))

               QUIT ""

 +3        NEW %,APCL,E

 +4        KILL APCL

 +5        SET %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES"

           SET E=$$START1^APCLDF(%,"APCL(")

 +6        IF $DATA(APCL(1))

               QUIT "Yes"

 +7        KILL APCL

 +8        SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE

           SET E=$$START1^APCLDF(X,"APCL(")

           IF $DATA(APCL(3))

               QUIT "Yes"

 +9        QUIT "No"

LASTHT(P,EDATE,F) ;PEP - return last ht and date

 +1        IF 'P

               QUIT ""

 +2        IF $GET(F)=""

               SET F="E"

 +3        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +4        NEW %,APCLARRY,H,E,W

 +5        SET %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE

           NEW X

           SET E=$$START1^APCLDF(%,"APCLARRY(")

           SET H=$PIECE($GET(APCLARRY(1)),U,2)

 +6        IF H=""

               QUIT H

 +7        SET H=$JUSTIFY(H,4,1)

 +8        IF F="I"

               QUIT H

 +9        QUIT H_" inches "_$$FMTE^XLFDT($PIECE(APCLARRY(1),U))

LASTWC(P,EDATE,F) ;PEP - return last ht and date

 +1        IF 'P

               QUIT ""

 +2        IF $GET(F)=""

               SET F="E"

 +3        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +4        SET BDATE=$$FMADD^XLFDT(EDATE,-365)

 +5        NEW %,APCLARRY,H,E,W

 +6        SET %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE

           NEW X

           SET E=$$START1^APCLDF(%,"APCLARRY(")

           SET H=$PIECE($GET(APCLARRY(1)),U,2)

 +7        QUIT H_"  "_$$FMTE^XLFDT($PIECE($GET(APCLARRY(1)),U))

LASTWT(P,EDATE,F) ;PEP - return last wt

 +1        IF 'P

               QUIT ""

 +2        IF $GET(F)=""

               SET F="E"

 +3        SET BDATE=$$FMADD^XLFDT(EDATE,-365)

 +4        NEW %,APCLARRY,E,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX,W,H,APCLC

 +5        NEW APCLV221

           SET APCLV221=$ORDER(^ICD9("BA","V22.1 ",""))

 +6        KILL APCL

           SET APCLW=""

           SET APCLX=P_"^LAST 30 MEAS WT;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(APCLX,"APCL(")

 +7        SET APCLC=0

           SET APCLN=0

           FOR 

               SET APCLN=$ORDER(APCL(APCLN))

               IF APCLN'=+APCLN!(APCLC>2)

                   QUIT 

               Begin DoDot:1

 +8                SET APCLZ=$PIECE(APCL(APCLN),U,5)

 +9                IF '$DATA(^AUPNVPOV("AD",APCLZ))

                       SET APCLC=APCLC+1

                       SET APCLW=APCLW_"|"_$PIECE(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(APCL(APCLN),U))

                       QUIT 

 +10               SET APCLD=0

                   FOR 

                       SET APCLD=$ORDER(^AUPNVPOV("AD",APCLZ,APCLD))

                       IF 'APCLD!(APCLW]"")

                           QUIT 

                       Begin DoDot:2

 +11                       IF $PIECE(^AUPNVPOV(APCLD,0),U)'=APCLV221

                               SET APCLC=APCLC+1

                               SET APCLW=APCLW_"|"_$PIECE(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(APCL(APCLN),U))

 +12                       QUIT 

                       End DoDot:2

               End DoDot:1

 +13       QUIT $SELECT(F="E":APCLW,1:+APCLW)

CMSFDX(P,R,T) ;EP - return date/dx of dm in register

 +1        IF '$GET(P)

               QUIT ""

 +2        IF '$GET(R)

               QUIT ""

 +3        IF $GET(T)=""

               QUIT ""

 +4        NEW D1,Y,X,D,G

           SET (G,X)=0

           SET (D,Y)=""

           FOR 

               SET X=$ORDER(^ACM(44,"C",P,X))

               IF X'=+X!(G)

                   QUIT 

               IF $PIECE(^ACM(44,X,0),U,4)=R

                   Begin DoDot:1

 +5                    SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)

                       SET D1=D

                       SET D=$$FMTE^XLFDT(D)

 +6                    SET Y=$$VAL^XBDIQ1(9002244,X,.01)

                   End DoDot:1

 +7        QUIT $SELECT(T="D":$GET(D),T="DX":$GET(Y),T="ID":$GET(D1),1:"")

 +8       ;

PLDMDOO(P,F) ;EP

 +1        IF '$GET(P)

               QUIT ""

 +2        IF $GET(F)=""

               SET F="E"

 +3        NEW T

           SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))

 +4        IF 'T

               QUIT ""

 +5        NEW D,X,I

           SET D=""

           SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET I=$PIECE(^AUPNPROB(X,0),U)

 +7                IF $$ICD^ATXCHK(I,T,9)

                       Begin DoDot:2

 +8                        IF $PIECE(^AUPNPROB(X,0),U,13)]""

                               SET D($PIECE(^AUPNPROB(X,0),U,13))=""

 +9                        QUIT 

                       End DoDot:2

 +10               QUIT 

               End DoDot:1

 +11       SET D=$ORDER(D(0))

           QUIT $SELECT(F="E":$$FMTE^XLFDT(D),1:$ORDER(D(0)))

PLDMDXS(P) ;EP - get all DM dxs from problem list

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW T

           SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))

 +3        IF 'T

               QUIT "<diabetes taxonomy missing>"

 +4        NEW D,X,I

           SET D=""

           SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                SET I=$PIECE(^AUPNPROB(X,0),U)

 +6       ;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U)  ;cmi/anch/maw 9/12/2007 orig line

 +7       ;cmi/anch/maw 9/12/2007 csv

                   IF $$ICD^ATXCHK(I,T,9)

                       IF D]""

                           SET D=D_";"

                       SET D=D_$PIECE($$ICDDX^ICDCODE(I),U,2)

 +8                QUIT 

               End DoDot:1

 +9        QUIT D

 +10      ;

FRSTDMDX(P,F) ;EP return date of first dm dx

 +1        IF '$GET(P)

               QUIT ""

 +2        IF $GET(F)=""

               SET F="E"

 +3        NEW X,E,APCL,Y

 +4        SET Y="APCL("

 +5        SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"

           SET E=$$START1^APCLDF(X,Y)

           SET Y=$PIECE($GET(APCL(1)),U)

 +6        QUIT $SELECT(F="E":$$FMTE^XLFDT(Y),1:Y)

LASTDMDX(P,D) ;EP - last pcc dm dx

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X,E,APCL,Y

 +3        SET Y="APCL("

 +4        SET X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D

           SET E=$$START1^APCLDF(X,Y)

 +5        IF $DATA(APCL(1))

               QUIT "Type 2"

 +6        KILL APCL

           SET X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D

           SET E=$$START1^APCLDF(X,Y)

 +7        IF $DATA(APCL(1))

               QUIT "Type 1"

 +8        QUIT ""

 +9       ;

IFG(P,APCLRET) ;EP

 +1        KILL APCLRET

 +2        NEW APCLC,APCL

 +3        SET APCLC=0

 +4        KILL APCL

 +5       ;look at problem list then povs

 +6       ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 +7       ;look for first and last pov

 +8        SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +9                SET I=$PIECE(^AUPNPROB(X,0),U)

 +10      ;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 +11      ;cmi/anch/maw 9/12/2007 csv

                   SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)

 +12               IF I'="790.21"

                       QUIT 

 +13               SET APCLC=APCLC+1

                   SET APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 +14               QUIT 

               End DoDot:1

 +15      ;now look at first and last pov

 +16       SET Y="APCL("

 +17       SET X=P_"^LAST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT

           SET E=$$START1^APCLDF(X,Y)

 +18       IF $DATA(APCL(1))

               SET APCLC=APCLC+1

               SET APCLRET(APCLC)="Last POV in PCC: "_$PIECE(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($PIECE(APCL(1),U))

 +19       KILL APCL

           SET X=P_"^FIRST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT

           SET E=$$START1^APCLDF(X,Y)

 +20       IF $DATA(APCL(1))

               SET APCLC=APCLC+1

               SET APCLRET(APCLC)="First POV in PCC: "_$PIECE(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($PIECE(APCL(1),U))

 +21       QUIT 

IGT(P,APCLRET) ;EP

 +1        KILL APCLRET

 +2        NEW APCLC,APCL

 +3        SET APCLC=0

 +4        KILL APCL

 +5       ;look at problem list then povs

 +6       ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 +7       ;look for first and last pov

 +8        SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +9                SET I=$PIECE(^AUPNPROB(X,0),U)

 +10      ;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 +11      ;cmi/anch/maw 9/12/2007 csv

                   SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)

 +12               IF I'="790.22"

                       QUIT 

 +13               SET APCLC=APCLC+1

                   SET APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 +14               QUIT 

               End DoDot:1

 +15      ;now look at first and last pov

 +16       SET Y="APCL("

 +17       SET X=P_"^LAST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT

           SET E=$$START1^APCLDF(X,Y)

 +18       IF $DATA(APCL(1))

               SET APCLC=APCLC+1

               SET APCLRET(APCLC)="Last POV in PCC: "_$PIECE(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($PIECE(APCL(1),U))

 +19       KILL APCL

           SET X=P_"^FIRST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT

           SET E=$$START1^APCLDF(X,Y)

 +20       IF $DATA(APCL(1))

               SET APCLC=APCLC+1

               SET APCLRET(APCLC)="First POV in PCC: "_$PIECE(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($PIECE(APCL(1),U))

 +21       QUIT 

MS(P,APCLRET) ;EP

 +1        KILL APCLRET

 +2        NEW APCLC,APCL

 +3        SET APCLC=0

 +4        KILL APCL

 +5       ;look at problem list then povs

 +6       ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 +7       ;look for first and last pov

 +8        SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +9                SET I=$PIECE(^AUPNPROB(X,0),U)

 +10      ;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 +11      ;cmi/anch/maw 9/12/2007 csv

                   SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)

 +12               IF I'="277.7"

                       QUIT 

 +13               SET APCLC=APCLC+1

                   SET APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 +14               QUIT 

               End DoDot:1

 +15      ;now look at first and last pov

 +16       SET Y="APCL("

 +17       SET X=P_"^LAST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT

           SET E=$$START1^APCLDF(X,Y)

 +18       IF $DATA(APCL(1))

               SET APCLC=APCLC+1

               SET APCLRET(APCLC)="Last POV in PCC: "_$PIECE(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($PIECE(APCL(1),U))

 +19       KILL APCL

           SET X=P_"^FIRST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT

           SET E=$$START1^APCLDF(X,Y)

 +20       IF $DATA(APCL(1))

               SET APCLC=APCLC+1

               SET APCLRET(APCLC)="First POV in PCC: "_$PIECE(APCL(1),U,2)_"  Date: "_$$FMTE^XLFDT($PIECE(APCL(1),U))

 +21       QUIT 

ABNG(P,APCLRET) ;EP

 +1        KILL APCLRET

 +2        NEW APCLC

 +3        SET APCLC=0

 +4       ;look at problem list then povs

 +5       ;return  where found^dx code^provider narr^date (either visit date or doo from pl)

 +6       ;look for first and last pov

 +7        SET X=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +8                SET I=$PIECE(^AUPNPROB(X,0),U)

 +9       ;S I=$P($G(^ICD9(I,0)),U)  ;cmi/anch/maw 9/12/2007 orig line

 +10      ;cmi/anch/maw 9/12/2007 csv

                   SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)

 +11               IF I'="790.29"

                       QUIT 

 +12               SET APCLC=APCLC+1

                   SET APCLRET(APCLC)="Problem List: "_I_"  Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)

 +13               QUIT 

               End DoDot:1