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

APCLAP11.m

Go to the documentation of this file. 
  1. APCLAP11 ; IHS/CMI/LAB - APC REPORT PROCESS ;
  1.  ;;2.0;IHS PCC SUITE;**8,10,11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;cmi/anch/maw 9/7/2007 code set versioning in PROC
  1.  ;
  1. START ;
  1.  S APCLBT=$H
  1.  K ^XTMP("APCLAP1",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLAP1","PCC/APC VISIT REPORT")
  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),"AOS"[$P(^(0),U,7) S APCLVREC=^(0) D PROC,EOJ
  1.  Q
  1. PROC ;
  1.  Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
  1.  I $$CHKLOC^APCLOCCK(APCLLOC,$P(APCLVREC,U,6))=0 Q
  1.  S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
  1.  Q:'$$APCWL^APCLV(APCLVDFN)  ;not workload reportable
  1.  S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN=9999
  1.  S APCLY=$$PRIMPROV^APCLV(APCLVDFN,"F")
  1.  I APCLY="" S APCLDISC="??"
  1.  I APCLY S APCLDISC=$P($G(^DIC(7,APCLY,9999999)),U)
  1.  S APCLAP=$$PRIMPROV^APCLV(APCLVDFN,"I")
  1.  Q:APCLAP=""
  1.  S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,""))
  1.  ;S (APCLX,APCLICD)=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)
  1.  ;cmi/anch/maw 9/7/2007 code set versioning mods
  1.  N APCLVDT
  1.  S APCLVDT=+$P($G(^AUPNVSIT(APCLVDFN,0)),".")
  1.  ;cmi/anch/maw 9/7/2007 end of mods
  1.  S (APCLX,APCLICD)=$$VAL^XBDIQ1(9000010.07,APCLPPOV,.01)
  1.  D @APCLPROC
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  S:APCLPROC="ALLP" APCLSORT="APCLSEC"
  1.  S:APCLPROC="ALLDISC" APCLSORT="APCLADIS"
  1.  Q
  1. EOJ ;
  1.  D EOJ^APCLAP12
  1.  Q
  1.  ;
  1. CHKDISC ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 D CHKDISC6 Q  ;no file 200 conversion
  1.  I '$D(^VA(200,APCLAP)) S APCLSKIP=1 Q
  1.  S APCLY=$$PROVCLS^XBFUNC1(APCLAP,"I") I 'APCLY S APCLDISC="??" Q
  1.  S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) 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. 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. DISC ;
  1.  D DISC^APCLAP12
  1.  Q
  1.  ;
  1. CLIN ;
  1.  D CLIN^APCLAP12
  1.  Q
  1.  ;
  1. DATE ;
  1.  D DATE^APCLAP12
  1.  Q
  1. PROV ;
  1.  D PROV^APCLAP12
  1.  Q
  1. LOS ;
  1.  S APCLSRT2=$P(^AUTTLOC(APCLVLOC,0),U,10),APCLVLOC=$P(^DIC(4,APCLVLOC,0),U)
  1.  Q
  1.  ;
  1. ALLP ;
  1.  S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="S" D SETSEC
  1.  S APCLSORT="APCLPROV" D PROV
  1.  Q
  1. SETSEC ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 G SETSEC6 ;no file 200 conv
  1.  S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
  1.  Q:APCLSEC=""
  1.  Q:'$D(^VA(200,APCLSEC,0))
  1.  S APCLSRT2=$$PROVCLS^XBFUNC1(APCLSEC,"I") I 'APCLSRT2 G SETSEC1
  1.  S APCLSRT2=$P(^DIC(7,APCLSRT2,0),U)
  1. SETSEC1 S APCLSEC=$P(^VA(200,APCLSEC,0),U)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  ;S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q
  1. SETSEC6 ;
  1.  S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
  1.  Q:APCLSEC=""
  1.  Q:'$D(^DIC(16,APCLSEC,0))
  1.  S APCLZ=$P(^DIC(6,APCLSEC,0),U,4)
  1.  I APCLZ="" S APCLSRT2="DISCIPLINE NOT AVAILABLE" G SETSEC61
  1.  I '$D(^DIC(7,APCLZ,9999999)) S APCLSRT2="DISCIPLINE NOT AVAILABLE" G SETSEC1
  1.  S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) Q:APCLSRT2=""
  1.  S APCLSRT2=$P(^DIC(7,APCLZ,0),U)
  1. SETSEC61 S APCLSEC=$P(^DIC(16,APCLSEC,0),U)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q
  1. ALLDISC ;
  1.  S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="S" D SETSECD
  1.  S APCLSORT="APCLDISC" D DISC
  1.  Q
  1. SETSECD ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 G SETSECD6
  1.  S APCLADIS=$P(^AUPNVPRV(APCL2,0),U)
  1.  Q:APCLADIS=""
  1.  Q:'$D(^VA(200,APCLADIS,0))
  1.  S APCLSRT2=$$PROVCLSC^XBFUNC1(APCLADIS)
  1.  S APCLADIS=$$PROVCLS^XBFUNC1(APCLADIS)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  ;S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q
  1. SETSECD6 ;
  1.  S APCLADIS=$P(^AUPNVPRV(APCL2,0),U)
  1.  Q:APCLADIS=""
  1.  Q:'$D(^DIC(16,APCLADIS,0))
  1.  S APCLZ=$P(^DIC(6,APCLADIS,0),U,4)
  1.  I APCLZ="" S APCLADIS="DISCIPLINE NOT AVAILABLE",APCLSRT2="??" G SETSECD1
  1.  I '$D(^DIC(7,APCLZ,9999999)) S APCLADIS="DISCIPLINE NOT AVAILABLE",APCLSRT2="??" G SETSECD1
  1.  S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) Q:APCLSRT2=""
  1.  S APCLADIS=$P(^DIC(7,APCLZ,0),U)
  1. SETSECD1 S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q
  1. DX ;
  1.  D DXX^APCLAP0
  1.  Q
  1.  ;
  1. APCC ;APC CATEGORY
  1.  D DXX^APCLAP0
  1.  S APCLAPCC=$P(^AUTTRCDC($P(^AUTTRCD(APCLDA1,0),U,4),0),U)
  1.  S APCLSRT2=" "
  1.  Q
  1. CLEX ;
  1. 09 ;;
  1. 11 ;;
  1. 36 ;;
  1. 41 ;;
  1. 42 ;;
  1. 51 ;;
  1. 52 ;;
  1. 53 ;;
  1. 54 ;;
  1. 56 ;;
  1. 60  ;;
  1. 99 ;;