Routine: APCLRX91

APCLRX91 ; IHS/CMI/LAB - RX'S DISPENSED BY DATE/TIME ;

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

 ;APCL1 = Before 8:00

 ;APCL2 = 8:00 - 8:59

 ;APCL3 = 9:00 - 9:59

 ;APCL4 = 10:00 - 10:59

 ;APCL5 11:00 - 11:59

 ;APCL6 12:00 - 12:59

 ;APCL7 1:00 - 1:159

 ;APCL8 2:00 - 2:59

 ;APCL9 3:00 - 3:59

 ;APCL10 4:00 - 4:59

 ;APCL11 5:00 - 5:59

 ;APCL12 6:00 - 6:59

 ;APCL13 7:00 - 7:59

 ;APCL14 8:00 - 8:59

 ;APCL15 9:00 - 9:59

 ;APCL16 10:00 - 10:59

 ;APCL17 11:00 - 11:59

START ;

 S APCLBT=$H,APCLJOB=$J,APCL1=0,APCL2=0,APCL3=0,APCL4=0,APCL5=0,APCL6=0,APCL7=0,APCL8=0,APCL9=0,APCLG=0,APCLGO=0,APCL10=0,APCL11=0,APCL12=0

 S APCL13=0,APCL14=0,APCL15=0,APCL16=0,APCL17=0,APCLGTOT=0

 K ^XTMP("APCLCV",APCLJOB,APCLBT)

V ; Run by visit date

 S APCLSD=APCLSD_".9999" F  S APCLSD=$O(^PSRX("AL",APCLSD)) Q:APCLSD=""!((APCLSD\1)>APCLED)  D V1

XIT ;

 D EOJ

 S APCLET=$H

V1 ;

 ;S APCLVIEN="" F  S APCLVIEN=$O(^PSRX("AL",APCLSD,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN  I $D(^PSRX(APCLVIEN,0)) S APCLVREC=^(0) D PROC

 ;Commented above line and added lines below to look at both original

 ;fills and refills....dloz 8-23-01

 S APCLVIEN="" F  S APCLVIEN=$O(^PSRX("AL",APCLSD,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN  D

 .S APCLVBZL="" F  S APCLVBZL=$O(^PSRX("AL",APCLSD,APCLVIEN,APCLVBZL)) Q:APCLVBZL=""  D

 ..I $D(^PSRX(APCLVIEN,0)) S APCLVREC=^(0)

 ..I APCLVBZL'=0 D PROC1 Q

 ..E  D PROC

PROC1 ;Captures refill release date stats

 I APCLLOC]"",APCLLOC'=$P(^PSRX(APCLVIEN,1,APCLVBZL,0),U,9) Q

 S DFN=$P(APCLVREC,U,2)

 Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))

 S APCLRXTM=$P(^PSRX(APCLVIEN,1,APCLVBZL,0),U,18)

 S APCLRXHR=$E(APCLRXTM,9,12)

 D DOCOUNT

 ;End of modifications...dloz

PROC ;

 I APCLLOC]"",APCLLOC'=$P(^PSRX(APCLVIEN,2),U,9) Q   ;Quit if not Division = 9th piece

 S DFN=$P(APCLVREC,U,2) ;Patient = 2nd piece

 Q:$P(^DPT(DFN,0),U)="DEMO,PATIENT"

HRSTART ;Start Hour Counts <8>8>9>10>11 8 hour day

 ;S APCLGTOT=APCLGTOT+1 ; Grand Total

 S APCLRXTM=$P(^PSRX(APCLVIEN,2),U,13) ; Release Date/time

 S APCLRXHR=$E(APCLRXTM,9,12) ; Military Time Extraction

