Routine: AQAQPR32

AQAQPR32 ;IHS/ANMC/LJF - DISCHARGES BY PROVIDER & DX; [ 07/09/1999  2:26 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 AQAQTCT=0,AQAQPRV=""

 I '$D(^UTILITY("AQAQPR3",$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("AQAQPR3",$J,AQAQPRV)) G TOTALS:AQAQPRV=""

 G END:AQAQSTOP=U I AQAQPAGE=0 D HEAD

 E  D NEWPG G END:AQAQSTOP=U ;print heading with provider name

 S (AQAQGCT,AQAQPCT)=0 ;aqaqgct=icd group count;aqaqpct=prov count

 ;>>> loop2=for provider, get each icd code & subcount by icd groupings

 S AQAQICD=0

LOOP2 S AQAQICD=$O(^UTILITY("AQAQPR3",$J,AQAQPRV,AQAQICD))

 I AQAQICD="" D PROVCNT^AQAQPR33 G LOOP1 ;subtotal by prov & then loop

 I AQAQGCT=0 D GETGRP^AQAQPR33 ;print name of icd grouping

 I AQAQICD>($P(AQAQRNG,"-",2)_".999") D SUBCNT^AQAQPR33 ;group subcnt

 I (AQAQICD?1"V".E),(AQAQRNG'?1"V".E) D SUBCNT^AQAQPR33 ;v-codes

 ;>>> loop3&loop4=for each icd code, pull by visit date & visit dfn

 S AQAQDT=0

LOOP3 S AQAQDT=$O(^UTILITY("AQAQPR3",$J,AQAQPRV,AQAQICD,AQAQDT))

 G LOOP2:AQAQDT="" S AQAQVDFN=0

LOOP4 S AQAQVDFN=$O(^UTILITY("AQAQPR3",$J,AQAQPRV,AQAQICD,AQAQDT,AQAQVDFN))

 G LOOP3:AQAQVDFN="" S AQAQSTR=^(AQAQVDFN) D LINE ;print visit data

 G END:AQAQSTOP=U G LOOP4 ;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-" 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("AQAQPR3",$J) Q

LINE ;***> SUBRTN to print line of visit data

 S AQAQV=^AUPNVSIT(AQAQVDFN,0),AQAQVDT=$P(AQAQV,U) ;visit node

 ;BEGIN Y2K FIX BLOCK

 ;W !,$E(AQAQVDT,4,5)_"/"_$E(AQAQVDT,6,7)_"/"_$E(AQAQVDT,2,3)_"-" ;adm

 W !,$E(AQAQVDT,4,5)_"/"_$E(AQAQVDT,6,7)_"/"_($E(AQAQVDT,1,3)+1700)_"-" ; Y2000;adm

 ;END Y2K FIX BLOCK

 ;BEGIN Y2K FIX BLOCK

 ;W $E(AQAQDT,4,5)_"/"_$E(AQAQDT,6,7)_"/"_$E(AQAQDT,2,3) ;dsc date

 W $E(AQAQDT,4,5)_"/"_$E(AQAQDT,6,7)_"/"_($E(AQAQDT,1,3)+1700) ; Y2000;dsc date

 ;END Y2K FIX BLOCK

 S AQAQY=$P(AQAQV,U,5),AQAQY=$P($G(^AUPNPAT(AQAQY,41,DUZ(2),0)),U,2)

 W ?23,$J(AQAQY,6) ;patient chart #

 S AQAQX=$P(^AUPNVINP($P(AQAQSTR,U,2),0),U,5)

 W:AQAQX'="" ?32,$E($P(^DIC(45.7,AQAQX,0),U),1,3) ;discharge srv

 S AQAQX=$P(^AUPNVPOV($P(AQAQSTR,U),0),U,12),AQAQZ=$P(^(0),U,4)

 W ?37,AQAQX ;primary or secondary

 W ?42,$E($P(^AUTNPOV(AQAQZ,0),U),1,37) ;provider narrative for dx

 S AQAQGCT=AQAQGCT+1,AQAQPCT=AQAQPCT+1 ;increment counts

 I $Y>(IOSL-5) D NEWPG

NEWPG ;EP;***> 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

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="INPATIENT DIAGNOSES 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 !,"Visit",?23,"Patient",!,"Dates",?23,"Chart #",?32,"Srv",?37,"P/S"

 W ?42,"Diagnosis Narrative",!,AQAQLIN2

AQAQPR32  ;IHS/ANMC/LJF - DISCHARGES BY PROVIDER & DX; [ 07/09/1999  2:26 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 AQAQTCT=0

           SET AQAQPRV=""

 +16      ;

 +17       IF '$DATA(^UTILITY("AQAQPR3",$JOB))

               DO HEAD

               WRITE !!,">>> NO DATA FOUND!!"

               GOTO WAIT

 +18      ;

 +19      ;

 +20      ;>>> loop1=get next provider & start new page & new counts

 +21       SET AQAQPRV=0

LOOP1      SET AQAQPRV=$ORDER(^UTILITY("AQAQPR3",$JOB,AQAQPRV))

           IF AQAQPRV=""

               GOTO TOTALS

 +1        IF AQAQSTOP=U

               GOTO END

           IF AQAQPAGE=0

               DO HEAD

 +2       ;print heading with provider name

          IF '$TEST

               DO NEWPG

               IF AQAQSTOP=U

                   GOTO END

 +3       ;aqaqgct=icd group count;aqaqpct=prov count

           SET (AQAQGCT,AQAQPCT)=0

 +4       ;

 +5       ;>>> loop2=for provider, get each icd code & subcount by icd groupings

 +6        SET AQAQICD=0

LOOP2      SET AQAQICD=$ORDER(^UTILITY("AQAQPR3",$JOB,AQAQPRV,AQAQICD))

 +1       ;subtotal by prov & then loop

           IF AQAQICD=""

               DO PROVCNT^AQAQPR33

               GOTO LOOP1

 +2       ;print name of icd grouping

           IF AQAQGCT=0

               DO GETGRP^AQAQPR33

 +3       ;group subcnt

           IF AQAQICD>($PIECE(AQAQRNG,"-",2)_".999")

               DO SUBCNT^AQAQPR33

 +4       ;v-codes

           IF (AQAQICD?1"V".E)

               IF (AQAQRNG'?1"V".E)

                   DO SUBCNT^AQAQPR33

 +5       ;

 +6       ;>>> loop3&loop4=for each icd code, pull by visit date & visit dfn

 +7        SET AQAQDT=0

LOOP3      SET AQAQDT=$ORDER(^UTILITY("AQAQPR3",$JOB,AQAQPRV,AQAQICD,AQAQDT))

 +1        IF AQAQDT=""

               GOTO LOOP2

           SET AQAQVDFN=0

LOOP4      SET AQAQVDFN=$ORDER(^UTILITY("AQAQPR3",$JOB,AQAQPRV,AQAQICD,AQAQDT,AQAQVDFN))

 +1       ;print visit data

           IF AQAQVDFN=""

               GOTO LOOP3

           SET AQAQSTR=^(AQAQVDFN)

           DO LINE

 +2       ;quit if "^" entered OR continue looping

           IF AQAQSTOP=U

               GOTO END

           GOTO LOOP4

 +3       ;

 +4       ;

TOTALS    ;>>> print facility totals <<<

 +1        IF $Y>(IOSL-4)

               DO NEWPG

 +2        WRITE !!,"***TOTAL DIAGNOSES:  ",AQAQTCT,"***",!,AQAQLINE

WAIT       IF IOST["C-"

               WRITE !

               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("AQAQPR3",$JOB)

           QUIT

 +2       ;

 +3       ;

LINE      ;***> SUBRTN to print line of visit data

 +1       ;visit node

           SET AQAQV=^AUPNVSIT(AQAQVDFN,0)

           SET AQAQVDT=$PIECE(AQAQV,U)

 +2       ;BEGIN Y2K FIX BLOCK

 +3       ;W !,$E(AQAQVDT,4,5)_"/"_$E(AQAQVDT,6,7)_"/"_$E(AQAQVDT,2,3)_"-" ;adm

 +4       ; Y2000;adm

           WRITE !,$EXTRACT(AQAQVDT,4,5)_"/"_$EXTRACT(AQAQVDT,6,7)_"/"_($EXTRACT(AQAQVDT,1,3)+1700)_"-"

 +5       ;END Y2K FIX BLOCK

 +6       ;BEGIN Y2K FIX BLOCK

 +7       ;W $E(AQAQDT,4,5)_"/"_$E(AQAQDT,6,7)_"/"_$E(AQAQDT,2,3) ;dsc date

 +8       ; Y2000;dsc date

           WRITE $EXTRACT(AQAQDT,4,5)_"/"_$EXTRACT(AQAQDT,6,7)_"/"_($EXTRACT(AQAQDT,1,3)+1700)

 +9       ;END Y2K FIX BLOCK

 +10       SET AQAQY=$PIECE(AQAQV,U,5)

           SET AQAQY=$PIECE($GET(^AUPNPAT(AQAQY,41,DUZ(2),0)),U,2)

 +11      ;patient chart #

           WRITE ?23,$JUSTIFY(AQAQY,6)

 +12       SET AQAQX=$PIECE(^AUPNVINP($PIECE(AQAQSTR,U,2),0),U,5)

 +13      ;discharge srv

           IF AQAQX'=""

               WRITE ?32,$EXTRACT($PIECE(^DIC(45.7,AQAQX,0),U),1,3)

 +14       SET AQAQX=$PIECE(^AUPNVPOV($PIECE(AQAQSTR,U),0),U,12)

           SET AQAQZ=$PIECE(^(0),U,4)

 +15      ;primary or secondary

           WRITE ?37,AQAQX

 +16      ;provider narrative for dx

           WRITE ?42,$EXTRACT($PIECE(^AUTNPOV(AQAQZ,0),U),1,37)

 +17      ;increment counts

           SET AQAQGCT=AQAQGCT+1

           SET AQAQPCT=AQAQPCT+1

 +18       IF $Y>(IOSL-5)

               DO NEWPG

 +19       QUIT

 +20      ;

 +21      ;

NEWPG     ;EP;***> 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="INPATIENT DIAGNOSES 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 !,"Visit",?23,"Patient",!,"Dates",?23,"Chart #",?32,"Srv",?37,"P/S"

 +9        WRITE ?42,"Diagnosis Narrative",!,AQAQLIN2

 +10       QUIT

AQAQPR32.m