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

APCHS9A.m

Go to the documentation of this file. 
  1. APCHS9A ; IHS/CMI/LAB - PART 9 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;cmi/anch/maw 8/27/2007 code set versioning in PVCH and SUPPCP
  1.  ;
  1. SUPP ;EP - supplements
  1.  S APCHSFO=0 F  S APCHSFO=$O(^APCHSCTL(APCHSTYP,12,"B",APCHSFO)) Q:APCHSFO'=+APCHSFO!($D(APCHSQIT))  D  Q:$D(APCHSQIT)
  1.  .S APCHSFOR=$O(^APCHSCTL(APCHSTYP,12,"B",APCHSFO,0))
  1.  .S APCHSUPI=$P(^APCHSCTL(APCHSTYP,12,APCHSFOR,0),U,2)
  1.  .Q:APCHSUPI=""
  1.  .Q:'$D(^APCHSUP(APCHSUPI))
  1.  .Q:$G(^APCHSUP(APCHSUPI,11))=""
  1.  .D SUPPCHK
  1.  .Q:'APCHSFOK
  1.  .X ^APCHSUP(APCHSUPI,11)
  1. EOJ ;
  1.  K APCHSFOK,APCHSFOR,APCHSUPI
  1.  Q
  1. SUPPCHK ; <SCREEN>
  1.  I '$O(^APCHSUP(APCHSUPI,13,0)) S APCHSFOK=1 Q
  1.  S APCHSFOK=0
  1.  ;Q:'$O(^AUPNPROB("AC",APCHSPAT,0))
  1.  F APCHSPI=0:0 S APCHSPI=$O(^AUPNPROB("AC",APCHSPAT,APCHSPI)) Q:'APCHSPI  D SUPPCP Q:APCHSFOK
  1.  Q:APCHSFOK
  1. PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
  1.  K APCHY,APCHV,^TMP($J,"ALL VISITS")
  1.  S APCHSNVN=$S($P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2):$P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,2),1:1)
  1.  S APCHSNYR=$S($P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3):$P($G(^APCHSITE(DUZ(2),11,APCHSUPI,0)),U,3),1:1)
  1.  S APCHSNYR=APCHSNYR*365
  1.  S APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
  1.  S APCHY="^TMP($J,""ALL VISITS"",",%=APCHSPAT_"^ALL VISITS;DURING "_APCHSBD_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
  1.  I '$D(^TMP($J,"ALL VISITS",1)) Q
  1.  S (X,APCHSCNT,APCHSFOK)=0 F  S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(APCHSFOK)  S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"DAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:'$D(^AUPNVPOV("AD",V))
  1.  .;cmi/anch/maw 8/27/2007 mods for code set versioning
  1.  .;S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  S APCHSCM=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCM S APCHSCM=$P($G(^ICD9(APCHSCM,0)),U) I APCHSCM]"" D CHKCODE
  1.  .N APCHSVDT
  1.  .S APCHSVDT=$P(+V,".")
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  S APCHSCMX=$P($G(^AUPNVPOV(Y,0)),U) I APCHSCMX S APCHSCM=$P($$ICDDX^ICDEX(APCHSCMX,APCHSVDT),U,2) I APCHSCM]"" D CHKCODE
  1.  .Q:'D
  1.  .;cmi/anch/maw 8/27/2007 end of mods
  1.  .;REMOVED PROVIDER CHECK PER CHRIS LAMER BY EMAIL 09/2008
  1.  .;S Y=$$PRIMPROV^APCLV(V,"F")
  1.  .;Q:'Y
  1.  .;I $P(^DIC(7,Y,9999999),U,1)=39 S APCHSFOK=1 Q
  1.  .;Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
  1.  .S APCHSCNT=APCHSCNT+1
  1.  .I APCHSCNT'<APCHSNVN S APCHSFOK=1
  1.  .Q
  1.  K ^TMP($J,"ALL VISITS"),APCHV,APCHY
  1.  Q
  1. CHKCODE ;
  1.  S D=0
  1.  F APCHSCI=0:0 S APCHSCI=$O(^APCHSUP(APCHSUPI,13,APCHSCI)) Q:'APCHSCI  D CHKCODE1 Q:D
  1.  Q
  1. CHKCODE1 ;
  1.  S D=0
  1.  S APCHSC1=$P(^APCHSUP(APCHSUPI,13,APCHSCI,0),U,1)
  1.  I $E(APCHSC1)="[" S D=$$ICD^ATXAPI(APCHSCMX,$O(^ATXAX("B",$E(APCHSC1,2,99),0)),9) Q
  1.  I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
  1.  E  S APCHSC2=APCHSC1
  1.  S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
  1.  I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S D=1
  1.  Q
  1. SUPPCP ;
  1.  S APCHSP=^AUPNPROB(APCHSPI,0) Q:$P(APCHSP,U,12)="D"
  1.  S APCHSCM=$P($$ICDDX^ICDEX(+$P(APCHSP,U)),U,2)
  1.  S APCHSCII=+$$ICDDX^ICDEX(+$P(APCHSP,U))
  1.  F APCHSCI=0:0 S APCHSCI=$O(^APCHSUP(APCHSUPI,13,APCHSCI)) Q:'APCHSCI  D SUPPCR Q:APCHSFOK
  1.  Q
  1. SUPPCR S APCHSC1=$P(^APCHSUP(APCHSUPI,13,APCHSCI,0),U)
  1.  I $E(APCHSC1)="[" S APCHSFOK=$$ICD^ATXAPI(APCHSCII,$O(^ATXAX("B",$E(APCHSC1,2,99),0)),9) Q
  1.  I APCHSC1["-" S APCHSC2=$P(APCHSC1,"-",2),APCHSC1=$P(APCHSC1,"-",1)
  1.  E  S APCHSC2=APCHSC1
  1.  S APCHSC1=APCHSC1_" ",APCHSC2=APCHSC2_" "
  1.  I APCHSC1'](APCHSCM_" "),(APCHSCM_" ")']APCHSC2 S APCHSFOK=1
  1.  Q