- 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 ;;
