AQAQPR42 ;IHS/ANMC/LJF - DISCHARGES BY PROVIDER & DX; [ 07/09/1999 2:27 PM ]
;;2.2;STAFF CREDENTIALS;**8**;JULY 9, 1999
;;AQAQ*2*8;Y2K FIX;CS;2990708
;
;>>> 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
;BEGIN Y2K FIX BLOCK
;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 AQAQRG=$E(AQAQBDT,4,5)_"/"_$E(AQAQBDT,6,7)_"/"_($E(AQAQBDT,1,3)+1700)_" to " ; Y2000
S AQAQRG=AQAQRG_$E(AQAQEDT,4,5)_"/"_$E(AQAQEDT,6,7)_"/"_($E(AQAQEDT,1,3)+1700) ; Y2000
;END Y2K FIX BLOCK
S AQAQLINE="",$P(AQAQLINE,"=",80)=""
S AQAQLIN2="",$P(AQAQLIN2,"-",80)=""
S (AQAQPCT,AQAQTCT)=0,AQAQPRV=""
;
I '$D(^UTILITY("AQAQPR4",$J)) D HEAD W !!,">>> NO DATA FOUND!!" G WAIT
;
;>>> loop1=get next provider & start new page & new counts
S AQAQPRV=0
LOOP1 S AQAQPRV=$O(^UTILITY("AQAQPR4",$J,AQAQPRV)) G TOTALS:AQAQPRV=""
G END:AQAQSTOP=U I AQAQPAGE=0 D HEAD G PRVINIT
E D NEWPG G END:AQAQSTOP=U ;print heading with provider name
S AQAQPCT=0 ;initialize provider count
;
PRVINIT ;
;>>> loop2=for provider, get each diagnostic category
S AQAQGRP=0
LOOP2 S AQAQGRP=$O(^UTILITY("AQAQPR4",$J,AQAQPRV,AQAQGRP))
I AQAQGRP="" D PROVCNT G END:AQAQSTOP=U G LOOP1 ;subtotal by prov
S AQAQCNT=^UTILITY("AQAQPR4",$J,AQAQPRV,AQAQGRP)
W !,$E(AQAQGRP,1,67),?70,AQAQCNT,! ;print counts
S AQAQPCT=AQAQPCT+AQAQCNT ;increment count for provider
I $Y>(IOSL-5) D NEWPG
G END:AQAQSTOP=U G LOOP2 ;quit if "^" entered OR continue looping
;
;
TOTALS ;>>> print facility totals <<<
I $Y>(IOSL-4) D NEWPG
W !!,"***TOTAL DIAGNOSES: ",AQAQTCT,"***",!,AQAQLINE
WAIT I IOST["C-" 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("AQAQPR4",$J) Q
;
;
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
W @IOF,!,AQAQLINE S AQAQPAGE=AQAQPAGE+1
W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,AQAQDUZ,?80-$L(AQAQSITE)/2,AQAQSITE
S AQAQTY="AMBULATORY DIAGNOSIS COUNTS BY PROVIDER"
W ! D ^%T W ?80-$L(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
S Y=DT X ^DD("DD") W !,Y,?80-$L(AQAQPRV)/2,AQAQPRV ;prov name
W !?30,AQAQRG,!,AQAQLINE ;date range and line
W !,"Diagnostic Category",?70,"Count",!,AQAQLIN2
I AQAQCDX=1 W !?25,"*** PRIMARY DIAGNOSES ONLY ***"
E W !?17,"*** PRIMARY & SECONDARY DIAGNOSES COUNTED ***"
Q
;
;
PROVCNT ;***> SUBRTN to print provider subcount
I $Y>(IOSL-4) D NEWPG Q:AQAQSTOP=U
W !?20,"TOTAL DIAGNOSES FOR PROVIDER: ",AQAQPCT
W !,AQAQLINE S AQAQTCT=AQAQTCT+AQAQPCT,AQAQPCT=0
Q
AQAQPR42 ;IHS/ANMC/LJF - DISCHARGES BY PROVIDER & DX; [ 07/09/1999 2:27 PM ]
+1 ;;2.2;STAFF CREDENTIALS;**8**;JULY 9, 1999
+2 ;;AQAQ*2*8;Y2K FIX;CS;2990708
+3 ;
+4 ;>>> initialize variables <<<
+5 SET AQAQPAGE=0
SET AQAQSTOP=""
SET AQAQDUZ=$PIECE(^DIC(3,DUZ,0),U,2)
+6 ;set site
SET AQAQSITE=$PIECE(^DIC(4,DUZ(2),0),U)
+7 ;BEGIN Y2K FIX BLOCK
+8 ;S AQAQRG=$E(AQAQBDT,4,5)_"/"_$E(AQAQBDT,6,7)_"/"_$E(AQAQBDT,2,3)_" to "
+9 ;S AQAQRG=AQAQRG_$E(AQAQEDT,4,5)_"/"_$E(AQAQEDT,6,7)_"/"_$E(AQAQEDT,2,3)
+10 ; Y2000
SET AQAQRG=$EXTRACT(AQAQBDT,4,5)_"/"_$EXTRACT(AQAQBDT,6,7)_"/"_($EXTRACT(AQAQBDT,1,3)+1700)_" to "
+11 ; Y2000
SET AQAQRG=AQAQRG_$EXTRACT(AQAQEDT,4,5)_"/"_$EXTRACT(AQAQEDT,6,7)_"/"_($EXTRACT(AQAQEDT,1,3)+1700)
+12 ;END Y2K FIX BLOCK
+13 SET AQAQLINE=""
SET $PIECE(AQAQLINE,"=",80)=""
+14 SET AQAQLIN2=""
SET $PIECE(AQAQLIN2,"-",80)=""
+15 SET (AQAQPCT,AQAQTCT)=0
SET AQAQPRV=""
+16 ;
+17 IF '$DATA(^UTILITY("AQAQPR4",$JOB))
DO HEAD
WRITE !!,">>> NO DATA FOUND!!"
GOTO WAIT
+18 ;
+19 ;>>> loop1=get next provider & start new page & new counts
+20 SET AQAQPRV=0
LOOP1 SET AQAQPRV=$ORDER(^UTILITY("AQAQPR4",$JOB,AQAQPRV))
IF AQAQPRV=""
GOTO TOTALS
+1 IF AQAQSTOP=U
GOTO END
IF AQAQPAGE=0
DO HEAD
GOTO PRVINIT
+2 ;print heading with provider name
IF '$TEST
DO NEWPG
IF AQAQSTOP=U
GOTO END
+3 ;initialize provider count
SET AQAQPCT=0
+4 ;
PRVINIT ;
+1 ;>>> loop2=for provider, get each diagnostic category
+2 SET AQAQGRP=0
LOOP2 SET AQAQGRP=$ORDER(^UTILITY("AQAQPR4",$JOB,AQAQPRV,AQAQGRP))
+1 ;subtotal by prov
IF AQAQGRP=""
DO PROVCNT
IF AQAQSTOP=U
GOTO END
GOTO LOOP1
+2 SET AQAQCNT=^UTILITY("AQAQPR4",$JOB,AQAQPRV,AQAQGRP)
+3 ;print counts
WRITE !,$EXTRACT(AQAQGRP,1,67),?70,AQAQCNT,!
+4 ;increment count for provider
SET AQAQPCT=AQAQPCT+AQAQCNT
+5 IF $Y>(IOSL-5)
DO NEWPG
+6 ;quit if "^" entered OR continue looping
IF AQAQSTOP=U
GOTO END
GOTO LOOP2
+7 ;
+8 ;
TOTALS ;>>> print facility totals <<<
+1 IF $Y>(IOSL-4)
DO NEWPG
+2 WRITE !!,"***TOTAL DIAGNOSES: ",AQAQTCT,"***",!,AQAQLINE
WAIT IF IOST["C-"
KILL DIR
SET DIR(0)="E"
SET DIR("A")="RETURN to continue"
DO ^DIR
+1 ;
END ;EP;>>> eoj <<<
+1 WRITE @IOF
DO ^%ZISC
DO KILL^AQAQUTIL
KILL ^UTILITY("AQAQPR4",$JOB)
QUIT
+2 ;
+3 ;
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 WRITE @IOF,!,AQAQLINE
SET AQAQPAGE=AQAQPAGE+1
+2 WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+3 WRITE !,AQAQDUZ,?80-$LENGTH(AQAQSITE)/2,AQAQSITE
+4 SET AQAQTY="AMBULATORY DIAGNOSIS COUNTS BY PROVIDER"
+5 WRITE !
DO ^%T
WRITE ?80-$LENGTH(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
+6 ;prov name
SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y,?80-$LENGTH(AQAQPRV)/2,AQAQPRV
+7 ;date range and line
WRITE !?30,AQAQRG,!,AQAQLINE
+8 WRITE !,"Diagnostic Category",?70,"Count",!,AQAQLIN2
+9 IF AQAQCDX=1
WRITE !?25,"*** PRIMARY DIAGNOSES ONLY ***"
+10 IF '$TEST
WRITE !?17,"*** PRIMARY & SECONDARY DIAGNOSES COUNTED ***"
+11 QUIT
+12 ;
+13 ;
PROVCNT ;***> SUBRTN to print provider subcount
+1 IF $Y>(IOSL-4)
DO NEWPG
IF AQAQSTOP=U
QUIT
+2 WRITE !?20,"TOTAL DIAGNOSES FOR PROVIDER: ",AQAQPCT
+3 WRITE !,AQAQLINE
SET AQAQTCT=AQAQTCT+AQAQPCT
SET AQAQPCT=0
+4 QUIT
