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

APCLAP41.m

Go to the documentation of this file. 
  1. APCLAP41 ; IHS/CMI/LAB - APC REPORT PROCESS ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;
  1. START ;
  1.  S APCLBT=$H
  1.  K ^XTMP("APCLAP4",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLAP4","AVG # VISITS PER DAY")
  1.  ;
  1. V ; Run by visit date
  1.  S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1
  1.  ;
  1. END ;
  1.  S APCLET=$H
  1.  D EOJ
  1.  Q
  1. V1 ;
  1.  ;count only visits with service category of A, O, R, S
  1.  S APCLVDFN="" F  S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVSIT(APCLVDFN,0)),$P(^(0),U,9),'$P(^(0),U,11),"AORS"[$P(^(0),U,7) S APCLVREC=^(0) D PROC,EOJ
  1.  Q
  1. PROC ;
  1.  ;K APCLSKIP
  1.  ;Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))  ;LAB/TUCSON CHANGED CV TO C FOR VA USE
  1.  Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
  1.  I $$CHKLOC^APCLOCCK(APCLLOC,$P(APCLVREC,U,6))=0 Q
  1.  ;Q:'$D(^AUPNVPOV("AD",APCLVDFN))
  1.  ;Q:'$D(^AUPNVPRV("AD",APCLVDFN))
  1.  S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
  1.  S APCLCLIN=$P(APCLVREC,U,8)
  1.  I APCLCLIN]"",$D(APCLCLNT),'$D(APCLCLNT(APCLCLIN)) Q
  1.  Q:'$$APCWL^APCLV(APCLVDFN)
  1.  I APCLCLIN="" S APCLCLIN=9999
  1. CHKCL ;
  1.  ;convert dental with med to pharmacy clinic
  1.  ;G:$G(DUZ("AG"))["V" PROC1
  1.  ;S X=$S(APCLCLIN="":"",$D(^DIC(40.7,APCLCLIN,0)):$P(^DIC(40.7,APCLCLIN,0),U,2),1:"")
  1.  ;I X=56,'$D(^AUPNVMED("AD",APCLVDFN)) Q
  1.  ;I X=56 S APCLCLIN=APCLRXCL
  1.  ;Q:$D(^APCLCNTL(2,11,"B",X))
  1.  ;
  1. PROC1 ;
  1.  ;S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1,APCLAP=$P(^(0),U)
  1.  ;Q:APCL1'=1
  1.  ;S APCLDISC="" D CHKDISC
  1.  ;Q:$D(APCLSKIP)
  1.  ;S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,"")) Q:'$D(^AUPNVPOV(APCLPPOV))
  1.  ;S (APCLX,APCLICD)=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)
  1.  ;Q:APCLX=".9999"
  1.  D DATE
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP4",APCLJOB,APCLBTH,"VISITS DOW",APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  I '$D(^XTMP("APCLAP4",APCLJOB,APCLBTH,"DOW DATE",APCLDATE)) S ^XTMP("APCLAP4",APCLJOB,APCLBTH,"DOW DATE",APCLDATE)="",^(APCLSRT2)=$S($D(^XTMP("APCLAP4",APCLJOB,APCLBTH,"DOW #",APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q
  1. EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ,APCLLOCC
  1.  Q
  1.  ;
  1. CHKDISC ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 G CHKDISC6
  1.  S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN" S APCLDISC="??" Q
  1.  S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
  1.  I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
  1.  Q
  1.  ;
  1. CHKDISC6 ;
  1.  I '$D(^DIC(6,APCLAP)) S APCLSKIP=1 Q
  1.  S APCLY=$P(^DIC(6,APCLAP,0),U,4)
  1.  I APCLY="" S APCLDISC="??" Q
  1.  I '$D(^DIC(7,APCLY,9999999)) S APCLDISC="??" Q
  1.  S APCLDISC=$P(^DIC(7,APCLY,9999999),U) I APCLDISC="" S APCLDISC="??" Q
  1.  S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
  1.  I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
  1.  Q
  1.  ;
  1. DATE ;
  1.  S APCLDATE=$P(APCLODAT,".")
  1.  S X=APCLDATE D H^%DTC S APCLSRT2=$P("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1) I APCLSRT2="" S APCLSRT2="UNKNOWN"
  1.  Q