AQAQDCP ;IHS/ANMC/LJF - INCOM/DELQ CHARTS BY PROVIDER; [ 07/09/1999 2:27 PM ]
;;2.2;STAFF CREDENTIALS;**8**;JULY 9, 1999
;;AQAQ*2*8;Y2K FIX;CS;2990708
;>>> initialize variables
S AQAQSTOP="",AQAQDUZ=$P(^DIC(3,DUZ,0),U,2)
S AQAQFAC=$P(^DIC(4,DUZ(2),0),U)
S AQAQLIN="",$P(AQAQLIN,"=",80)=""
D HEAD
;
;>>> for each provider, call subrtn to print data
S AQAQPRVN=0 F AQAQI=2:1:7 S AQAQTOT(AQAQI)=0
F Q:AQAQPRVN="" Q:AQAQSTOP=U D
.S AQAQPRVN=$O(^UTILITY("AQAQDC",$J,AQAQPRVN)) Q:AQAQPRVN=""
.S AQAQSTR=^(AQAQPRVN) D LINE
G END:AQAQSTOP=U
;
;>>> print totals
W !!,AQAQLIN
W !,"Total Delinquent Charts: ",?33,AQAQDTOT
S AQAQX=23 F AQAQI=2:1:5 W ?(AQAQX+(AQAQI*10)),$J(AQAQTOT(AQAQI),3)
;
END ;>>> eoj
I IOST?1"C-".E K DIR S DIR(0)="E",DIR("A")="RETURN to continue" D ^DIR
W @IOF K ^UTILITY("AQAQDC") D ^%ZISC D KILL^AQAQUTIL Q
;>>> end of main routine <<<
;
NEWPG ;***> SUBRTN for end of page control
I IOST'?1"C-".E D HEAD S AQAQSTOP="" Q
K DIR S DIR(0)="E" D ^DIR S AQAQSTOP=X
I AQAQSTOP'=U D HEAD
Q
;
HEAD ;**> SUBRTN to print heading
W !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
W @IOF,!!,AQAQDUZ,?80-$L(AQAQFAC)/2,AQAQFAC
;BEGIN Y2K FIX BLOCK
;W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_($E(DT,1,3)+1700) ; Y2000
;END Y2K FIX BLOCK
W ?25,"DELINQUENT CHARTS BY PROVIDER"
W ! D ^%T W ?34,"SUMMARY PAGE"
W !!?30,"DELINQ",?39,"-----REASONS CHARTS ARE DELINQUENT------"
W !,"PROVIDER",?30,"CHARTS",?39,"OP REPORT"
W ?50,"A SHEET",?60,"SUMMARY",?70,"SIGNATURE",!,AQAQLIN
Q
;
LINE ;***> SUBRTN to print line of data
W !,$E(AQAQPRVN,1,15),?33,$J($P(AQAQSTR,U),3)
W ?43,$J($P(AQAQSTR,U,2),3),?53,$J($P(AQAQSTR,U,3),3)
W ?63,$J($P(AQAQSTR,U,4),3),?73,$J($P(AQAQSTR,U,5),3)
;W ?65,$J($P(AQAQSTR,U,6),3),?73,$J($P(AQAQSTR,U,7),3)
F AQAQJ=2:1:5 S AQAQTOT(AQAQJ)=AQAQTOT(AQAQJ)+$P(AQAQSTR,U,AQAQJ)
I $Y>(IOSL-5) D NEWPG
Q
AQAQDCP ;IHS/ANMC/LJF - INCOM/DELQ CHARTS BY PROVIDER; [ 07/09/1999 2:27 PM ]
+1 ;;2.2;STAFF CREDENTIALS;**8**;JULY 9, 1999
+2 ;;AQAQ*2*8;Y2K FIX;CS;2990708
+3 ;>>> initialize variables
+4 SET AQAQSTOP=""
SET AQAQDUZ=$PIECE(^DIC(3,DUZ,0),U,2)
+5 SET AQAQFAC=$PIECE(^DIC(4,DUZ(2),0),U)
+6 SET AQAQLIN=""
SET $PIECE(AQAQLIN,"=",80)=""
+7 DO HEAD
+8 ;
+9 ;>>> for each provider, call subrtn to print data
+10 SET AQAQPRVN=0
FOR AQAQI=2:1:7
SET AQAQTOT(AQAQI)=0
+11 FOR
IF AQAQPRVN=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:1
+12 SET AQAQPRVN=$ORDER(^UTILITY("AQAQDC",$JOB,AQAQPRVN))
IF AQAQPRVN=""
QUIT
+13 SET AQAQSTR=^(AQAQPRVN)
DO LINE
End DoDot:1
+14 IF AQAQSTOP=U
GOTO END
+15 ;
+16 ;>>> print totals
+17 WRITE !!,AQAQLIN
+18 WRITE !,"Total Delinquent Charts: ",?33,AQAQDTOT
+19 SET AQAQX=23
FOR AQAQI=2:1:5
WRITE ?(AQAQX+(AQAQI*10)),$JUSTIFY(AQAQTOT(AQAQI),3)
+20 ;
END ;>>> eoj
+1 IF IOST?1"C-".E
KILL DIR
SET DIR(0)="E"
SET DIR("A")="RETURN to continue"
DO ^DIR
+2 WRITE @IOF
KILL ^UTILITY("AQAQDC")
DO ^%ZISC
DO KILL^AQAQUTIL
QUIT
+3 ;>>> end of main routine <<<
+4 ;
NEWPG ;***> SUBRTN for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET AQAQSTOP=""
QUIT
+2 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 !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
+2 WRITE @IOF,!!,AQAQDUZ,?80-$LENGTH(AQAQFAC)/2,AQAQFAC
+3 ;BEGIN Y2K FIX BLOCK
+4 ;W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
+5 ; Y2000
WRITE !,$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_($EXTRACT(DT,1,3)+1700)
+6 ;END Y2K FIX BLOCK
+7 WRITE ?25,"DELINQUENT CHARTS BY PROVIDER"
+8 WRITE !
DO ^%T
WRITE ?34,"SUMMARY PAGE"
+9 WRITE !!?30,"DELINQ",?39,"-----REASONS CHARTS ARE DELINQUENT------"
+10 WRITE !,"PROVIDER",?30,"CHARTS",?39,"OP REPORT"
+11 WRITE ?50,"A SHEET",?60,"SUMMARY",?70,"SIGNATURE",!,AQAQLIN
+12 QUIT
+13 ;
LINE ;***> SUBRTN to print line of data
+1 WRITE !,$EXTRACT(AQAQPRVN,1,15),?33,$JUSTIFY($PIECE(AQAQSTR,U),3)
+2 WRITE ?43,$JUSTIFY($PIECE(AQAQSTR,U,2),3),?53,$JUSTIFY($PIECE(AQAQSTR,U,3),3)
+3 WRITE ?63,$JUSTIFY($PIECE(AQAQSTR,U,4),3),?73,$JUSTIFY($PIECE(AQAQSTR,U,5),3)
+4 ;W ?65,$J($P(AQAQSTR,U,6),3),?73,$J($P(AQAQSTR,U,7),3)
+5 FOR AQAQJ=2:1:5
SET AQAQTOT(AQAQJ)=AQAQTOT(AQAQJ)+$PIECE(AQAQSTR,U,AQAQJ)
+6 IF $Y>(IOSL-5)
DO NEWPG
+7 QUIT
