BDMD313.m

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

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007

 ;LORI - ADD V04,81

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in PLDMDXS

 ;

FLU(P,BDATE,EDATE) ;EP

 NEW BDM,X,E,%,%DT,BD,B,D,C,Y,LFLU,TFLU,Z,G,T

 S X=EDATE,%DT="P" D ^%DT S (BD,E)=Y

 S (B,BD)=$$FMADD^XLFDT(BD,-(15*30)),BD=$$FMTE^XLFDT(BD)

 ;B-int fm beg

 ;E-int fm end

 S LFLU="" K TFLU

 I $$BI D LASTFLUN

 I '$$BI D LASTFLUO

 S LFLU=$O(TFLU(0))

 I LFLU]"" S LFLU=9999999-LFLU

 K BDM S %=P_"^LAST DX V04.8;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LFLU>$P(BDM(1),U)

 .S LFLU=$P(BDM(1),U)

 K BDM S %=P_"^LAST DX V04.81;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LFLU>$P(BDM(1),U)

 .S LFLU=$P(BDM(1),U)

 K BDM S %=P_"^LAST DX V06.6;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LFLU>$P(BDM(1),U)

 .S LFLU=$P(BDM(1),U)

 K BDM S %=P_"^LAST PROCEDURE 99.52;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LFLU>$P(BDM(1),U)

 .S LFLU=$P(BDM(1),U)

 ;check CPT codes in year prior to date range

 S X=EDATE,%DT="P" D ^%DT S ED=Y

 S X=BD,%DT="P" D ^%DT S BD=Y

 S T=$O(^ATXAX("B","DM AUDIT FLU CPTS",0))

 K BDM I T S BDM(1)=$$CPT^BDMD312(P,BD,ED,T,3) D

 .I BDM(1)="" K BDM Q

 .Q:LFLU>$P(BDM(1),U)

 .S LFLU=$P(BDM(1),U)

 I LFLU]"" Q "Yes  "_$$FMTE^XLFDT(LFLU)

 ;

 NEW G S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:88,1:12),0)),BD,EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",15,0)),BD,EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",16,0)),BD,EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",111,0)),BD,EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 S G="" F Z=15,16,88,111 Q:G  S X=0,Y=$O(^AUTTIMM("C",Z,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q "Refused"

 Q "No"