DOCOUNT ;Start Count by hour

 Q:'$D(APCLRXHR)

 S APCLGTOT=APCLGTOT+1 ; GRAND TOTAL

 I APCLRXHR<"0800" D TBEFORE Q

 I APCLRXHR>"0799"&(APCLRXHR<"0900") D T0800 Q

 I APCLRXHR>"0899"&(APCLRXHR<"1000") D T0900 Q

 I APCLRXHR>"0999"&(APCLRXHR<"1100") D T1000 Q

 I APCLRXHR>"1099"&(APCLRXHR<"1200") D T1100 Q

 I APCLRXHR>"1199"&(APCLRXHR<"1300") D T1200 Q

 I APCLRXHR>"1299"&(APCLRXHR<"1400") D T1300 Q

 I APCLRXHR>"1399"&(APCLRXHR<"1500") D T1400 Q

 I APCLRXHR>"1499"&(APCLRXHR<"1600") D T1500 Q

 I APCLRXHR>"1599"&(APCLRXHR<"1700") D T1600 Q

 I APCLRXHR>"1699"&(APCLRXHR<"1800") D T1700 Q

 I APCLRXHR>"1799"&(APCLRXHR<"1900") D T1800 Q

 I APCLRXHR>"1899"&(APCLRXHR<"2000") D T1900 Q

 I APCLRXHR>"1999"&(APCLRXHR<"2100") D T2000 Q

 I APCLRXHR>"2099"&(APCLRXHR<"2200") D T2100 Q

 I APCLRXHR>"2199"&(APCLRXHR<"2300") D T2200 Q

 I APCLRXHR>"2299" D TAFTER Q

TBEFORE ;Before 8:00 am RX's

 S APCL1=APCL1+1 ; Count the RX on First Hour Type

T0800 ;Counts for 8:00 to 9:00 RX's

 S APCL2=APCL2+1 ; COUNT ANOTHER TIMEFRAME

T0900 ;Counts 9:00 - 10:00

 S APCL3=APCL3+1

T1000 ;Counts 10:00-11:00

 S APCL4=APCL4+1

T1100 ;Counts 11:00-12:00

 S APCL5=APCL5+1

T1200 ;Counts 12:00-1:00

 S APCL6=APCL6+1

T1300 ;Counts 1:00 - 2:00

 S APCL7=APCL7+1

T1400 ;Counts 2:00 - 3:00

 S APCL8=APCL8+1

T1500 ;Counts 3:00 - 4:00

 S APCL9=APCL9+1

T1600 ;Counts 4:00 - 5:00

 S APCL10=APCL10+1

T1700 ;Counts 5:00 - 6:00

 S APCL11=APCL11+1

T1800 ;Counts 6:00 - 7:00

 S APCL12=APCL12+1

T1900 ;Counts 7:00- 8:00

 S APCL13=APCL13+1

T2000 ;Counts 8:00-9:00

 S APCL14=APCL14+1

T2100 ;Counts 9:00 - 10:00

 S APCL15=APCL15+1

T2200 ;Counts 10:00-11:00

 S APCL16=APCL16+1

TAFTER ;Counts 11:00-11:59

 S APCL17=APCL17+1

EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN

 K X,X1,X2

APCLRX91  ; IHS/CMI/LAB - RX'S DISPENSED BY DATE/TIME ;

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

 +2       ;APCL1 = Before 8:00

 +3       ;APCL2 = 8:00 - 8:59

 +4       ;APCL3 = 9:00 - 9:59

 +5       ;APCL4 = 10:00 - 10:59

 +6       ;APCL5 11:00 - 11:59

 +7       ;APCL6 12:00 - 12:59

 +8       ;APCL7 1:00 - 1:159

 +9       ;APCL8 2:00 - 2:59

 +10      ;APCL9 3:00 - 3:59

 +11      ;APCL10 4:00 - 4:59

 +12      ;APCL11 5:00 - 5:59

 +13      ;APCL12 6:00 - 6:59

 +14      ;APCL13 7:00 - 7:59

 +15      ;APCL14 8:00 - 8:59

 +16      ;APCL15 9:00 - 9:59

 +17      ;APCL16 10:00 - 10:59

 +18      ;APCL17 11:00 - 11:59

 +19      ;

