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
Q
;
;
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
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="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
Q
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
