APCLAP21 ; IHS/CMI/LAB - All visit report process ; 08 Dec 2010 12:01 PM
;;2.0;IHS PCC SUITE;**7,8,16**;MAY 14, 2009;Build 9
;FIX UNDEF PER ROSS
START ;
S APCLBT=$H
K ^XTMP("APCLAP2",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLAP2","PCC VISIT COUNTS REPORT")
;
V ; Run by visit date
S APCLODAT=$O(^AUPNVSIT("B",APCLSD)) I APCLODAT="" S APCLET=$H Q
S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D V1
;
END ;
S APCLET=$H
D EOJ
Q
V1 ;
S APCLVDFN="" F S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
Q
PROC ;
K APCLSKIP
Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
Q:'$P(APCLVREC,U,9)
Q:$P(APCLVREC,U,11)
Q:"EDXIH"[$P(APCLVREC,U,7)
I 'APCLCRYN,$P(APCLVREC,U,7)="C" Q ;don't want chart reviews and this is a chart review
Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3))) ;lab/ohprd changed CV to C for VA use
S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
Q:'$D(^AUTTLOC(APCLVLOC))
Q:'$D(^DIC(4,APCLVLOC))
I $$CHKLOC^APCLOCCK(APCLLOC,APCLVLOC)=0 Q
Q:'$D(^AUPNVPOV("AD",APCLVDFN))
Q:'$D(^AUPNVPRV("AD",APCLVDFN))
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)
I APCL1=0 Q
I APCL1>1 Q
S APCLDISC="" D CHKDISC
D @APCLPROC
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
I APCLPROC="ALLP" S APCLSORT="APCLSEC"
I APCLPROC="ALLDISC" S APCLSORT="APCLADIS"
Q
EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ
Q
;
CLIN ;
D CLIN^APCLAP22
Q
;
SC ;
D SC^APCLAP22
Q
DATE ;
D DATE^APCLAP22
Q
DISC ;
S APCLSRT2=APCLDISC
S APCLDISC=$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(APCLAP),APCLY:$P(^DIC(7,APCLY,0),U),1:"???")
Q
PROV ;
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))
S APCLSRT2=$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(APCLAP),APCLY:$P($G(^DIC(7,APCLY,0)),U),1:"???")
I APCLSRT2="" S APCLSRT2="PROVIDER CLASS UNAVAILABLE" Q
Q
CHKDISC ;
I $P(^DD(9000010.06,.01,0),U,2)[6 G CHKDISC6
I '$D(^VA(200,APCLAP)) S APCLPROV="NO PROVIDER ENTERED",APCLSRT2="NONE" Q
S APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I") I APCLDPTR=""!(APCLDPTR="UNKNOWN") S APCLDISC="???" Q
S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN"!(APCLDISC="") S APCLDISC="???" Q
Q
CHKDISC6 ;
I '$D(^DIC(6,APCLAP)) S APCLPROV="NO PROVIDER ENTERED",APCLSRT2="NONE" Q
S APCLY=$P(^DIC(6,APCLAP,0),U,4)
I APCLY="" S APCLPROV="NO PROVIDER DISC ENTERED",APCLSRT2="NONE",APCLDISC="???" Q
I '$D(^DIC(7,APCLY,0)) S APCLPROV="NO PROVIDER DISC ENTERED",APCLSTR2="NONE" Q
I '$D(^DIC(7,APCLY,9999999)) S APCLPROV=$P(^DIC(7,APCLY,0),U),APCLSRT2="???" Q
S APCLDISC=$P(^DIC(7,APCLY,9999999),U) I APCLDISC="" S APCLPROV=$P(^DIC(7,APCLY,0),U),APCLSRT2="???",APCLDISC="???" Q
Q
;
LOS ;
S APCLSRT2=$P(^AUTTLOC(APCLVLOC,0),U,10)
I APCLSRT2="" S APCLSRT2="??????"
Q
;
ALLP ;
S (APCL1,APCL2)=0 F S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2="" I $P(^AUPNVPRV(APCL2,0),U,4)="S" D SETSEC
S APCLSORT="APCLPROV" D PROV
Q
SETSEC ;
I $P(^DD(9000010.06,.01,0),U,2)[6 G SETSEC6
S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
Q:'$D(^VA(200,APCLSEC,0))
S APCLSRT2=$$PROVCLS^XBFUNC1(APCLSEC)
SETSEC1 S APCLSEC=$P(^VA(200,APCLSEC,0),U)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
Q
SETSEC6 ;
S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
Q:APCLSEC=""
Q:'$D(^DIC(16,APCLSEC,0))
S APCLZ=$P(^DIC(6,APCLSEC,0),U,4)
I APCLZ="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC61
Q:'$D(^DIC(7,APCLZ,9999999))
S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) I APCLSRT2="" S APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE" G SETSEC61
S APCLSRT2=$P(^DIC(7,APCLZ,0),U)
SETSEC61 S APCLSEC=$P(^DIC(16,APCLSEC,0),U)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
Q
ALLDISC ;
S (APCL1,APCL2)=0 F S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2="" I $P(^AUPNVPRV(APCL2,0),U,4)="S" D SETSECD
S APCLSORT="APCLDISC" D DISC
Q
SETSECD ;
I $P(^DD(9000010.06,.01,0),U,2)[6 G SETSECD6
S APCLADIS=$P(^AUPNVPRV(APCL2,0),U)
Q:'$D(^VA(200,APCLADIS,0))
S APCLSRT2=$$PROVCLSC^XBFUNC1(APCLADIS)
S APCLADIS=$$PROVCLS^XBFUNC1(APCLADIS)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
Q
SETSECD6 ;
S APCLADIS=$P(^AUPNVPRV(APCL2,0),U)
Q:APCLADIS=""
Q:'$D(^DIC(16,APCLADIS,0))
S APCLZ=$P(^DIC(6,APCLADIS,0),U,4)
I APCLZ="" S APCLSRT2="???",APCLADIS="PROVIDER DISC NOT AVAILABLE" G SETSECD1
I '$D(^DIC(7,APCLZ,9999999)) S APCLSRT2="???",APCLADIS="PROVIDER DISC NOT AVAILABLE" G SETSECD1
S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) Q:APCLSRT2=""
S APCLADIS=$P(^DIC(7,APCLZ,0),U)
SETSECD1 S ^(APCLSRT2)=$S($D(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
Q
DX ;
D DX^APCLAP22
Q
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
+2 ;FIX UNDEF PER ROSS
START ;
+1 SET APCLBT=$HOROLOG
+2 KILL ^XTMP("APCLAP2",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLAP2","PCC VISIT COUNTS REPORT")
+4 ;
V ; Run by visit date
+1 SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLSD))
IF APCLODAT=""
SET APCLET=$HOROLOG
QUIT
+2 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
DO V1
+3 ;
END ;
+1 SET APCLET=$HOROLOG
+2 DO EOJ
+3 QUIT
V1 ;
+1 SET APCLVDFN=""
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))
IF APCLVDFN'=+APCLVDFN
QUIT
IF $DATA(^AUPNVSIT(APCLVDFN,0))
SET APCLVREC=^(0)
DO PROC
DO EOJ
+2 QUIT
PROC ;
+1 KILL APCLSKIP
+2 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
QUIT
+3 IF '$PIECE(APCLVREC,U,9)
QUIT
+4 IF $PIECE(APCLVREC,U,11)
QUIT
+5 IF "EDXIH"[$PIECE(APCLVREC,U,7)
QUIT
+6 ;don't want chart reviews and this is a chart review
IF 'APCLCRYN
IF $PIECE(APCLVREC,U,7)="C"
QUIT
+7 ;lab/ohprd changed CV to C for VA use
IF $DATA(^APCLCNTL(4,11,"B",$PIECE(APCLVREC,U,3)))
QUIT
+8 SET APCLVLOC=$PIECE(APCLVREC,U,6)
IF APCLVLOC=""
QUIT
+9 IF '$DATA(^AUTTLOC(APCLVLOC))
QUIT
+10 IF '$DATA(^DIC(4,APCLVLOC))
QUIT
+11 IF $$CHKLOC^APCLOCCK(APCLLOC,APCLVLOC)=0
QUIT
+12 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
QUIT
+13 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
QUIT
+14 SET (APCL1,APCL2)=0
FOR
SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
IF APCL2=""
QUIT
IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="P"
SET APCL1=APCL1+1
SET APCLAP=$PIECE(^(0),U)
+15 IF APCL1=0
QUIT
+16 IF APCL1>1
QUIT
+17 SET APCLDISC=""
DO CHKDISC
+18 DO @APCLPROC
+19 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+20 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+21 IF APCLPROC="ALLP"
SET APCLSORT="APCLSEC"
+22 IF APCLPROC="ALLDISC"
SET APCLSORT="APCLADIS"
+23 QUIT
EOJ KILL APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ
+1 QUIT
+2 ;
CLIN ;
+1 DO CLIN^APCLAP22
+2 QUIT
+3 ;
SC ;
+1 DO SC^APCLAP22
+2 QUIT
DATE ;
+1 DO DATE^APCLAP22
+2 QUIT
DISC ;
+1 SET APCLSRT2=APCLDISC
+2 SET APCLDISC=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(APCLAP),APCLY:$PIECE(^DIC(7,APCLY,0),U),1:"???")
+3 QUIT
PROV ;
+1 SET APCLPROV=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,APCLAP,0),U),1:$PIECE(^DIC(16,APCLAP,0),U))
+2 SET APCLSRT2=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(APCLAP),APCLY:$PIECE($GET(^DIC(7,APCLY,0)),U),1:"???")
+3 IF APCLSRT2=""
SET APCLSRT2="PROVIDER CLASS UNAVAILABLE"
QUIT
+4 QUIT
CHKDISC ;
+1 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
GOTO CHKDISC6
+2 IF '$DATA(^VA(200,APCLAP))
SET APCLPROV="NO PROVIDER ENTERED"
SET APCLSRT2="NONE"
QUIT
+3 SET APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I")
IF APCLDPTR=""!(APCLDPTR="UNKNOWN")
SET APCLDISC="???"
QUIT
+4 SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
IF APCLDISC="UNKNOWN"!(APCLDISC="")
SET APCLDISC="???"
QUIT
+5 QUIT
CHKDISC6 ;
+1 IF '$DATA(^DIC(6,APCLAP))
SET APCLPROV="NO PROVIDER ENTERED"
SET APCLSRT2="NONE"
QUIT
+2 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
+3 IF APCLY=""
SET APCLPROV="NO PROVIDER DISC ENTERED"
SET APCLSRT2="NONE"
SET APCLDISC="???"
QUIT
+4 IF '$DATA(^DIC(7,APCLY,0))
SET APCLPROV="NO PROVIDER DISC ENTERED"
SET APCLSTR2="NONE"
QUIT
+5 IF '$DATA(^DIC(7,APCLY,9999999))
SET APCLPROV=$PIECE(^DIC(7,APCLY,0),U)
SET APCLSRT2="???"
QUIT
+6 SET APCLDISC=$PIECE(^DIC(7,APCLY,9999999),U)
IF APCLDISC=""
SET APCLPROV=$PIECE(^DIC(7,APCLY,0),U)
SET APCLSRT2="???"
SET APCLDISC="???"
QUIT
+7 QUIT
+8 ;
LOS ;
+1 SET APCLSRT2=$PIECE(^AUTTLOC(APCLVLOC,0),U,10)
+2 IF APCLSRT2=""
SET APCLSRT2="??????"
+3 QUIT
+4 ;
ALLP ;
+1 SET (APCL1,APCL2)=0
FOR
SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
IF APCL2=""
QUIT
IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="S"
DO SETSEC
+2 SET APCLSORT="APCLPROV"
DO PROV
+3 QUIT
SETSEC ;
+1 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
GOTO SETSEC6
+2 SET APCLSEC=$PIECE(^AUPNVPRV(APCL2,0),U)
+3 IF '$DATA(^VA(200,APCLSEC,0))
QUIT
+4 SET APCLSRT2=$$PROVCLS^XBFUNC1(APCLSEC)
SETSEC1 SET APCLSEC=$PIECE(^VA(200,APCLSEC,0),U)
+1 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+2 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+3 QUIT
SETSEC6 ;
+1 SET APCLSEC=$PIECE(^AUPNVPRV(APCL2,0),U)
+2 IF APCLSEC=""
QUIT
+3 IF '$DATA(^DIC(16,APCLSEC,0))
QUIT
+4 SET APCLZ=$PIECE(^DIC(6,APCLSEC,0),U,4)
+5 IF APCLZ=""
SET APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE"
GOTO SETSEC61
+6 IF '$DATA(^DIC(7,APCLZ,9999999))
QUIT
+7 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,9999999),U)
IF APCLSRT2=""
SET APCLSRT2="PROVIDER DISCIPLINE UNAVAILABLE"
GOTO SETSEC61
+8 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,0),U)
SETSEC61 SET APCLSEC=$PIECE(^DIC(16,APCLSEC,0),U)
+1 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+2 QUIT
ALLDISC ;
+1 SET (APCL1,APCL2)=0
FOR
SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
IF APCL2=""
QUIT
IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="S"
DO SETSECD
+2 SET APCLSORT="APCLDISC"
DO DISC
+3 QUIT
SETSECD ;
+1 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
GOTO SETSECD6
+2 SET APCLADIS=$PIECE(^AUPNVPRV(APCL2,0),U)
+3 IF '$DATA(^VA(200,APCLADIS,0))
QUIT
+4 SET APCLSRT2=$$PROVCLSC^XBFUNC1(APCLADIS)
+5 SET APCLADIS=$$PROVCLS^XBFUNC1(APCLADIS)
+6 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+7 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+8 QUIT
SETSECD6 ;
+1 SET APCLADIS=$PIECE(^AUPNVPRV(APCL2,0),U)
+2 IF APCLADIS=""
QUIT
+3 IF '$DATA(^DIC(16,APCLADIS,0))
QUIT
+4 SET APCLZ=$PIECE(^DIC(6,APCLADIS,0),U,4)
+5 IF APCLZ=""
SET APCLSRT2="???"
SET APCLADIS="PROVIDER DISC NOT AVAILABLE"
GOTO SETSECD1
+6 IF '$DATA(^DIC(7,APCLZ,9999999))
SET APCLSRT2="???"
SET APCLADIS="PROVIDER DISC NOT AVAILABLE"
GOTO SETSECD1
+7 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,9999999),U)
IF APCLSRT2=""
QUIT
+8 SET APCLADIS=$PIECE(^DIC(7,APCLZ,0),U)
SETSECD1 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP2",APCLJOB,APCLBTH,"LOCTOT",APCLVLOC,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+1 QUIT
DX ;
+1 DO DX^APCLAP22
+2 QUIT
