- 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
