- APCLAA1 ; IHS/CMI/LAB - Process APC 1A report ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;CMI/TUCSON/LAB - patch 3 FY fix
- START ;
- S APCLBT=$H,APCLJOB=$J
- K ^XTMP("APCLAA",APCLJOB,APCLBT)
- D XTMP^APCLOSUT("APCLAA","PCC VISITS BY PROV DISC")
- ;beginning Y2K fix
- ;S X1=APCLFY,X2=-1 D C^%DTC S APCLSD=X S X1=APCLFY,X2=365 D C^%DTC S APCLFYE=$E(X,1,3)_"0930" ;Y2000
- ;end Y2K
- V ; Run by visit date
- S APCLGRAN=0
- S APCLSD=APCLSD_".9999" F S APCLSD=$O(^AUPNVSIT("B",APCLSD)) Q:APCLSD=""!((APCLSD\1)>APCLFYE) D V1
- ;
- XIT ;
- D EOJ
- S APCLET=$H
- Q
- V1 ;
- S APCLVDFN="" F S APCLVDFN=$O(^AUPNVSIT("B",APCLSD,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
- Q
- PROC ;
- K APCLSKIP
- Q:'$P(APCLVREC,U,9)
- Q:$P(APCLVREC,U,11)
- Q:"EHI"[$P(APCLVREC,U,7)
- Q:"CV"[$P(APCLVREC,U,3)
- I APCLLOC]"",APCLLOC'=$P(APCLVREC,U,6) Q
- S DFN=$P(APCLVREC,U,5)
- Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO)) ;IHS/CMI/LAB - all demo patients
- Q:'$D(^AUPNVPOV("AD",APCLVDFN))
- Q:'$D(^AUPNVPRV("AD",APCLVDFN))
- S APCLVLOC=$P(APCLVREC,U,6)
- Q:'$D(^DIC(4,APCLVLOC))
- Q:'$D(^AUTTLOC(APCLVLOC))
- ;
- PROC1 ;
- 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)
- Q:APCL1=0
- Q:APCL1>1
- S APCLDISC="" D CHKDISC
- Q:$D(APCLSKIP)
- S APCLMOS=+$E(APCLSD,4,5)
- S ^(APCLMOS)=$S($D(^XTMP("APCLAA",APCLJOB,APCLBT,"MODISC",APCLDPTR,APCLMOS)):^(APCLMOS)+1,1:1)
- S ^(APCLDPTR)=$S($D(^XTMP("APCLAA",APCLJOB,APCLBT,"DISCTOT",APCLDPTR)):^(APCLDPTR)+1,1:1)
- S APCLGRAN=APCLGRAN+1
- Q
- EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN
- K X,X1,X2
- Q
- ;
- CHKDISC ;
- I $P(^DD(9000010.06,.01,0),U,2)[200 D CHKDISC2 Q ;FILE 200 CONV
- I '$D(^DIC(6,APCLAP)) S APCLSKIP=1 Q
- S APCLDPTR=$P(^DIC(6,APCLAP,0),U,4)
- I APCLDPTR="" S APCLDISC="??",APCLDPTR="??" Q
- I '$D(^DIC(7,APCLDPTR,9999999)) S APCLDISC="??" Q
- S APCLDISC=$P(^DIC(7,APCLDPTR,9999999),U) I APCLDISC="" S APCLSKIP=1 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
- ;
- ;
- CHKDISC2 ;CHECK DISC IF CONVERTED TO FILE 200
- I '$D(^VA(200,APCLAP)) S APCLSKIP=1 Q
- S APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I") I APCLDPTR=""!(APCLDPTR="UNKNOWN") S APCLDISC="???" Q
- S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN"!(APCLDISC="") S APCLSKIP=1 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
- ;
- APCLAA1 ; IHS/CMI/LAB - Process APC 1A report ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;CMI/TUCSON/LAB - patch 3 FY fix
- START ;
- +1 SET APCLBT=$HOROLOG
- SET APCLJOB=$JOB
- +2 KILL ^XTMP("APCLAA",APCLJOB,APCLBT)
- +3 DO XTMP^APCLOSUT("APCLAA","PCC VISITS BY PROV DISC")
- +4 ;beginning Y2K fix
- +5 ;S X1=APCLFY,X2=-1 D C^%DTC S APCLSD=X S X1=APCLFY,X2=365 D C^%DTC S APCLFYE=$E(X,1,3)_"0930" ;Y2000
- +6 ;end Y2K
- V ; Run by visit date
- +1 SET APCLGRAN=0
- +2 SET APCLSD=APCLSD_".9999"
- FOR
- SET APCLSD=$ORDER(^AUPNVSIT("B",APCLSD))
- IF APCLSD=""!((APCLSD\1)>APCLFYE)
- QUIT
- DO V1
- +3 ;
- XIT ;
- +1 DO EOJ
- +2 SET APCLET=$HOROLOG
- +3 QUIT
- V1 ;
- +1 SET APCLVDFN=""
- FOR
- SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLSD,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 '$PIECE(APCLVREC,U,9)
- QUIT
- +3 IF $PIECE(APCLVREC,U,11)
- QUIT
- +4 IF "EHI"[$PIECE(APCLVREC,U,7)
- QUIT
- +5 IF "CV"[$PIECE(APCLVREC,U,3)
- QUIT
- +6 IF APCLLOC]""
- IF APCLLOC'=$PIECE(APCLVREC,U,6)
- QUIT
- +7 SET DFN=$PIECE(APCLVREC,U,5)
- +8 ;IHS/CMI/LAB - all demo patients
- IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
- QUIT
- +9 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
- QUIT
- +10 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
- QUIT
- +11 SET APCLVLOC=$PIECE(APCLVREC,U,6)
- +12 IF '$DATA(^DIC(4,APCLVLOC))
- QUIT
- +13 IF '$DATA(^AUTTLOC(APCLVLOC))
- QUIT
- +14 ;
- PROC1 ;
- +1 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)
- +2 IF APCL1=0
- QUIT
- +3 IF APCL1>1
- QUIT
- +4 SET APCLDISC=""
- DO CHKDISC
- +5 IF $DATA(APCLSKIP)
- QUIT
- +6 SET APCLMOS=+$EXTRACT(APCLSD,4,5)
- +7 SET ^(APCLMOS)=$SELECT($DATA(^XTMP("APCLAA",APCLJOB,APCLBT,"MODISC",APCLDPTR,APCLMOS)):^(APCLMOS)+1,1:1)
- +8 SET ^(APCLDPTR)=$SELECT($DATA(^XTMP("APCLAA",APCLJOB,APCLBT,"DISCTOT",APCLDPTR)):^(APCLDPTR)+1,1:1)
- +9 SET APCLGRAN=APCLGRAN+1
- +10 QUIT
- EOJ KILL APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN
- +1 KILL X,X1,X2
- +2 QUIT
- +3 ;
- CHKDISC ;
- +1 ;FILE 200 CONV
- IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
- DO CHKDISC2
- QUIT
- +2 IF '$DATA(^DIC(6,APCLAP))
- SET APCLSKIP=1
- QUIT
- +3 SET APCLDPTR=$PIECE(^DIC(6,APCLAP,0),U,4)
- +4 IF APCLDPTR=""
- SET APCLDISC="??"
- SET APCLDPTR="??"
- QUIT
- +5 IF '$DATA(^DIC(7,APCLDPTR,9999999))
- SET APCLDISC="??"
- QUIT
- +6 SET APCLDISC=$PIECE(^DIC(7,APCLDPTR,9999999),U)
- IF APCLDISC=""
- SET APCLSKIP=1
- QUIT
- +7 SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)
- +8 IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))
- SET APCLSKIP=1
- +9 QUIT
- +10 ;
- +11 ;
- CHKDISC2 ;CHECK DISC IF CONVERTED TO FILE 200
- +1 IF '$DATA(^VA(200,APCLAP))
- SET APCLSKIP=1
- QUIT
- +2 SET APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I")
- IF APCLDPTR=""!(APCLDPTR="UNKNOWN")
- SET APCLDISC="???"
- QUIT
- +3 SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)
- IF APCLDISC="UNKNOWN"!(APCLDISC="")
- SET APCLSKIP=1
- 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
- +7 ;
