- BDMP413 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
- ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
- ;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,BDM,E,BDML,BDMLL,BDMV
- S BDMLL=0,BDMV=""
- K BDM
- S X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
- S BDML=0 F S BDML=$O(BDM(BDML)) Q:BDML'=+BDML!(BDMLL=3) S BDMBP=$P($G(BDM(BDML)),U,2) D
- .Q:$$CLINIC^APCLV($P(BDM(BDML),U,5),"C")=30
- .S BDMLL=BDMLL+1
- .I F="E" S $P(BDMV,";",BDMLL)=BDMBP_" "_$$FMTE^XLFDT($P(BDM(BDML),U))
- .I F="I" S $P(BDMV,";",BDMLL)=$P(BDMBP," ")
- Q BDMV
- HTNDX(P,EDATE) ;EP - is HTN on problem list
- I '$G(P) Q ""
- I '$D(^DPT(P)) Q ""
- NEW %,BDM,E
- K BDM
- S %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES" S E=$$START1^APCLDF(%,"BDM(")
- I $D(BDM(1)) Q "Yes"
- K BDM
- S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(") I $D(BDM(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 %,BDMARRY,H,E,W
- S %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
- I H="" Q H
- S H=$J(H,4,1)
- I F="I" Q H
- Q H_" inches "_$$FMTE^XLFDT($P(BDMARRY(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 %,BDMARRY,H,E,W
- S %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
- Q H_" "_$$FMTE^XLFDT($P($G(BDMARRY(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 %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,W,H,BDMC
- NEW BDMV221 S BDMV221=$O(^ICD9("BA","V22.1 ",""))
- K BDM S BDMW="" S BDMX=P_"^LAST 30 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
- S BDMC=0,BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMC>2) D
- . S BDMZ=$P(BDM(BDMN),U,5)
- . I '$D(^AUPNVPOV("AD",BDMZ)) S BDMC=BDMC+1,BDMW=BDMW_"|"_$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U)) Q
- . S BDMD=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"") D
- .. I $P(^AUPNVPOV(BDMD,0),U)'=BDMV221 S BDMC=BDMC+1,BDMW=BDMW_"|"_$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U))
- ..Q
- Q $S(F="E":BDMW,1:+BDMW)
- 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,BDM,Y
- S Y="BDM("
- S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BDM(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,BDM,Y
- S Y="BDM("
- S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) Q "Type 2"
- K BDM S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) Q "Type 1"
- Q ""
- ;
- IFG(P,BDMRET) ;EP
- K BDMRET
- NEW BDMC,BDM
- S BDMC=0
- K BDM
- ;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 BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
- .Q
- ;now look at first and last pov
- S Y="BDM("
- S X=P_"^LAST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- K BDM S X=P_"^FIRST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- Q
- IGT(P,BDMRET) ;EP
- K BDMRET
- NEW BDMC,BDM
- S BDMC=0
- K BDM
- ;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 BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
- .Q
- ;now look at first and last pov
- S Y="BDM("
- S X=P_"^LAST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- K BDM S X=P_"^FIRST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- Q
- MS(P,BDMRET) ;EP
- K BDMRET
- NEW BDMC,BDM
- S BDMC=0
- K BDM
- ;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 BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
- .Q
- ;now look at first and last pov
- S Y="BDM("
- S X=P_"^LAST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- K BDM S X=P_"^FIRST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- Q
- ABNG(P,BDMRET) ;EP
- K BDMRET
- NEW BDMC
- S BDMC=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 BDMC=BDMC+1,BDMRET(BDMC)="Problem List: "_I_" Date of Onset: "_$$VAL^XBDIQ1(9000011,X,.13)
- .Q
- ;now look at first and last pov
- S Y="BDM("
- S X=P_"^LAST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="Last POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- K BDM S X=P_"^FIRST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT S E=$$START1^APCLDF(X,Y)
- I $D(BDM(1)) S BDMC=BDMC+1,BDMRET(BDMC)="First POV in PCC: "_$P(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($P(BDM(1),U))
- Q
- BDMP413 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
- +1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
- +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,BDM,E,BDML,BDMLL,BDMV
- +3 SET BDMLL=0
- SET BDMV=""
- +4 KILL BDM
- +5 SET X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(X,"BDM(")
- +6 SET BDML=0
- FOR
- SET BDML=$ORDER(BDM(BDML))
- IF BDML'=+BDML!(BDMLL=3)
- QUIT
- SET BDMBP=$PIECE($GET(BDM(BDML)),U,2)
- Begin DoDot:1
- +7 IF $$CLINIC^APCLV($PIECE(BDM(BDML),U,5),"C")=30
- QUIT
- +8 SET BDMLL=BDMLL+1
- +9 IF F="E"
- SET $PIECE(BDMV,";",BDMLL)=BDMBP_" "_$$FMTE^XLFDT($PIECE(BDM(BDML),U))
- +10 IF F="I"
- SET $PIECE(BDMV,";",BDMLL)=$PIECE(BDMBP," ")
- End DoDot:1
- +11 QUIT BDMV
- HTNDX(P,EDATE) ;EP - is HTN on problem list
- +1 IF '$GET(P)
- QUIT ""
- +2 IF '$DATA(^DPT(P))
- QUIT ""
- +3 NEW %,BDM,E
- +4 KILL BDM
- +5 SET %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES"
- SET E=$$START1^APCLDF(%,"BDM(")
- +6 IF $DATA(BDM(1))
- QUIT "Yes"
- +7 KILL BDM
- +8 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
- SET E=$$START1^APCLDF(X,"BDM(")
- IF $DATA(BDM(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 %,BDMARRY,H,E,W
- +5 SET %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
- NEW X
- SET E=$$START1^APCLDF(%,"BDMARRY(")
- SET H=$PIECE($GET(BDMARRY(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(BDMARRY(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 %,BDMARRY,H,E,W
- +6 SET %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE
- NEW X
- SET E=$$START1^APCLDF(%,"BDMARRY(")
- SET H=$PIECE($GET(BDMARRY(1)),U,2)
- +7 QUIT H_" "_$$FMTE^XLFDT($PIECE($GET(BDMARRY(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 %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,W,H,BDMC
- +5 NEW BDMV221
- SET BDMV221=$ORDER(^ICD9("BA","V22.1 ",""))
- +6 KILL BDM
- SET BDMW=""
- SET BDMX=P_"^LAST 30 MEAS WT;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(BDMX,"BDM(")
- +7 SET BDMC=0
- SET BDMN=0
- FOR
- SET BDMN=$ORDER(BDM(BDMN))
- IF BDMN'=+BDMN!(BDMC>2)
- QUIT
- Begin DoDot:1
- +8 SET BDMZ=$PIECE(BDM(BDMN),U,5)
- +9 IF '$DATA(^AUPNVPOV("AD",BDMZ))
- SET BDMC=BDMC+1
- SET BDMW=BDMW_"|"_$PIECE(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(BDM(BDMN),U))
- QUIT
- +10 SET BDMD=0
- FOR
- SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
- IF 'BDMD!(BDMW]"")
- QUIT
- Begin DoDot:2
- +11 IF $PIECE(^AUPNVPOV(BDMD,0),U)'=BDMV221
- SET BDMC=BDMC+1
- SET BDMW=BDMW_"|"_$PIECE(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(BDM(BDMN),U))
- +12 QUIT
- End DoDot:2
- End DoDot:1
- +13 QUIT $SELECT(F="E":BDMW,1:+BDMW)
- 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,BDM,Y
- +4 SET Y="BDM("
- +5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
- SET E=$$START1^APCLDF(X,Y)
- SET Y=$PIECE($GET(BDM(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,BDM,Y
- +3 SET Y="BDM("
- +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(BDM(1))
- QUIT "Type 2"
- +6 KILL BDM
- 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(BDM(1))
- QUIT "Type 1"
- +8 QUIT ""
- +9 ;
- IFG(P,BDMRET) ;EP
- +1 KILL BDMRET
- +2 NEW BDMC,BDM
- +3 SET BDMC=0
- +4 KILL BDM
- +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 BDMC=BDMC+1
- SET BDMRET(BDMC)="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="BDM("
- +17 SET X=P_"^LAST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +18 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="Last POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +19 KILL BDM
- SET X=P_"^FIRST DX 790.21;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +20 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="First POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +21 QUIT
- IGT(P,BDMRET) ;EP
- +1 KILL BDMRET
- +2 NEW BDMC,BDM
- +3 SET BDMC=0
- +4 KILL BDM
- +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 BDMC=BDMC+1
- SET BDMRET(BDMC)="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="BDM("
- +17 SET X=P_"^LAST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +18 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="Last POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +19 KILL BDM
- SET X=P_"^FIRST DX 790.22;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +20 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="First POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +21 QUIT
- MS(P,BDMRET) ;EP
- +1 KILL BDMRET
- +2 NEW BDMC,BDM
- +3 SET BDMC=0
- +4 KILL BDM
- +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 BDMC=BDMC+1
- SET BDMRET(BDMC)="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="BDM("
- +17 SET X=P_"^LAST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +18 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="Last POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +19 KILL BDM
- SET X=P_"^FIRST DX 277.7;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +20 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="First POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +21 QUIT
- ABNG(P,BDMRET) ;EP
- +1 KILL BDMRET
- +2 NEW BDMC
- +3 SET BDMC=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 BDMC=BDMC+1
- SET BDMRET(BDMC)="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="BDM("
- +16 SET X=P_"^LAST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +17 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="Last POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +18 KILL BDM
- SET X=P_"^FIRST DX 790.29;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_DT
- SET E=$$START1^APCLDF(X,Y)
- +19 IF $DATA(BDM(1))
- SET BDMC=BDMC+1
- SET BDMRET(BDMC)="First POV in PCC: "_$PIECE(BDM(1),U,2)_" Date: "_$$FMTE^XLFDT($PIECE(BDM(1),U))
- +20 QUIT