START     ;

 +1        SET APCLBT=$HOROLOG

           SET APCLJOB=$JOB

           SET APCL1=0

           SET APCL2=0

           SET APCL3=0

           SET APCL4=0

           SET APCL5=0

           SET APCL6=0

           SET APCL7=0

           SET APCL8=0

           SET APCL9=0

           SET APCLG=0

           SET APCLGO=0

           SET APCL10=0

           SET APCL11=0

           SET APCL12=0

 +2        SET APCL13=0

           SET APCL14=0

           SET APCL15=0

           SET APCL16=0

           SET APCL17=0

           SET APCLGTOT=0

 +3        KILL ^XTMP("APCLCV",APCLJOB,APCLBT)

V         ; Run by visit date

 +1        SET APCLSD=APCLSD_".9999"

FOR

               SET APCLSD=$ORDER(^PSRX("AL",APCLSD))

               IF APCLSD=""!((APCLSD\1)>APCLED)

                   QUIT

               DO V1

 +2       ;

XIT       ;

 +1        DO EOJ

 +2        SET APCLET=$HOROLOG

 +3        QUIT

V1        ;

 +1       ;S APCLVIEN="" F  S APCLVIEN=$O(^PSRX("AL",APCLSD,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN  I $D(^PSRX(APCLVIEN,0)) S APCLVREC=^(0) D PROC

 +2       ;

 +3       ;Commented above line and added lines below to look at both original

 +4       ;fills and refills....dloz 8-23-01

 +5       ;

 +6        SET APCLVIEN=""

FOR

               SET APCLVIEN=$ORDER(^PSRX("AL",APCLSD,APCLVIEN))

               IF APCLVIEN'=+APCLVIEN

                   QUIT

               Begin DoDot:1

 +7                SET APCLVBZL=""

FOR

                       SET APCLVBZL=$ORDER(^PSRX("AL",APCLSD,APCLVIEN,APCLVBZL))

                       IF APCLVBZL=""

                           QUIT

                       Begin DoDot:2

 +8                        IF $DATA(^PSRX(APCLVIEN,0))

                               SET APCLVREC=^(0)

 +9                        IF APCLVBZL'=0

                               DO PROC1

                               QUIT

 +10                      IF '$TEST

                               DO PROC

                       End DoDot:2

               End DoDot:1

 +11       QUIT

 +12      ;

PROC1     ;Captures refill release date stats

 +1        IF APCLLOC]""

               IF APCLLOC'=$PIECE(^PSRX(APCLVIEN,1,APCLVBZL,0),U,9)

                   QUIT

 +2        SET DFN=$PIECE(APCLVREC,U,2)

 +3        IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))

               QUIT

 +4        SET APCLRXTM=$PIECE(^PSRX(APCLVIEN,1,APCLVBZL,0),U,18)

 +5        SET APCLRXHR=$EXTRACT(APCLRXTM,9,12)

 +6        DO DOCOUNT

 +7        QUIT

 +8       ;End of modifications...dloz

PROC      ;

 +1       ;Quit if not Division = 9th piece

           IF APCLLOC]""

               IF APCLLOC'=$PIECE(^PSRX(APCLVIEN,2),U,9)

                   QUIT

 +2       ;Patient = 2nd piece

           SET DFN=$PIECE(APCLVREC,U,2)

 +3        IF $PIECE(^DPT(DFN,0),U)="DEMO,PATIENT"

               QUIT

 +4       ;

HRSTART   ;Start Hour Counts <8>8>9>10>11 8 hour day

 +1       ;S APCLGTOT=APCLGTOT+1 ; Grand Total

 +2       ; Release Date/time

           SET APCLRXTM=$PIECE(^PSRX(APCLVIEN,2),U,13)

 +3       ; Military Time Extraction

           SET APCLRXHR=$EXTRACT(APCLRXTM,9,12)

 +4       ;

