AQAQPR22 ;IHS/ANMC/LJF - PROCEDURES BY PROVIDER(PCC DATA); [ 07/09/1999 2:25 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 "
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("AQAQPR2",$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("AQAQPR2",$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("AQAQPR2",$J,AQAQPRV,AQAQICD))
I AQAQICD="" D PROVCNT^AQAQPR23 G LOOP1 ;subtotal by prov & then loop
I AQAQGCT=0 D GETGRP^AQAQPR23 ;print name of icd grouping
I AQAQICD>($P(AQAQRNG,"-",2)_".999") D SUBCNT^AQAQPR23 ;group subcnt
;
;>>> loop3&loop4=for each icd code, pull by visit date & visit dfn
S AQAQDT=0
LOOP3 S AQAQDT=$O(^UTILITY("AQAQPR2",$J,AQAQPRV,AQAQICD,AQAQDT))
G LOOP2:AQAQDT="" S AQAQVDFN=0
LOOP4 S AQAQVDFN=$O(^UTILITY("AQAQPR2",$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 PROCEDURES: ",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("AQAQPR2",$J) Q
;
;
LINE ;***> SUBRTN to print line of visit data
;BEGIN Y2K FIX BLOCK
;W !,$E(AQAQDT,4,5)_"/"_$E(AQAQDT,6,7)_"/"_$E(AQAQDT,2,3) ;visit date
W !,$E(AQAQDT,4,5)_"/"_$E(AQAQDT,6,7)_"/"_($E(AQAQDT,1,3)+1700) ; Y2000;visit date
;END Y2K FIX BLOCK
S AQAQX=$P(^AUPNVPRC($P(AQAQSTR,U),0),U,6),AQAQZ=$P(^(0),U,4)
;BEGIN Y2K FIX BLOCK
;W ?10,$E(AQAQX,4,5)_"/"_$E(AQAQX,6,7)_"/"_$E(AQAQX,2,3) ;proc date
W ?11,$E(AQAQX,4,5)_"/"_$E(AQAQX,6,7)_"/"_($E(AQAQX,1,3)+1700) ; Y2000;proc date
;END Y2K FIX BLOCK
S AQAQX=^AUPNVSIT(AQAQVDFN,0) W ?22,$P(AQAQX,U,7) ;serv category
S AQAQY=$P(AQAQX,U,5),AQAQY=$P($G(^AUPNPAT(AQAQY,41,DUZ(2),0)),U,2)
W ?26,$J(AQAQY,6) ;patient chart #
W ?36,$E($P(^AUTNPOV(AQAQZ,0),U),1,43) ;provider narrative for proc
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="PROCEDURES 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",?11,"Proc.",?20,"Visit",?26,"Patient"
W !,"Date",?11,"Date",?20,"Type",?26,"Chart #"
W ?36,"Procedure Narrative",!,AQAQLIN2
Q
AQAQPR22 ;IHS/ANMC/LJF - PROCEDURES BY PROVIDER(PCC DATA); [ 07/09/1999 2:25 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 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("AQAQPR2",$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("AQAQPR2",$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("AQAQPR2",$JOB,AQAQPRV,AQAQICD))
+1 ;subtotal by prov & then loop
IF AQAQICD=""
DO PROVCNT^AQAQPR23
GOTO LOOP1
+2 ;print name of icd grouping
IF AQAQGCT=0
DO GETGRP^AQAQPR23
+3 ;group subcnt
IF AQAQICD>($PIECE(AQAQRNG,"-",2)_".999")
DO SUBCNT^AQAQPR23
+4 ;
+5 ;>>> loop3&loop4=for each icd code, pull by visit date & visit dfn
+6 SET AQAQDT=0
LOOP3 SET AQAQDT=$ORDER(^UTILITY("AQAQPR2",$JOB,AQAQPRV,AQAQICD,AQAQDT))
+1 IF AQAQDT=""
GOTO LOOP2
SET AQAQVDFN=0
LOOP4 SET AQAQVDFN=$ORDER(^UTILITY("AQAQPR2",$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 PROCEDURES: ",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("AQAQPR2",$JOB)
QUIT
+2 ;
+3 ;
LINE ;***> SUBRTN to print line of visit data
+1 ;BEGIN Y2K FIX BLOCK
+2 ;W !,$E(AQAQDT,4,5)_"/"_$E(AQAQDT,6,7)_"/"_$E(AQAQDT,2,3) ;visit date
+3 ; Y2000;visit date
WRITE !,$EXTRACT(AQAQDT,4,5)_"/"_$EXTRACT(AQAQDT,6,7)_"/"_($EXTRACT(AQAQDT,1,3)+1700)
+4 ;END Y2K FIX BLOCK
+5 SET AQAQX=$PIECE(^AUPNVPRC($PIECE(AQAQSTR,U),0),U,6)
SET AQAQZ=$PIECE(^(0),U,4)
+6 ;BEGIN Y2K FIX BLOCK
+7 ;W ?10,$E(AQAQX,4,5)_"/"_$E(AQAQX,6,7)_"/"_$E(AQAQX,2,3) ;proc date
+8 ; Y2000;proc date
WRITE ?11,$EXTRACT(AQAQX,4,5)_"/"_$EXTRACT(AQAQX,6,7)_"/"_($EXTRACT(AQAQX,1,3)+1700)
+9 ;END Y2K FIX BLOCK
+10 ;serv category
SET AQAQX=^AUPNVSIT(AQAQVDFN,0)
WRITE ?22,$PIECE(AQAQX,U,7)
+11 SET AQAQY=$PIECE(AQAQX,U,5)
SET AQAQY=$PIECE($GET(^AUPNPAT(AQAQY,41,DUZ(2),0)),U,2)
+12 ;patient chart #
WRITE ?26,$JUSTIFY(AQAQY,6)
+13 ;provider narrative for proc
WRITE ?36,$EXTRACT($PIECE(^AUTNPOV(AQAQZ,0),U),1,43)
+14 ;increment counts
SET AQAQGCT=AQAQGCT+1
SET AQAQPCT=AQAQPCT+1
+15 IF $Y>(IOSL-5)
DO NEWPG
+16 QUIT
+17 ;
+18 ;
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="PROCEDURES 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",?11,"Proc.",?20,"Visit",?26,"Patient"
+9 WRITE !,"Date",?11,"Date",?20,"Type",?26,"Chart #"
+10 WRITE ?36,"Procedure Narrative",!,AQAQLIN2
+11 QUIT
