APCLP61B ; IHS/CMI/LAB - get dm audit values ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
TD(P,EDATE) ;EP
NEW APCL,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,T
K TDD
S %DT="P",X=EDATE D ^%DT S E=Y ;set E = ending date in fm format
S B=$$FMADD^XLFDT(E,-3653) ;b is 10 years back from end date in fm format
I '$$BI D LASTTDO ;pre v7
I $$BI D LASTTDN ;get td from v imm
S LTD=$O(TDD(0))
I LTD]"" S LTD=9999999-LTD
;now check cpt codes
S T=$O(^ATXAX("B","DM AUDIT TD CPTS",0))
K C I T S C=$$CPT^APCLP612(P,B,E,T,3) D
.I C="" Q
.Q:LTD>$P(C,U)
.S LTD=$P(C,U)
I LTD]"" Q "Yes - "_$$FMTE^XLFDT(LTD)
S C=$$FMTE^XLFDT(B) ;external form of beginning date
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:9,1:"02"),0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:1,1:"03"),0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:28,1:34),0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:20,1:42),0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:35,1:04),0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
I '$$BI Q "No"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",22,0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",50,0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",106,0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",107,0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLP617(P,9999999.14,$O(^AUTTIMM("C",110,0)),C,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
TDBI ;
S G="" F Z=1,9,20,22,28,35,50,106,107,110 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:D<B
.Q:D>E
.S G=1
I G Q "Refused"
Q "No"
;
LASTTDN ;
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=1 S TDD(9999999-D)="" Q
.I Y=9 S TDD(9999999-D)="" Q
.I Y=20 S TDD(9999999-D)="" Q
.I Y=22 S TDD(9999999-D)="" Q
.I Y=28 S TDD(9999999-D)="" Q
.I Y=35 S TDD(9999999-D)="" Q
.I Y=50 S TDD(9999999-D)="" Q
.I Y=106 S TDD(9999999-D)="" Q
.I Y=107 S TDD(9999999-D)="" Q
.I Y=110 S TDD(9999999-D)="" Q
Q
;;
LASTTDO ;
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 Y="04" S TDD(9999999-D)="" Q
.I Y=42 S TDD(9999999-D)="" Q
.I Y=34 S TDD(9999999-D)="" Q
.I Y="03" S TDD(9999999-D)="" Q
.I Y="02" S TDD(9999999-D)="" Q
Q
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
APCLP61B ; IHS/CMI/LAB - get dm audit values ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
TD(P,EDATE) ;EP
+1 NEW APCL,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,T
+2 KILL TDD
+3 ;set E = ending date in fm format
SET %DT="P"
SET X=EDATE
DO ^%DT
SET E=Y
+4 ;b is 10 years back from end date in fm format
SET B=$$FMADD^XLFDT(E,-3653)
+5 ;pre v7
IF '$$BI
DO LASTTDO
+6 ;get td from v imm
IF $$BI
DO LASTTDN
+7 SET LTD=$ORDER(TDD(0))
+8 IF LTD]""
SET LTD=9999999-LTD
+9 ;now check cpt codes
+10 SET T=$ORDER(^ATXAX("B","DM AUDIT TD CPTS",0))
+11 KILL C
IF T
SET C=$$CPT^APCLP612(P,B,E,T,3)
Begin DoDot:1
+12 IF C=""
QUIT
+13 IF LTD>$PIECE(C,U)
QUIT
+14 SET LTD=$PIECE(C,U)
End DoDot:1
+15 IF LTD]""
QUIT "Yes - "_$$FMTE^XLFDT(LTD)
+16 ;external form of beginning date
SET C=$$FMTE^XLFDT(B)
+17 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:9,1:"02"),0)),C,EDATE)
+18 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+19 IF G
QUIT "No - Not Medically Indicated"
+20 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:1,1:"03"),0)),C,EDATE)
+21 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+22 IF G
QUIT "No - Not Medically Indicated"
+23 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:28,1:34),0)),C,EDATE)
+24 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+25 IF G
QUIT "No - Not Medically Indicated"
+26 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:20,1:42),0)),C,EDATE)
+27 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+28 IF G
QUIT "No - Not Medically Indicated"
+29 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:35,1:04),0)),C,EDATE)
+30 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+31 IF G
QUIT "No - Not Medically Indicated"
+32 IF '$$BI
QUIT "No"
+33 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",22,0)),C,EDATE)
+34 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+35 IF G
QUIT "No - Not Medically Indicated"
+36 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",50,0)),C,EDATE)
+37 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+38 IF G
QUIT "No - Not Medically Indicated"
+39 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",106,0)),C,EDATE)
+40 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+41 IF G
QUIT "No - Not Medically Indicated"
+42 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",107,0)),C,EDATE)
+43 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+44 IF G
QUIT "No - Not Medically Indicated"
+45 SET G=$$REFUSAL^APCLP617(P,9999999.14,$ORDER(^AUTTIMM("C",110,0)),C,EDATE)
+46 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+47 IF G
QUIT "No - Not Medically Indicated"
TDBI ;
+1 SET G=""
FOR Z=1,9,20,22,28,35,50,106,107,110
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
+2 SET R=$PIECE(^BIPC(X,0),U,3)
+3 IF R=""
QUIT
+4 IF '$DATA(^BICONT(R,0))
QUIT
+5 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF D<B
QUIT
+9 IF D>E
QUIT
+10 SET G=1
End DoDot:1
+11 IF G
QUIT "Refused"
+12 QUIT "No"
+13 ;
LASTTDN ;
+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=1
SET TDD(9999999-D)=""
QUIT
+9 IF Y=9
SET TDD(9999999-D)=""
QUIT
+10 IF Y=20
SET TDD(9999999-D)=""
QUIT
+11 IF Y=22
SET TDD(9999999-D)=""
QUIT
+12 IF Y=28
SET TDD(9999999-D)=""
QUIT
+13 IF Y=35
SET TDD(9999999-D)=""
QUIT
+14 IF Y=50
SET TDD(9999999-D)=""
QUIT
+15 IF Y=106
SET TDD(9999999-D)=""
QUIT
+16 IF Y=107
SET TDD(9999999-D)=""
QUIT
+17 IF Y=110
SET TDD(9999999-D)=""
QUIT
End DoDot:1
+18 QUIT
+19 ;;
LASTTDO ;
+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 IF Y="04"
SET TDD(9999999-D)=""
QUIT
+7 IF Y=42
SET TDD(9999999-D)=""
QUIT
+8 IF Y=34
SET TDD(9999999-D)=""
QUIT
+9 IF Y="03"
SET TDD(9999999-D)=""
QUIT
+10 IF Y="02"
SET TDD(9999999-D)=""
QUIT
End DoDot:1
+11 QUIT
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
