APCLRX91 ; IHS/OHPRD/TMJ - RX'S DISPENSED BY DATE/TIME ; [ 08/28/00 1:42 PM ]
;;3.0;IHS PCC REPORTS;**8**;FEB 05, 1997
;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
Q
V1 ;
S APCLVIEN="" F S APCLVIEN=$O(^PSRX("AL",APCLSD,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^PSRX(APCLVIEN,0)) S APCLVREC=^(0) D PROC
Q
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
Q
;
TBEFORE ;Before 8:00 am RX's
S APCL1=APCL1+1 ; Count the RX on First Hour Type
Q
;
T0800 ;Counts for 8:00 to 9:00 RX's
S APCL2=APCL2+1 ; COUNT ANOTHER TIMEFRAME
Q
;
T0900 ;Counts 9:00 - 10:00
S APCL3=APCL3+1
Q
;
T1000 ;Counts 10:00-11:00
S APCL4=APCL4+1
Q
;
T1100 ;Counts 11:00-12:00
S APCL5=APCL5+1
Q
;
T1200 ;Counts 12:00-1:00
S APCL6=APCL6+1
Q
;
T1300 ;Counts 1:00 - 2:00
S APCL7=APCL7+1
Q
;
T1400 ;Counts 2:00 - 3:00
S APCL8=APCL8+1
Q
;
T1500 ;Counts 3:00 - 4:00
S APCL9=APCL9+1
Q
;
T1600 ;Counts 4:00 - 5:00
S APCL10=APCL10+1
Q
;
T1700 ;Counts 5:00 - 6:00
S APCL11=APCL11+1
Q
;
T1800 ;Counts 6:00 - 7:00
S APCL12=APCL12+1
Q
;
T1900 ;Counts 7:00- 8:00
S APCL13=APCL13+1
Q
;
T2000 ;Counts 8:00-9:00
S APCL14=APCL14+1
Q
;
T2100 ;Counts 9:00 - 10:00
S APCL15=APCL15+1
Q
;
T2200 ;Counts 10:00-11:00
S APCL16=APCL16+1
Q
;
TAFTER ;Counts 11:00-11:59
S APCL17=APCL17+1
Q
EOJ K APCLVLOC,APCLVREC,APCLSKIP,APCLAP,APCLDISC,APCLDPTR,APCLLOCC,APCLCLN
K X,X1,X2
Q
;
;
APCLRX91 ; IHS/OHPRD/TMJ - RX'S DISPENSED BY DATE/TIME ; [ 08/28/00 1:42 PM ]
+1 ;;3.0;IHS PCC REPORTS;**8**;FEB 05, 1997
+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 SET APCLVIEN=""
FOR
SET APCLVIEN=$ORDER(^PSRX("AL",APCLSD,APCLVIEN))
IF APCLVIEN'=+APCLVIEN
QUIT
IF $DATA(^PSRX(APCLVIEN,0))
SET APCLVREC=^(0)
DO PROC
+2 QUIT
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 ;