PNEU(P,EDATE) ;EP

 NEW BDM,X,E,B,%DT,Y,TPN,D,LPN,G,C,Z,T

 K TPN

 S %DT="P",X=EDATE D ^%DT S E=Y  ;set E = ending date in fm format

 S B=$$DOB^AUPNPAT(P) ;b is DOB

 I '$$BI D LASTPNO ;pre v7

 I $$BI D LASTPNN ;get td from v imm

 S LPN=$O(TPN(0))

 I LPN]"" S LPN=9999999-LPN

 ;now check cpt codes

 S T=$O(^ATXAX("B","DM AUDIT PNEUMO CPTS",0))

 K C I T S C=$$CPT^BDMD312(P,B,E,T,3) D

 .I C="" Q

 .Q:LPN>$P(C,U)

 .S LPN=$P(C,U)

 I LPN]"" Q "Yes - "_$$FMTE^XLFDT(LPN)

 S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 I '$$BI Q "No"

 S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P,"E"),EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 S G=$$REFUSAL^BDMD317(P,9999999.14,$O(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P,"E"),EDATE)

 I G,$P(G,U,2)'="N" Q "Refused"

 I G Q "No - Not Medically Indicated"

 S X=EDATE,%DT="P" D ^%DT S E=Y

 S G="" F Z=33,100,109 Q:G  S X=0,Y=$O(^AUTTIMM("C",Z,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .Q:$P(^BIPC(X,0),U,4)>ED

 .S G=1

 I G Q "Refused"

 Q "No"

LASTFLUN ;

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

 .S Y=$P(^AUPNVIMM(X,0),U) Q:'Y

 .S Y=$P(^AUTTIMM(Y,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I D<B Q  ;too early

 .I D>E Q  ;after time frame

 .I Y=88 S TFLU(9999999-D)="" Q

 .I Y=15 S TFLU(9999999-D)="" Q

 .I Y=16 S TFLU(9999999-D)="" Q

 .I Y=111 S TFLU(9999999-D)="" Q

 Q

LASTFLUO ;

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

 .S Y=$P(^AUPNVIMM(X,0),U) Q:'Y

 .S Y=$P(^AUTTIMM(Y,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I D<B Q  ;too early

 .I D>E Q  ;after time frame

 .I Y=12 S TFLU(9999999-D)="" Q

 Q

LASTPNN ;

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

 .S Y=$P(^AUPNVIMM(X,0),U) Q:'Y

 .S Y=$P(^AUTTIMM(Y,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I D<B Q  ;too early

 .I D>E Q  ;after time frame

 .I Y=33 S TPN(9999999-D)="" Q

 .I Y=100 S TPN(9999999-D)="" Q

 .I Y=109 S TPN(9999999-D)="" Q

 Q

LASTPNO ;

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

 .S Y=$P(^AUPNVIMM(X,0),U) Q:'Y

 .S Y=$P(^AUTTIMM(Y,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I D<B Q  ;too early

 .I D>E Q  ;after time frame

 .I Y=19 S TPN(9999999-D)="" Q

 Q

BI() ;

 Q $S($O(^AUTTIMM(0))>100:1,1:0)

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))

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

 I 'P Q ""

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

 NEW %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,W,H

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

 K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")

 S BDMN=0 F  S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"")  D

 . S BDMZ=$P(BDM(BDMN),U,5)

 . I '$D(^AUPNVPOV("AD",BDMZ)) S 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 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/10/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/10/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 ""

 ;

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

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007

 +2       ;LORI - ADD V04,81

 +3       ;

 +4       ;cmi/anch/maw 9/10/2007 code set versioning in PLDMDXS

 +5       ;

FLU(P,BDATE,EDATE) ;EP

 +1        NEW BDM,X,E,%,%DT,BD,B,D,C,Y,LFLU,TFLU,Z,G,T

 +2        SET X=EDATE

           SET %DT="P"

           DO ^%DT

           SET (BD,E)=Y

 +3        SET (B,BD)=$$FMADD^XLFDT(BD,-(15*30))

           SET BD=$$FMTE^XLFDT(BD)

 +4       ;B-int fm beg

 +5       ;E-int fm end

 +6        SET LFLU=""

           KILL TFLU

 +7        IF $$BI

               DO LASTFLUN

 +8        IF '$$BI

               DO LASTFLUO

 +9        SET LFLU=$ORDER(TFLU(0))

 +10       IF LFLU]""

               SET LFLU=9999999-LFLU

 +11       KILL BDM

           SET %=P_"^LAST DX V04.8;DURING "_BD_"-"_EDATE

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

 +12       IF $DATA(BDM(1))

               Begin DoDot:1

 +13               IF LFLU>$PIECE(BDM(1),U)

                       QUIT 

 +14               SET LFLU=$PIECE(BDM(1),U)

               End DoDot:1

 +15       KILL BDM

           SET %=P_"^LAST DX V04.81;DURING "_BD_"-"_EDATE

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

 +16       IF $DATA(BDM(1))

               Begin DoDot:1

 +17               IF LFLU>$PIECE(BDM(1),U)

                       QUIT 

 +18               SET LFLU=$PIECE(BDM(1),U)

               End DoDot:1

 +19       KILL BDM

           SET %=P_"^LAST DX V06.6;DURING "_BD_"-"_EDATE

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

 +20       IF $DATA(BDM(1))

               Begin DoDot:1

 +21               IF LFLU>$PIECE(BDM(1),U)

                       QUIT 

 +22               SET LFLU=$PIECE(BDM(1),U)

               End DoDot:1

 +23       KILL BDM

           SET %=P_"^LAST PROCEDURE 99.52;DURING "_BD_"-"_EDATE

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

 +24       IF $DATA(BDM(1))

               Begin DoDot:1

 +25               IF LFLU>$PIECE(BDM(1),U)

                       QUIT 

 +26               SET LFLU=$PIECE(BDM(1),U)

               End DoDot:1

 +27      ;check CPT codes in year prior to date range

 +28       SET X=EDATE

           SET %DT="P"

           DO ^%DT

           SET ED=Y

 +29       SET X=BD

           SET %DT="P"

           DO ^%DT

           SET BD=Y

 +30       SET T=$ORDER(^ATXAX("B","DM AUDIT FLU CPTS",0))

 +31       KILL BDM

           IF T

               SET BDM(1)=$$CPT^BDMD312(P,BD,ED,T,3)

               Begin DoDot:1

 +32               IF BDM(1)=""

                       KILL BDM

                       QUIT 

 +33               IF LFLU>$PIECE(BDM(1),U)

                       QUIT 

 +34               SET LFLU=$PIECE(BDM(1),U)

               End DoDot:1

 +35       IF LFLU]""

               QUIT "Yes  "_$$FMTE^XLFDT(LFLU)

 +36      ;

 +37       NEW G

           SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:88,1:12),0)),BD,EDATE)

 +38       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +39       IF G

               QUIT "No - Not Medically Indicated"

 +40       SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",15,0)),BD,EDATE)

 +41       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +42       IF G

               QUIT "No - Not Medically Indicated"

 +43       SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",16,0)),BD,EDATE)

 +44       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +45       IF G

               QUIT "No - Not Medically Indicated"

 +46       SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",111,0)),BD,EDATE)

 +47       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +48       IF G

               QUIT "No - Not Medically Indicated"

 +49       SET G=""

           FOR Z=15,16,88,111

               IF G

                   QUIT 

               SET X=0

               SET Y=$ORDER(^AUTTIMM("C",Z,0))

               IF Y

                   FOR 

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

                       IF X'=+X!(G)

                           QUIT 

                       Begin DoDot:1

 +50                       SET R=$PIECE(^BIPC(X,0),U,3)

 +51                       IF R=""

                               QUIT 

 +52                       IF '$DATA(^BICONT(R,0))

                               QUIT 

 +53                       IF $PIECE(^BICONT(R,0),U,1)'["Refusal"

                               QUIT 

 +54                       SET D=$PIECE(^BIPC(X,0),U,4)

 +55                       IF D=""

                               QUIT 

 +56                       IF $PIECE(^BIPC(X,0),U,4)<BD

                               QUIT 

 +57                       IF $PIECE(^BIPC(X,0),U,4)>ED

                               QUIT 

 +58                       SET G=1

                       End DoDot:1

 +59       IF G

               QUIT "Refused"

 +60       QUIT "No"

PNEU(P,EDATE) ;EP

 +1        NEW BDM,X,E,B,%DT,Y,TPN,D,LPN,G,C,Z,T

 +2        KILL TPN

 +3       ;set E = ending date in fm format

           SET %DT="P"

           SET X=EDATE

           DO ^%DT

           SET E=Y

 +4       ;b is DOB

           SET B=$$DOB^AUPNPAT(P)

 +5       ;pre v7

           IF '$$BI

               DO LASTPNO

 +6       ;get td from v imm

           IF $$BI

               DO LASTPNN

 +7        SET LPN=$ORDER(TPN(0))

 +8        IF LPN]""

               SET LPN=9999999-LPN

 +9       ;now check cpt codes

 +10       SET T=$ORDER(^ATXAX("B","DM AUDIT PNEUMO CPTS",0))

 +11       KILL C

           IF T

               SET C=$$CPT^BDMD312(P,B,E,T,3)

               Begin DoDot:1

 +12               IF C=""

                       QUIT 

 +13               IF LPN>$PIECE(C,U)

                       QUIT 

 +14               SET LPN=$PIECE(C,U)

               End DoDot:1

 +15       IF LPN]""

               QUIT "Yes - "_$$FMTE^XLFDT(LPN)

 +16       SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE)

 +17       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +18       IF G

               QUIT "No - Not Medically Indicated"

 +19       IF '$$BI

               QUIT "No"

 +20       SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P,"E"),EDATE)

 +21       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +22       IF G

               QUIT "No - Not Medically Indicated"

 +23       SET G=$$REFUSAL^BDMD317(P,9999999.14,$ORDER(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P,"E"),EDATE)

 +24       IF G

               IF $PIECE(G,U,2)'="N"

                   QUIT "Refused"

 +25       IF G

               QUIT "No - Not Medically Indicated"

 +26       SET X=EDATE

           SET %DT="P"

           DO ^%DT

           SET E=Y

 +27       SET G=""

           FOR Z=33,100,109

               IF G

                   QUIT 

               SET X=0

               SET Y=$ORDER(^AUTTIMM("C",Z,0))

               IF Y

                   FOR 

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

                       IF X'=+X!(G)

                           QUIT 

                       Begin DoDot:1

 +28                       SET R=$PIECE(^BIPC(X,0),U,3)

 +29                       IF R=""

                               QUIT 

 +30                       IF '$DATA(^BICONT(R,0))

                               QUIT 

 +31                       IF $PIECE(^BICONT(R,0),U,1)'["Refusal"

                               QUIT 

 +32                       SET D=$PIECE(^BIPC(X,0),U,4)

 +33                       IF D=""

                               QUIT 

 +34                       IF $PIECE(^BIPC(X,0),U,4)>ED

                               QUIT 

 +35                       SET G=1

                       End DoDot:1

 +36       IF G

               QUIT "Refused"

 +37       QUIT "No"

