APCLAP71.m

APCLAP71 ; IHS/CMI/LAB - APC REPORT PROCESS ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;To tally average number of visits per day of week by clinic

 ;

START ;

 S APCLBT=$H

 K ^XTMP("APCLAP7",APCLJOB,APCLBTH)

 D XTMP^APCLOSUT("APCLAP7","PCC - AVG VISITS BY DAY")

 ;

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),"AORS"[$P(^(0),U,7) S APCLVREC=^(0) D PROC,EOJ

 Q

PROC ;

 ;K APCLSKIP

 ;Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))

 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:'$D(^AUPNVPOV("AD",APCLVDFN))

 ;Q:'$D(^AUPNVPRV("AD",APCLVDFN))

 S APCLCLIN=$P(APCLVREC,U,8)

 Q:APCLCLIN=""

 S APCLCNAM=$P(^DIC(40.7,APCLCLIN,0),U)

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'=1

 Q:'$$APCWL^APCLV(APCLVDFN)

 ;S APCLDISC="" D CHKDISC

 ;Q:$D(APCLSKIP)

 ;S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,"")) Q:'$D(^AUPNVPOV(APCLPPOV))

 ;S (APCLX,APCLICD)=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)

 ;Q:APCLX=".9999"

 D DATE

 S ^(APCLSRT2)=$S($D(^XTMP("APCLAP7",APCLJOB,APCLBTH,"VISITS DOW",APCLCNAM,APCLSRT2)):^(APCLSRT2)+1,1:1)

 I '$D(^XTMP("APCLAP7",APCLJOB,APCLBTH,"DOW DATE",APCLCNAM,APCLDATE)) D

 .S ^XTMP("APCLAP7",APCLJOB,APCLBTH,"DOW DATE",APCLCNAM,APCLDATE)="",^(APCLSRT2)=$S($D(^XTMP("APCLAP7",APCLJOB,APCLBTH,"DOW #",APCLCNAM,APCLSRT2)):^(APCLSRT2)+1,1:1)

 Q

EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ,APCLLOCC

 Q

 ;

CHKDISC ;

 I $P(^DD(9000010.06,.01,0),U,2)[6 G CHKDISC6

 S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN" 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

 ;

DATE ;

 S APCLDATE=$P(APCLODAT,".")

 S X=APCLDATE D H^%DTC S APCLSRT2=$P("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1) I APCLSRT2="" S APCLSRT2="UNKNOWN"

 ;S X=APCLDATE D H^%DTC S APCLSRT2=%Y+1

 Q

APCLAP71  ; IHS/CMI/LAB - APC REPORT PROCESS ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;To tally average number of visits per day of week by clinic

 +3       ;

START     ;

 +1        SET APCLBT=$HOROLOG

 +2        KILL ^XTMP("APCLAP7",APCLJOB,APCLBTH)

 +3        DO XTMP^APCLOSUT("APCLAP7","PCC - AVG VISITS BY DAY")

 +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 "AORS"[$PIECE(^(0),U,7)

                               SET APCLVREC=^(0)

                               DO PROC

                               DO EOJ

 +3        QUIT 

PROC      ;

 +1       ;K APCLSKIP

 +2       ;Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))

 +3        IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))

               QUIT 

 +4        IF $$CHKLOC^APCLOCCK(APCLLOC,$PIECE(APCLVREC,U,6))=0

               QUIT 

 +5        SET APCLVLOC=$PIECE(APCLVREC,U,6)

 +6       ;Q:'$D(^AUPNVPOV("AD",APCLVDFN))

 +7       ;Q:'$D(^AUPNVPRV("AD",APCLVDFN))

 +8        SET APCLCLIN=$PIECE(APCLVREC,U,8)

 +9        IF APCLCLIN=""

               QUIT 

 +10       SET APCLCNAM=$PIECE(^DIC(40.7,APCLCLIN,0),U)

PROC1     ;

 +1       ;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)

 +2       ;Q:APCL1'=1

 +3        IF '$$APCWL^APCLV(APCLVDFN)

               QUIT 

 +4       ;S APCLDISC="" D CHKDISC

 +5       ;Q:$D(APCLSKIP)

 +6       ;S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,"")) Q:'$D(^AUPNVPOV(APCLPPOV))

 +7       ;S (APCLX,APCLICD)=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)

 +8       ;Q:APCLX=".9999"

 +9        DO DATE

 +10       SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP7",APCLJOB,APCLBTH,"VISITS DOW",APCLCNAM,APCLSRT2)):^(APCLSRT2)+1,1:1)

 +11       IF '$DATA(^XTMP("APCLAP7",APCLJOB,APCLBTH,"DOW DATE",APCLCNAM,APCLDATE))

               Begin DoDot:1

 +12               SET ^XTMP("APCLAP7",APCLJOB,APCLBTH,"DOW DATE",APCLCNAM,APCLDATE)=""

                   SET ^(APCLSRT2)=$SELECT($DATA(^XTMP("APCLAP7",APCLJOB,APCLBTH,"DOW #",APCLCNAM,APCLSRT2)):^(APCLSRT2)+1,1:1)

               End DoDot:1

 +13       QUIT 

EOJ        KILL APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLX,APCLHIGH,APCLDX,APCLLOW,APCLICD,APCLDA1,APCLDA2,APCLY,APCLSRT2,APCLDATE,APCLPROV,APCLSEC,APCLZ,APCLLOCC

 +1        QUIT 

 +2       ;

CHKDISC   ;

 +1        IF $PIECE(^DD(9000010.06,.01,0),U,2)[6

               GOTO CHKDISC6

 +2        SET APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP)

           IF APCLDISC="UNKNOWN"

               SET APCLDISC="??"

               QUIT 

 +3        SET APCLLOCC=$EXTRACT($PIECE(^AUTTLOC(APCLVLOC,0),U,10),5,6)

 +4        IF (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC))

               SET APCLSKIP=1

 +5        QUIT 

 +6       ;

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       ;

DATE      ;

 +1        SET APCLDATE=$PIECE(APCLODAT,".")

 +2        SET X=APCLDATE

           DO H^%DTC

           SET APCLSRT2=$PIECE("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1)

           IF APCLSRT2=""

               SET APCLSRT2="UNKNOWN"

 +3       ;S X=APCLDATE D H^%DTC S APCLSRT2=%Y+1

 +4        QUIT