DOCOUNT   ;Start Count by hour

 +1        IF '$DATA(APCLRXHR)

               QUIT

 +2       ; GRAND TOTAL

           SET APCLGTOT=APCLGTOT+1

 +3        IF APCLRXHR<"0800"

               DO TBEFORE

               QUIT

 +4        IF APCLRXHR>"0799"&(APCLRXHR<"0900")

               DO T0800

               QUIT

 +5        IF APCLRXHR>"0899"&(APCLRXHR<"1000")

               DO T0900

               QUIT

 +6        IF APCLRXHR>"0999"&(APCLRXHR<"1100")

               DO T1000

               QUIT

 +7        IF APCLRXHR>"1099"&(APCLRXHR<"1200")

               DO T1100

               QUIT

 +8        IF APCLRXHR>"1199"&(APCLRXHR<"1300")

               DO T1200

               QUIT

 +9        IF APCLRXHR>"1299"&(APCLRXHR<"1400")

               DO T1300

               QUIT

 +10       IF APCLRXHR>"1399"&(APCLRXHR<"1500")

               DO T1400

               QUIT

 +11       IF APCLRXHR>"1499"&(APCLRXHR<"1600")

               DO T1500

               QUIT

 +12       IF APCLRXHR>"1599"&(APCLRXHR<"1700")

               DO T1600

               QUIT

 +13       IF APCLRXHR>"1699"&(APCLRXHR<"1800")

               DO T1700

               QUIT

 +14       IF APCLRXHR>"1799"&(APCLRXHR<"1900")

               DO T1800

               QUIT

 +15       IF APCLRXHR>"1899"&(APCLRXHR<"2000")

               DO T1900

               QUIT

 +16       IF APCLRXHR>"1999"&(APCLRXHR<"2100")

               DO T2000

               QUIT

 +17       IF APCLRXHR>"2099"&(APCLRXHR<"2200")

               DO T2100

               QUIT

 +18       IF APCLRXHR>"2199"&(APCLRXHR<"2300")

               DO T2200

               QUIT

 +19       IF APCLRXHR>"2299"

               DO TAFTER

               QUIT

 +20       QUIT

 +21      ;

TBEFORE   ;Before 8:00 am RX's

 +1       ; Count the RX on First Hour Type

           SET APCL1=APCL1+1

 +2        QUIT

 +3       ;

T0800     ;Counts for 8:00 to 9:00 RX's

 +1       ; COUNT ANOTHER TIMEFRAME

           SET APCL2=APCL2+1

 +2        QUIT

 +3       ;

T0900     ;Counts 9:00 - 10:00

 +1        SET APCL3=APCL3+1

 +2        QUIT

 +3       ;

T1000     ;Counts 10:00-11:00

 +1        SET APCL4=APCL4+1

 +2        QUIT

 +3       ;

T1100     ;Counts 11:00-12:00

 +1        SET APCL5=APCL5+1

 +2        QUIT

 +3       ;

T1200     ;Counts 12:00-1:00

 +1        SET APCL6=APCL6+1

 +2        QUIT

 +3       ;

T1300     ;Counts 1:00 - 2:00

 +1        SET APCL7=APCL7+1

 +2        QUIT

 +3       ;

T1400     ;Counts 2:00 - 3:00

 +1        SET APCL8=APCL8+1

 +2        QUIT

 +3       ;

T1500     ;Counts 3:00 - 4:00

 +1        SET APCL9=APCL9+1

 +2        QUIT

 +3       ;

T1600     ;Counts 4:00 - 5:00

 +1        SET APCL10=APCL10+1

 +2        QUIT

 +3       ;

T1700     ;Counts 5:00 - 6:00

 +1        SET APCL11=APCL11+1

 +2        QUIT

 +3       ;

T1800     ;Counts 6:00 - 7:00

 +1        SET APCL12=APCL12+1

 +2        QUIT

 +3       ;

T1900     ;Counts 7:00- 8:00

 +1        SET APCL13=APCL13+1

 +2        QUIT

 +3       ;

T2000     ;Counts 8:00-9:00

 +1        SET APCL14=APCL14+1

 +2        QUIT

 +3       ;

T2100     ;Counts 9:00 - 10:00

 +1        SET APCL15=APCL15+1

 +2        QUIT

 +3       ;

T2200     ;Counts 10:00-11:00

 +1        SET APCL16=APCL16+1

 +2        QUIT

 +3       ;

TAFTER    ;Counts 11:00-11:59

 +1        SET APCL17=APCL17+1

 +2        QUIT

EOJ        KILL APCLVLOC,APCLVREC,APCLSKIP,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN

 +1        KILL X,X1,X2

 +2        QUIT

 +3       ;

 +4       ;

APCLRX91.m