Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLD71B

APCLD71B.m

Go to the documentation of this file. 
  1. APCLD71B ; IHS/CMI/LAB - get dm audit values ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1. TD(P,EDATE) ;EP
  1.  NEW APCL,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,T
  1.  K TDD
  1.  S %DT="P",X=EDATE D ^%DT S E=Y  ;set E = ending date in fm format
  1.  S B=$$FMADD^XLFDT(E,-3653)  ;b is 10 years back from end date in fm format
  1.  I '$$BI D LASTTDO ;pre v7
  1.  I $$BI D LASTTDN ;get td from v imm
  1.  S LTD=$O(TDD(0))
  1.  I LTD]"" S LTD=9999999-LTD
  1.  ;now check cpt codes
  1.  S T=$O(^ATXAX("B","DM AUDIT TD CPTS",0))
  1.  K C I T S C=$$CPT^APCLD712(P,B,E,T,3) D
  1.  .I C="" Q
  1.  .Q:LTD>$P(C,U)
  1.  .S LTD=$P(C,U)
  1.  I LTD]"" Q "Yes - "_$$FMTE^XLFDT(LTD)
  1.  S C=$$FMTE^XLFDT(B) ;external form of beginning date
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:9,1:"02"),0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:1,1:"03"),0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:28,1:34),0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:20,1:42),0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:35,1:04),0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  I '$$BI Q "No"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",22,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",50,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",106,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",107,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",110,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",113,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1.  S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",115,0)),C,EDATE)
  1.  I G,$P(G,U,2)'="N" Q "Refused"
  1.  I G Q "No - Not Medically Indicated"
  1. TDBI ;
  1.  S G="" F Z=1,9,20,22,28,35,50,106,107,110.113,115 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
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:D=""
  1.  .Q:D<B
  1.  .Q:D>E
  1.  .S G=1
  1.  I G Q "Refused"
  1.  Q "No"
  1.  ;
  1. LASTTDN ;
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
  1.  .Q:'$D(^AUTTIMM(Y,0))
  1.  .S Y=$P(^AUTTIMM(Y,0),U,3)
  1.  .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1.  .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1.  .I D<B Q  ;too early
  1.  .I D>E Q  ;after time frame
  1.  .I Y=1 S TDD(9999999-D)="" Q
  1.  .I Y=9 S TDD(9999999-D)="" Q
  1.  .I Y=20 S TDD(9999999-D)="" Q
  1.  .I Y=22 S TDD(9999999-D)="" Q
  1.  .I Y=28 S TDD(9999999-D)="" Q
  1.  .I Y=35 S TDD(9999999-D)="" Q
  1.  .I Y=50 S TDD(9999999-D)="" Q
  1.  .I Y=106 S TDD(9999999-D)="" Q
  1.  .I Y=107 S TDD(9999999-D)="" Q
  1.  .I Y=110 S TDD(9999999-D)="" Q
  1.  .I Y=113 S TDD(9999999-D)="" Q
  1.  .I Y=115 S TDD(9999999-D)="" Q
  1.  Q
  1.  ;;
  1. LASTTDO ;
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
  1.  .S Y=$P(^AUTTIMM(Y,0),U,3)
  1.  .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1.  .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1.  .I Y="04" S TDD(9999999-D)="" Q
  1.  .I Y=42 S TDD(9999999-D)="" Q
  1.  .I Y=34 S TDD(9999999-D)="" Q
  1.  .I Y="03" S TDD(9999999-D)="" Q
  1.  .I Y="02" S TDD(9999999-D)="" Q
  1.  Q
  1. BI() ;
  1.  Q $S($O(^AUTTIMM(0))>100:1,1:0)