APCLPCT3 ; IHS/CMI/LAB - continuation of APCLPCT2 ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
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:"DXE"[$P(APCLVREC,U,7)
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:"DXE"[$P(APCLVREC,U,7)
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:"AORS"'[$P(APCLVREC,U,7)
;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 ;
Q:'$$APCWL^APCLV(APCLVDFN)
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
S D=$$PRIMPROV^APCLV(APCLVDFN,"F")
I D="" Q
I 'D Q
Q:$P(^DIC(7,D,9999999),U,3)'="Y"
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 ;;
APCLPCT3 ; IHS/CMI/LAB - continuation of APCLPCT2 ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
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 IF "DXE"[$PIECE(APCLVREC,U,7)
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 IF "DXE"[$PIECE(APCLVREC,U,7)
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 ;Q:"AORS"'[$P(APCLVREC,U,7)
+2 ;Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))
+3 ;Q:'$D(^AUPNVPOV("AD",APCLVDFN))
+4 ;Q:'$D(^AUPNVPRV("AD",APCLVDFN))
+5 SET APCLVLOC=$PIECE(APCLVREC,U,6)
IF APCLVLOC=""
QUIT
+6 IF '$DATA(^DIC(4,APCLVLOC))
QUIT
+7 IF '$DATA(^AUTTLOC(APCLVLOC))
QUIT
+8 ;S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" G PCP
CHKCL ;
+1 ;S X=$S(APCLCLIN="":"",$D(^DIC(40.7,APCLCLIN,0)):$P(^DIC(40.7,APCLCLIN,0),U,2),1:"")
+2 ;Q:X=""
+3 ;I X=56,'$D(^AUPNVMED("AD",APCLVDFN)) Q
+4 ;I $D(^APCLCNTL(2,11,"B",X)) Q
PCP ;
+1 IF '$$APCWL^APCLV(APCLVDFN)
QUIT
+2 SET $PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)=$PIECE(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)+1
+3 ;I APCLDISC>69,APCLDISC<91,APCLDISC'=88 G PCP1
+4 ;S X="P"_APCLDISC I $T(@X)="" Q
+5 SET D=$$PRIMPROV^APCLV(APCLVDFN,"F")
+6 IF D=""
QUIT
+7 IF 'D
QUIT
+8 IF $PIECE(^DIC(7,D,9999999),U,3)'="Y"
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 ;;