LASTFLUN  ;

 +1        SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'Y

                       QUIT 

 +3                SET Y=$PIECE(^AUTTIMM(Y,0),U,3)

 +4                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT 

 +5                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +6       ;too early

                   IF D<B

                       QUIT 

 +7       ;after time frame

                   IF D>E

                       QUIT 

 +8                IF Y=88

                       SET TFLU(9999999-D)=""

                       QUIT 

 +9                IF Y=15

                       SET TFLU(9999999-D)=""

                       QUIT 

 +10               IF Y=16

                       SET TFLU(9999999-D)=""

                       QUIT 

 +11               IF Y=111

                       SET TFLU(9999999-D)=""

                       QUIT 

               End DoDot:1

 +12       QUIT 

LASTFLUO  ;

 +1        SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'Y

                       QUIT 

 +3                SET Y=$PIECE(^AUTTIMM(Y,0),U,3)

 +4                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT 

 +5                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +6       ;too early

                   IF D<B

                       QUIT 

 +7       ;after time frame

                   IF D>E

                       QUIT 

 +8                IF Y=12

                       SET TFLU(9999999-D)=""

                       QUIT 

               End DoDot:1

 +9        QUIT 

LASTPNN   ;

 +1        SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'Y

                       QUIT 

 +3                SET Y=$PIECE(^AUTTIMM(Y,0),U,3)

 +4                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT 

 +5                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")