APCLP713 ; 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
APCLP713 ; 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
+14 ;now look at first and last pov
+15 SET Y="APCL("
+16 SET X=P_"^LAST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
SET E=$$START1^APCLDF(X,Y)
+17 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))
+18 KILL APCL
SET X=P_"^FIRST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
SET E=$$START1^APCLDF(X,Y)
+19 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))
+20 QUIT
