APCLAP11 ; IHS/CMI/LAB - APC REPORT PROCESS ;
;;2.0;IHS PCC SUITE;**8,10,11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/7/2007 code set versioning in PROC
;
START ;
S APCLBT=$H
K ^XTMP("APCLAP1",APCLJOB,APCLBTH)
D XTMP^APCLOSUT("APCLAP1","PCC/APC VISIT REPORT")
;
V ; Run by visit date
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 ;
;count only visits with service category of A, O, R, S
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
Q
PROC ;
Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
I $$CHKLOC^APCLOCCK(APCLLOC,$P(APCLVREC,U,6))=0 Q
S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
Q:'$$APCWL^APCLV(APCLVDFN) ;not workload reportable
S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN=9999
S APCLY=$$PRIMPROV^APCLV(APCLVDFN,"F")
I APCLY="" S APCLDISC="??"
I APCLY S APCLDISC=$P($G(^DIC(7,APCLY,9999999)),U)
S APCLAP=$$PRIMPROV^APCLV(APCLVDFN,"I")
Q:APCLAP=""
S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,""))
;S (APCLX,APCLICD)=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)
;cmi/anch/maw 9/7/2007 code set versioning mods
N APCLVDT
S APCLVDT=+$P($G(^AUPNVSIT(APCLVDFN,0)),".")
;cmi/anch/maw 9/7/2007 end of mods
S (APCLX,APCLICD)=$$VAL^XBDIQ1(9000010.07,APCLPPOV,.01)
D @APCLPROC
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
S:APCLPROC="ALLP" APCLSORT="APCLSEC"
S:APCLPROC="ALLDISC" APCLSORT="APCLADIS"
Q
EOJ ;
D EOJ^APCLAP12
Q
;
CHKDISC ;
I $P(^DD(9000010.06,.01,0),U,2)[6 D CHKDISC6 Q ;no file 200 conversion
I '$D(^VA(200,APCLAP)) S APCLSKIP=1 Q
S APCLY=$$PROVCLS^XBFUNC1(APCLAP,"I") I 'APCLY S APCLDISC="??" Q
S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="" S APCLDISC="??" Q
S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
Q
CHKDISC6 ;
I '$D(^DIC(6,APCLAP)) S APCLSKIP=1 Q
S APCLY=$P(^DIC(6,APCLAP,0),U,4)
I APCLY="" S APCLDISC="??" Q
I '$D(^DIC(7,APCLY,9999999)) S APCLDISC="??" Q
S APCLDISC=$P(^DIC(7,APCLY,9999999),U) I APCLDISC="" S APCLDISC="??" Q
S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
Q
;
DISC ;
D DISC^APCLAP12
Q
;
CLIN ;
D CLIN^APCLAP12
Q
;
DATE ;
D DATE^APCLAP12
Q
PROV ;
D PROV^APCLAP12
Q
LOS ;
S APCLSRT2=$P(^AUTTLOC(APCLVLOC,0),U,10),APCLVLOC=$P(^DIC(4,APCLVLOC,0),U)
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 ;no file 200 conv
S APCLSEC=$P(^AUPNVPRV(APCL2,0),U)
Q:APCLSEC=""
Q:'$D(^VA(200,APCLSEC,0))
S APCLSRT2=$$PROVCLS^XBFUNC1(APCLSEC,"I") I 'APCLSRT2 G SETSEC1
S APCLSRT2=$P(^DIC(7,APCLSRT2,0),U)
SETSEC1 S APCLSEC=$P(^VA(200,APCLSEC,0),U)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
;S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",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="DISCIPLINE NOT AVAILABLE" G SETSEC61
I '$D(^DIC(7,APCLZ,9999999)) S APCLSRT2="DISCIPLINE NOT AVAILABLE" G SETSEC1
S APCLSRT2=$P(^DIC(7,APCLZ,9999999),U) Q:APCLSRT2=""
S APCLSRT2=$P(^DIC(7,APCLZ,0),U)
SETSEC61 S APCLSEC=$P(^DIC(16,APCLSEC,0),U)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@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:APCLADIS=""
Q:'$D(^VA(200,APCLADIS,0))
S APCLSRT2=$$PROVCLSC^XBFUNC1(APCLADIS)
S APCLADIS=$$PROVCLS^XBFUNC1(APCLADIS)
S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
;S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",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 APCLADIS="DISCIPLINE NOT AVAILABLE",APCLSRT2="??" G SETSECD1
I '$D(^DIC(7,APCLZ,9999999)) S APCLADIS="DISCIPLINE NOT AVAILABLE",APCLSRT2="??" 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("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
Q
DX ;
D DXX^APCLAP0
Q
;
APCC ;APC CATEGORY
D DXX^APCLAP0
S APCLAPCC=$P(^AUTTRCDC($P(^AUTTRCD(APCLDA1,0),U,4),0),U)
S APCLSRT2=" "
Q
CLEX ;
09 ;;
11 ;;
36 ;;
41 ;;
42 ;;
51 ;;
52 ;;
53 ;;
54 ;;
56 ;;
60 ;;
99 ;;
APCLAP11 ; IHS/CMI/LAB - APC REPORT PROCESS ;
+1 ;;2.0;IHS PCC SUITE;**8,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/7/2007 code set versioning in PROC
+4 ;
START ;
+1 SET APCLBT=$HOROLOG
+2 KILL ^XTMP("APCLAP1",APCLJOB,APCLBTH)
+3 DO XTMP^APCLOSUT("APCLAP1","PCC/APC VISIT REPORT")
+4 ;
V ; Run by visit date
+1 SET APCLODAT=APCLSD_".9999"
FOR
SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
IF APCLODAT=""!((APCLODAT\1)>APCLED)
QUIT
DO V1
+2 ;
END ;
+1 SET APCLET=$HOROLOG
+2 DO EOJ
+3 QUIT
V1 ;
+1 ;count only visits with service category of A, O, R, S
+2 SET APCLVDFN=""
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))
IF APCLVDFN'=+APCLVDFN
QUIT
IF $DATA(^AUPNVSIT(APCLVDFN,0))
IF $PIECE(^(0),U,9)
IF '$PIECE(^(0),U,11)
IF "AOS"[$PIECE(^(0),U,7)
SET APCLVREC=^(0)
DO PROC
DO EOJ
+3 QUIT
PROC ;
+1 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
QUIT
+2 IF $$CHKLOC^APCLOCCK(APCLLOC,$PIECE(APCLVREC,U,6))=0
QUIT
+3 SET APCLVLOC=$PIECE(APCLVREC,U,6)
IF APCLVLOC=""
QUIT
+4 ;not workload reportable
IF '$$APCWL^APCLV(APCLVDFN)
QUIT
+5 SET APCLCLIN=$PIECE(APCLVREC,U,8)
IF APCLCLIN=""
SET APCLCLIN=9999
+6 SET APCLY=$$PRIMPROV^APCLV(APCLVDFN,"F")
+7 IF APCLY=""
SET APCLDISC="??"
+8 IF APCLY
SET APCLDISC=$PIECE($GET(^DIC(7,APCLY,9999999)),U)
+9 SET APCLAP=$$PRIMPROV^APCLV(APCLVDFN,"I")
+10 IF APCLAP=""
QUIT
+11 SET APCLPPOV=$ORDER(^AUPNVPOV("AD",APCLVDFN,""))
+12 ;S (APCLX,APCLICD)=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)
+13 ;cmi/anch/maw 9/7/2007 code set versioning mods
+14 NEW APCLVDT
+15 SET APCLVDT=+$PIECE($GET(^AUPNVSIT(APCLVDFN,0)),".")
+16 ;cmi/anch/maw 9/7/2007 end of mods
+17 SET (APCLX,APCLICD)=$$VAL^XBDIQ1(9000010.07,APCLPPOV,.01)
+18 DO @APCLPROC
+19 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+20 IF APCLPROC="ALLP"
SET APCLSORT="APCLSEC"
+21 IF APCLPROC="ALLDISC"
SET APCLSORT="APCLADIS"
+22 QUIT
EOJ ;
+1 DO EOJ^APCLAP12
+2 QUIT
+3 ;
CHKDISC ;
+1 ;no file 200 conversion
IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
DO CHKDISC6
QUIT
+2 IF '$DATA(^VA(200,APCLAP))
SET APCLSKIP=1
QUIT
+3 SET APCLY=$$PROVCLS^XBFUNC1(APCLAP,"I")
IF 'APCLY
SET APCLDISC="??"
QUIT
+4 SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
IF APCLDISC=""
SET APCLDISC="??"
QUIT
+5 SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)
+6 IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))
SET APCLSKIP=1
+7 QUIT
CHKDISC6 ;
+1 IF '$DATA(^DIC(6,APCLAP))
SET APCLSKIP=1
QUIT
+2 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
+3 IF APCLY=""
SET APCLDISC="??"
QUIT
+4 IF '$DATA(^DIC(7,APCLY,9999999))
SET APCLDISC="??"
QUIT
+5 SET APCLDISC=$PIECE(^DIC(7,APCLY,9999999),U)
IF APCLDISC=""
SET APCLDISC="??"
QUIT
+6 SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)
+7 IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))
SET APCLSKIP=1
+8 QUIT
+9 ;
DISC ;
+1 DO DISC^APCLAP12
+2 QUIT
+3 ;
CLIN ;
+1 DO CLIN^APCLAP12
+2 QUIT
+3 ;
DATE ;
+1 DO DATE^APCLAP12
+2 QUIT
PROV ;
+1 DO PROV^APCLAP12
+2 QUIT
LOS ;
+1 SET APCLSRT2=$PIECE(^AUTTLOC(APCLVLOC,0),U,10)
SET APCLVLOC=$PIECE(^DIC(4,APCLVLOC,0),U)
+2 QUIT
+3 ;
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 ;no file 200 conv
IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
GOTO SETSEC6
+2 SET APCLSEC=$PIECE(^AUPNVPRV(APCL2,0),U)
+3 IF APCLSEC=""
QUIT
+4 IF '$DATA(^VA(200,APCLSEC,0))
QUIT
+5 SET APCLSRT2=$$PROVCLS^XBFUNC1(APCLSEC,"I")
IF 'APCLSRT2
GOTO SETSEC1
+6 SET APCLSRT2=$PIECE(^DIC(7,APCLSRT2,0),U)
SETSEC1 SET APCLSEC=$PIECE(^VA(200,APCLSEC,0),U)
+1 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+2 ;S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",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="DISCIPLINE NOT AVAILABLE"
GOTO SETSEC61
+6 IF '$DATA(^DIC(7,APCLZ,9999999))
SET APCLSRT2="DISCIPLINE NOT AVAILABLE"
GOTO SETSEC1
+7 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,9999999),U)
IF APCLSRT2=""
QUIT
+8 SET APCLSRT2=$PIECE(^DIC(7,APCLZ,0),U)
SETSEC61 SET APCLSEC=$PIECE(^DIC(16,APCLSEC,0),U)
+1 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP1",APCLJOB,APCLBTH,@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 APCLADIS=""
QUIT
+4 IF '$DATA(^VA(200,APCLADIS,0))
QUIT
+5 SET APCLSRT2=$$PROVCLSC^XBFUNC1(APCLADIS)
+6 SET APCLADIS=$$PROVCLS^XBFUNC1(APCLADIS)
+7 SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+8 ;S ^(APCLSRT2)=$S($D(^XTMP("APCLAP1",APCLJOB,APCLBTH,"ALLLOC",@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+9 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 APCLADIS="DISCIPLINE NOT AVAILABLE"
SET APCLSRT2="??"
GOTO SETSECD1
+6 IF '$DATA(^DIC(7,APCLZ,9999999))
SET APCLADIS="DISCIPLINE NOT AVAILABLE"
SET APCLSRT2="??"
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("APCLAP1",APCLJOB,APCLBTH,@APCLSORT,APCLSRT2)):^(APCLSRT2)+1,1:1)
+1 QUIT
DX ;
+1 DO DXX^APCLAP0
+2 QUIT
+3 ;
APCC ;APC CATEGORY
+1 DO DXX^APCLAP0
+2 SET APCLAPCC=$PIECE(^AUTTRCDC($PIECE(^AUTTRCD(APCLDA1,0),U,4),0),U)
+3 SET APCLSRT2=" "
+4 QUIT
CLEX ;
09 ;;
11 ;;
36 ;;
41 ;;
42 ;;
51 ;;
52 ;;
53 ;;
54 ;;
56 ;;
60 ;;
99 ;;
