AQAQPR12 ;IHS/ANMC/LJF - ADMISSIONS BY PROVIDER; [ 08/06/92 4:29 PM ]
;;2.2;STAFF CREDENTIALS;;01 OCT 1992
;
;>>> initialize variables <<<
S AQAQPAGE=0,AQAQSTOP="",AQAQDUZ=$P(^DIC(3,DUZ,0),U,2)
S AQAQSITE=$P(^DIC(4,DUZ(2),0),U) ;set site
S AQAQRG=$E(AQAQBDT,4,5)_"/"_$E(AQAQBDT,6,7)_"/"_$E(AQAQBDT,2,3)_" to "
S AQAQRG=AQAQRG_$E(AQAQEDT,4,5)_"/"_$E(AQAQEDT,6,7)_"/"_$E(AQAQEDT,2,3)
S AQAQLINE="",$P(AQAQLINE,"=",80)=""
S AQAQLIN2="",$P(AQAQLIN2,"-",80)=""
S (AQAQICNT,AQAQSCNT,AQAQWCNT,AQAQTCNT,AQAQTICT,AQAQTWCT)=0
;
I '$D(^UTILITY("AQAQPR1",$J)) D HEAD W !!,">>> NO DATA FOR DATES",!! G WAIT
;
;>>> pull data by provider, then print <<<
S AQAQPRV=0
F S AQAQPRV=$O(^UTILITY("AQAQPR1",$J,AQAQPRV)) Q:AQAQPRV="" Q:AQAQSTOP=U D
.I (AQAQSCNT>0)!(AQAQICNT>0) D COUNT
.I AQAQPAGE=0 D HEAD
.E D NEWPG Q:AQAQSTOP=U
.W !!?80-$L(AQAQPRV)/2,AQAQPRV,! ;print provider subheading
.S (AQAQDT,AQAQLST)=0
.F S AQAQDT=$O(^UTILITY("AQAQPR1",$J,AQAQPRV,AQAQDT)) Q:AQAQDT="" Q:AQAQSTOP=U D
..I $E(AQAQLST,4,5)'=$E(AQAQDT)&(AQAQLST'=0) D COUNT ;if new month, get subcounts
..S DFN=0
..F S DFN=$O(^UTILITY("AQAQPR1",$J,AQAQPRV,AQAQDT,DFN)) Q:DFN="" Q:AQAQSTOP=U D
...S AQAQSTR=^(DFN) D LINE ;print line with admission data
;
;>>> do last month subcount, then print totals <<<
G END:AQAQSTOP=U
I (AQAQSCNT>0)!(AQAQICNT>0)!(AQAQWCNT>0) D COUNT
D NEWPG W !!," ADMISSIONS: ",AQAQTCNT
W !," ICU ADMISSIONS: ",AQAQTICT
W !," TOTAL ADMISSIONS: ",AQAQTCNT+AQAQTICT
W !,"NEWBORN ADMISSIONS: ",AQAQTWCT
W !,AQAQLINE
WAIT I IOST["C-" W ! K DIR S DIR(0)="E",DIR("A")="RETURN to continue" D ^DIR
;
;
END ;EP;>>> eoj <<<
W @IOF D ^%ZISC D KILL^AQAQUTIL K ^UTILITY("AQAQPR1",$J) Q
;
;>>> END OF MAIN ROUTINE <<<
;
;
NEWPG ;***> SUBRTN for end of page control
I IOST'?1"C-".E D HEAD S AQAQSTOP="" Q
I AQAQPAGE>0 K DIR S DIR(0)="E" D ^DIR S AQAQSTOP=X
I AQAQSTOP'=U D HEAD
Q
;
HEAD ;***> SUBRTN to print heading
I (IOST["C-")!(AQAQPAGE>0) W @IOF
W !,AQAQLINE S AQAQPAGE=AQAQPAGE+1
W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,AQAQDUZ,?80-$L(AQAQSITE)/2,AQAQSITE
S AQAQTY="ADMISSIONS BY PROVIDER"
W ! D ^%T W ?80-$L(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
S Y=DT X ^DD("DD") W !,Y,?30,AQAQRG ;date range
W !,AQAQLINE
W !,"Admit Date",?20,"Patient",?43,"Ward",?48,"Srv",?55,"Admitting DX"
W !,AQAQLIN2
Q
;
LINE ;***> SUBRTN to print line of data and increment counts
S Y=AQAQDT X ^DD("DD") W !,Y ;admit date/time
W ?20,$E($P(AQAQSTR,U),1,20) ;patient name
W ?43,$E($P(AQAQSTR,U,2),1,3),?48,$E($P(AQAQSTR,U,3),1,3) ;ward & srv
W ?55,$E($P(AQAQSTR,U,4),1,23) ;admitting dx
I $P(AQAQSTR,U,5)=1 S AQAQICNT=AQAQICNT+1 ;increment icu count
E I $P(AQAQSTR,U,3)="NEWBORN" S AQAQWCNT=AQAQWCNT+1 ;newborn count
E S AQAQSCNT=AQAQSCNT+1 ;increment subcount
I $Y>(IOSL-5) D NEWPG
Q
;
COUNT ;***> SUBRTN to print subcounts and increment totals
W !," Admissions: ",AQAQSCNT S AQAQTCNT=AQAQTCNT+AQAQSCNT
W !," ICU Admissions: ",AQAQICNT S AQAQTICT=AQAQTICT+AQAQICNT
W !," Total Admissions: ",AQAQICNT+AQAQSCNT
W !,"Newborn Admissions: ",AQAQWCNT S AQAQTWCT=AQAQTWCT+AQAQWCNT
W !,AQAQLINE S (AQAQSCNT,AQAQICNT,AQAQWCNT)=0
Q
AQAQPR12 ;IHS/ANMC/LJF - ADMISSIONS BY PROVIDER; [ 08/06/92 4:29 PM ]
+1 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
+2 ;
+3 ;>>> initialize variables <<<
+4 SET AQAQPAGE=0
SET AQAQSTOP=""
SET AQAQDUZ=$PIECE(^DIC(3,DUZ,0),U,2)
+5 ;set site
SET AQAQSITE=$PIECE(^DIC(4,DUZ(2),0),U)
+6 SET AQAQRG=$EXTRACT(AQAQBDT,4,5)_"/"_$EXTRACT(AQAQBDT,6,7)_"/"_$EXTRACT(AQAQBDT,2,3)_" to "
+7 SET AQAQRG=AQAQRG_$EXTRACT(AQAQEDT,4,5)_"/"_$EXTRACT(AQAQEDT,6,7)_"/"_$EXTRACT(AQAQEDT,2,3)
+8 SET AQAQLINE=""
SET $PIECE(AQAQLINE,"=",80)=""
+9 SET AQAQLIN2=""
SET $PIECE(AQAQLIN2,"-",80)=""
+10 SET (AQAQICNT,AQAQSCNT,AQAQWCNT,AQAQTCNT,AQAQTICT,AQAQTWCT)=0
+11 ;
+12 IF '$DATA(^UTILITY("AQAQPR1",$JOB))
DO HEAD
WRITE !!,">>> NO DATA FOR DATES",!!
GOTO WAIT
+13 ;
+14 ;>>> pull data by provider, then print <<<
+15 SET AQAQPRV=0
+16 FOR
SET AQAQPRV=$ORDER(^UTILITY("AQAQPR1",$JOB,AQAQPRV))
IF AQAQPRV=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:1
+17 IF (AQAQSCNT>0)!(AQAQICNT>0)
DO COUNT
+18 IF AQAQPAGE=0
DO HEAD
+19 IF '$TEST
DO NEWPG
IF AQAQSTOP=U
QUIT
+20 ;print provider subheading
WRITE !!?80-$LENGTH(AQAQPRV)/2,AQAQPRV,!
+21 SET (AQAQDT,AQAQLST)=0
+22 FOR
SET AQAQDT=$ORDER(^UTILITY("AQAQPR1",$JOB,AQAQPRV,AQAQDT))
IF AQAQDT=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:2
+23 ;if new month, get subcounts
IF $EXTRACT(AQAQLST,4,5)'=$EXTRACT(AQAQDT)&(AQAQLST'=0)
DO COUNT
+24 SET DFN=0
+25 FOR
SET DFN=$ORDER(^UTILITY("AQAQPR1",$JOB,AQAQPRV,AQAQDT,DFN))
IF DFN=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:3
+26 ;print line with admission data
SET AQAQSTR=^(DFN)
DO LINE
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ;>>> do last month subcount, then print totals <<<
+29 IF AQAQSTOP=U
GOTO END
+30 IF (AQAQSCNT>0)!(AQAQICNT>0)!(AQAQWCNT>0)
DO COUNT
+31 DO NEWPG
WRITE !!," ADMISSIONS: ",AQAQTCNT
+32 WRITE !," ICU ADMISSIONS: ",AQAQTICT
+33 WRITE !," TOTAL ADMISSIONS: ",AQAQTCNT+AQAQTICT
+34 WRITE !,"NEWBORN ADMISSIONS: ",AQAQTWCT
+35 WRITE !,AQAQLINE
WAIT IF IOST["C-"
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="RETURN to continue"
DO ^DIR
+1 ;
+2 ;
END ;EP;>>> eoj <<<
+1 WRITE @IOF
DO ^%ZISC
DO KILL^AQAQUTIL
KILL ^UTILITY("AQAQPR1",$JOB)
QUIT
+2 ;
+3 ;>>> END OF MAIN ROUTINE <<<
+4 ;
+5 ;
NEWPG ;***> SUBRTN for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET AQAQSTOP=""
QUIT
+2 IF AQAQPAGE>0
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET AQAQSTOP=X
+3 IF AQAQSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> SUBRTN to print heading
+1 IF (IOST["C-")!(AQAQPAGE>0)
WRITE @IOF
+2 WRITE !,AQAQLINE
SET AQAQPAGE=AQAQPAGE+1
+3 WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !,AQAQDUZ,?80-$LENGTH(AQAQSITE)/2,AQAQSITE
+5 SET AQAQTY="ADMISSIONS BY PROVIDER"
+6 WRITE !
DO ^%T
WRITE ?80-$LENGTH(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
+7 ;date range
SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y,?30,AQAQRG
+8 WRITE !,AQAQLINE
+9 WRITE !,"Admit Date",?20,"Patient",?43,"Ward",?48,"Srv",?55,"Admitting DX"
+10 WRITE !,AQAQLIN2
+11 QUIT
+12 ;
LINE ;***> SUBRTN to print line of data and increment counts
+1 ;admit date/time
SET Y=AQAQDT
XECUTE ^DD("DD")
WRITE !,Y
+2 ;patient name
WRITE ?20,$EXTRACT($PIECE(AQAQSTR,U),1,20)
+3 ;ward & srv
WRITE ?43,$EXTRACT($PIECE(AQAQSTR,U,2),1,3),?48,$EXTRACT($PIECE(AQAQSTR,U,3),1,3)
+4 ;admitting dx
WRITE ?55,$EXTRACT($PIECE(AQAQSTR,U,4),1,23)
+5 ;increment icu count
IF $PIECE(AQAQSTR,U,5)=1
SET AQAQICNT=AQAQICNT+1
+6 ;newborn count
IF '$TEST
IF $PIECE(AQAQSTR,U,3)="NEWBORN"
SET AQAQWCNT=AQAQWCNT+1
+7 ;increment subcount
IF '$TEST
SET AQAQSCNT=AQAQSCNT+1
+8 IF $Y>(IOSL-5)
DO NEWPG
+9 QUIT
+10 ;
COUNT ;***> SUBRTN to print subcounts and increment totals
+1 WRITE !," Admissions: ",AQAQSCNT
SET AQAQTCNT=AQAQTCNT+AQAQSCNT
+2 WRITE !," ICU Admissions: ",AQAQICNT
SET AQAQTICT=AQAQTICT+AQAQICNT
+3 WRITE !," Total Admissions: ",AQAQICNT+AQAQSCNT
+4 WRITE !,"Newborn Admissions: ",AQAQWCNT
SET AQAQTWCT=AQAQTWCT+AQAQWCNT
+5 WRITE !,AQAQLINE
SET (AQAQSCNT,AQAQICNT,AQAQWCNT)=0
+6 QUIT
