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

APCLAP21.m

Go to the documentation of this file. 
  1. APCLAP21 ; IHS/CMI/LAB - All visit report process ; 08 Dec 2010  12:01 PM
  1.  ;;2.0;IHS PCC SUITE;**7,8,16**;MAY 14, 2009;Build 9
  1.  ;FIX UNDEF PER ROSS
  1. START ;
  1.  S APCLBT=$H
  1.  K ^XTMP("APCLAP2",APCLJOB,APCLBTH)
  1.  D XTMP^APCLOSUT("APCLAP2","PCC VISIT COUNTS REPORT")
  1.  ;
  1. V ; Run by visit date
  1.  S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) I APCLODAT="" S APCLET=$H Q
  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.  S APCLVDFN="" F  S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
  1.  Q
  1. PROC ;
  1.  K APCLSKIP
  1.  Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
  1.  Q:'$P(APCLVREC,U,9)
  1.  Q:$P(APCLVREC,U,11)
  1.  Q:"EDXIH"[$P(APCLVREC,U,7)
  1.  I 'APCLCRYN,$P(APCLVREC,U,7)="C" Q  ;don't want chart reviews and this is a chart review
  1.  Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))  ;lab/ohprd changed CV to C for VA use
  1.  S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
  1.  Q:'$D(^AUTTLOC(APCLVLOC))
  1.  Q:'$D(^DIC(4,APCLVLOC))
  1.  I $$CHKLOC^APCLOCCK(APCLLOC,APCLVLOC)=0 Q
  1.  Q:'$D(^AUPNVPOV("AD",APCLVDFN))
  1.  Q:'$D(^AUPNVPRV("AD",APCLVDFN))
  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.  I APCL1=0 Q
  1.  I APCL1>1 Q
  1.  S APCLDISC="" D CHKDISC
  1.  D @APCLPROC
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  I APCLPROC="ALLP" S APCLSORT="APCLSEC"
  1.  I APCLPROC="ALLDISC" S APCLSORT="APCLADIS"
  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
  1.  Q
  1.  ;
  1. CLIN ;
  1.  D CLIN^APCLAP22
  1.  Q
  1.  ;
  1. SC ;
  1.  D SC^APCLAP22
  1.  Q
  1. DATE ;
  1.  D DATE^APCLAP22
  1.  Q
  1. DISC ;
  1.  S APCLSRT2=APCLDISC
  1.  S APCLDISC=$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(APCLAP),APCLY:$P(^DIC(7,APCLY,0),U),1:"???")
  1.  Q
  1. PROV ;
  1.  S APCLPROV=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,APCLAP,0),U),1:$P(^DIC(16,APCLAP,0),U))
  1.  S APCLSRT2=$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(APCLAP),APCLY:$P($G(^DIC(7,APCLY,0)),U),1:"???")
  1.  I APCLSRT2="" S APCLSRT2="PROVIDER CLASS UNAVAILABLE" Q
  1.  Q
  1. CHKDISC ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 G CHKDISC6
  1.  I '$D(^VA(200,APCLAP)) S APCLPROV="NO PROVIDER ENTERED",APCLSRT2="NONE" Q
  1.  S APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I") I APCLDPTR=""!(APCLDPTR="UNKNOWN") S APCLDISC="???" Q
  1.  S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN"!(APCLDISC="") S APCLDISC="???" Q
  1.  Q
  1. CHKDISC6 ;
  1.  I '$D(^DIC(6,APCLAP)) S APCLPROV="NO PROVIDER ENTERED",APCLSRT2="NONE" Q
  1.  S APCLY=$P(^DIC(6,APCLAP,0),U,4)
  1.  I APCLY="" S APCLPROV="NO PROVIDER DISC ENTERED",APCLSRT2="NONE",APCLDISC="???" Q
  1.  I '$D(^DIC(7,APCLY,0)) S APCLPROV="NO PROVIDER DISC ENTERED",APCLSTR2="NONE" Q
  1.  I '$D(^DIC(7,APCLY,9999999)) S APCLPROV=$P(^DIC(7,APCLY,0),U),APCLSRT2="???" Q
  1.  S APCLDISC=$P(^DIC(7,APCLY,9999999),U) I APCLDISC="" S APCLPROV=$P(^DIC(7,APCLY,0),U),APCLSRT2="???",APCLDISC="???" Q
  1.  Q
  1.  ;
  1. LOS ;
  1.  S APCLSRT2=$P(^AUTTLOC(APCLVLOC,0),U,10)
  1.  I APCLSRT2="" S APCLSRT2="??????"
  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
  1.  S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
  1.  Q:'$D(^VA(200,APCLSEC,0))
  1.  S APCLSRT2=$$PROVCLS^XBFUNC1(APCLSEC)
  1. SETSEC1 S APCLSEC=$P(^VA(200,APCLSEC,0),U)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",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="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC61
  1.  Q:'$D(^DIC(7,APCLZ,9999999))
  1.  S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) I APCLSRT2="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC61
  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("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@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:'$D(^VA(200,APCLADIS,0))
  1.  S APCLSRT2=$$PROVCLSC^XBFUNC1(APCLADIS)
  1.  S APCLADIS=$$PROVCLS^XBFUNC1(APCLADIS)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",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 APCLSRT2="???",APCLADIS="PROVIDER DISC NOT AVAILABLE" G SETSECD1
  1.  I '$D(^DIC(7,APCLZ,9999999)) S APCLSRT2="???",APCLADIS="PROVIDER DISC NOT AVAILABLE" 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("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
  1.  Q
  1. DX ;
  1.  D DX^APCLAP22
  1.  Q