APCLIPC3 ; IHS/OHPRD/TMJ - continuation of APCLIPC2 ; [ 03/19/01 9:47 AM ]
;;3.0;IHS PCC REPORTS;**7**;FEB 05, 1997
VISITS ;
K APCLGOTA,APCLGOTB,APCLSKIP,APCLLOCC
S APCLV=0 F S APCLV=$O(^AUPNVSIT("AA",APCLDFN,APCLV)) Q:APCLV'=+APCLV!($D(APCLGOTA)&($D(APCLGOTB)))!($P(APCLV,".")>APCLSDI) S APCLVD=$P(APCLV,".") D PROC
Q
PROC ;
S APCLVDFN=0 F S APCLVDFN=$O(^AUPNVSIT("AA",APCLDFN,APCLV,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN S APCLVREC=^AUPNVSIT(APCLVDFN,0) D SEEN
Q
SEEN ;determine if patient was seen in FYs
K APCLSKIP
G:$D(APCLGOTA) ALL
Q:APCLVD>APCLSDI
Q:APCLVD<APCLEDI
I APCLVFL="L",APCLSU'=$P(APCLVREC,U,6) Q
Q:$P(APCLVREC,U,7)'="H" ;Quit if Not Inpatient
Q:$P(APCLVREC,U,11)
Q:'$P(APCLVREC,U,9)
S APCLGOTA="",$P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)=$P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)+1
ALL ;
Q:$D(APCLGOTB)
Q:$P(APCLVREC,U,7)'="H" ;Quit if Not Inpatient
I APCLVFL="L",APCLSU'=$P(APCLVREC,U,6) Q
Q:$P(APCLVREC,U,11)
Q:'$P(APCLVREC,U,9)
I APCLVD>APCLSDI S APCLGOTB="" Q
Q:APCLVD<APCLEDI
S $P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,3)=$P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,3)+1
APC ;
Q:$P(APCLVREC,U,7)'="H" ;Quit if not Inpatient
Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))
Q:'$D(^AUPNVPOV("AD",APCLVDFN))
Q:'$D(^AUPNVPRV("AD",APCLVDFN))
S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
Q:'$D(^DIC(4,APCLVLOC))
Q:'$D(^AUTTLOC(APCLVLOC))
S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" G PCP
CHKCL ;
S X=$S(APCLCLIN="":"",$D(^DIC(40.7,APCLCLIN,0)):$P(^DIC(40.7,APCLCLIN,0),U,2),1:"")
Q:X=""
I X=56,'$D(^AUPNVMED("AD",APCLVDFN)) Q
I $D(^APCLCNTL(2,11,"B",X)) Q
PCP ;
S (APCL1,APCL2)=0 F I=0:0 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 DISC
Q:$D(APCLSKIP)
S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,""))
Q:$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)=".9999"
S $P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)=$P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)+1
I APCLDISC>69,APCLDISC<91,APCLDISC'=88 G PCP1
S X="P"_APCLDISC I $T(@X)="" Q
PCP1 S $P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,5)=$P(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,5)+1
Q
DISC ;
I $P(^DD(9000010.06,.01,0),U,2)[6 G DISC6
S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
I APCLDISC'?.N S APCLSKIP="" 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
DISC6 ;
I '$D(^DIC(6,APCLAP)) S APCLSKIP="" Q
S APCLY=$P(^DIC(6,APCLAP,0),U,4)
I APCLY="" S APCLSKIP="" Q
I '$D(^DIC(7,APCLY,9999999)) S APCLSKIP="" Q
S APCLDISC=$P(^DIC(7,APCLY,9999999),U) I APCLDISC="" S APCLSKIP="" 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
P00 ;;
P11 ;;
P16 ;;
P17 ;;
P18 ;;
P21 ;;
P41 ;;
P44 ;;
P25 ;;
P33 ;;
APCLIPC3 ; IHS/OHPRD/TMJ - continuation of APCLIPC2 ; [ 03/19/01 9:47 AM ]
+1 ;;3.0;IHS PCC REPORTS;**7**;FEB 05, 1997
VISITS ;
+1 KILL APCLGOTA,APCLGOTB,APCLSKIP,APCLLOCC
+2 SET APCLV=0
FOR
SET APCLV=$ORDER(^AUPNVSIT("AA",APCLDFN,APCLV))
IF APCLV'=+APCLV!($DATA(APCLGOTA)&($DATA(APCLGOTB)))!($PIECE(APCLV,".")>APCLSDI)
QUIT
SET APCLVD=$PIECE(APCLV,".")
DO PROC
+3 QUIT
PROC ;
+1 SET APCLVDFN=0
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("AA",APCLDFN,APCLV,APCLVDFN))
IF APCLVDFN'=+APCLVDFN
QUIT
SET APCLVREC=^AUPNVSIT(APCLVDFN,0)
DO SEEN
+2 QUIT
SEEN ;determine if patient was seen in FYs
+1 KILL APCLSKIP
+2 IF $DATA(APCLGOTA)
GOTO ALL
+3 IF APCLVD>APCLSDI
QUIT
+4 IF APCLVD<APCLEDI
QUIT
+5 IF APCLVFL="L"
IF APCLSU'=$PIECE(APCLVREC,U,6)
QUIT
+6 ;Quit if Not Inpatient
IF $PIECE(APCLVREC,U,7)'="H"
QUIT
+7 IF $PIECE(APCLVREC,U,11)
QUIT
+8 IF '$PIECE(APCLVREC,U,9)
QUIT
+9 SET APCLGOTA=""
SET $PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)=$PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)+1
ALL ;
+1 IF $DATA(APCLGOTB)
QUIT
+2 ;Quit if Not Inpatient
IF $PIECE(APCLVREC,U,7)'="H"
QUIT
+3 IF APCLVFL="L"
IF APCLSU'=$PIECE(APCLVREC,U,6)
QUIT
+4 IF $PIECE(APCLVREC,U,11)
QUIT
+5 IF '$PIECE(APCLVREC,U,9)
QUIT
+6 IF APCLVD>APCLSDI
SET APCLGOTB=""
QUIT
+7 IF APCLVD<APCLEDI
QUIT
+8 SET $PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,3)=$PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,3)+1
APC ;
+1 ;Quit if not Inpatient
IF $PIECE(APCLVREC,U,7)'="H"
QUIT
+2 IF $DATA(^APCLCNTL(4,11,"B",$PIECE(APCLVREC,U,3)))
QUIT
+3 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
QUIT
+4 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
QUIT
+5 SET APCLVLOC=$PIECE(APCLVREC,U,6)
IF APCLVLOC=""
QUIT
+6 IF '$DATA(^DIC(4,APCLVLOC))
QUIT
+7 IF '$DATA(^AUTTLOC(APCLVLOC))
QUIT
+8 SET APCLCLIN=$PIECE(APCLVREC,U,8)
IF APCLCLIN=""
GOTO PCP
CHKCL ;
+1 SET X=$SELECT(APCLCLIN="":"",$DATA(^DIC(40.7,APCLCLIN,0)):$PIECE(^DIC(40.7,APCLCLIN,0),U,2),1:"")
+2 IF X=""
QUIT
+3 IF X=56
IF '$DATA(^AUPNVMED("AD",APCLVDFN))
QUIT
+4 IF $DATA(^APCLCNTL(2,11,"B",X))
QUIT
PCP ;
+1 SET (APCL1,APCL2)=0
FOR I=0:0
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)
+2 IF APCL1=0
QUIT
+3 IF APCL1>1
QUIT
+4 SET APCLDISC=""
DO DISC
+5 IF $DATA(APCLSKIP)
QUIT
+6 SET APCLPPOV=$ORDER(^AUPNVPOV("AD",APCLVDFN,""))
+7 IF $PIECE(^ICD9($PIECE(^AUPNVPOV(APCLPPOV,0),U),0),U)=".9999"
QUIT
+8 SET $PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)=$PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)+1
+9 IF APCLDISC>69
IF APCLDISC<91
IF APCLDISC'=88
GOTO PCP1
+10 SET X="P"_APCLDISC
IF $TEXT(@X)=""
QUIT
PCP1 SET $PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,5)=$PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,5)+1
+1 QUIT
DISC ;
+1 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
GOTO DISC6
+2 SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
+3 IF APCLDISC'?.N
SET APCLSKIP=""
QUIT
+4 SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)
+5 IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))
SET APCLSKIP=1
+6 QUIT
DISC6 ;
+1 IF '$DATA(^DIC(6,APCLAP))
SET APCLSKIP=""
QUIT
+2 SET APCLY=$PIECE(^DIC(6,APCLAP,0),U,4)
+3 IF APCLY=""
SET APCLSKIP=""
QUIT
+4 IF '$DATA(^DIC(7,APCLY,9999999))
SET APCLSKIP=""
QUIT
+5 SET APCLDISC=$PIECE(^DIC(7,APCLY,9999999),U)
IF APCLDISC=""
SET APCLSKIP=""
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
P00 ;;
P11 ;;
P16 ;;
P17 ;;
P18 ;;
P21 ;;
P41 ;;
P44 ;;
P25 ;;
P33 ;;
