- ACKQWLD ;AUG/JLTP BIR/PTD-Print A&SP Capitation Report ; [ 03/28/96 10:45 AM ]
- ;;3.0;QUASAR;;Feb 11, 2000
- ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- OPTN ;Introduce option.
- W @IOF,!,"This option produces a four-part capitation report.",!,"It includes demographic, diagnostic, procedure, and CDR data.",!
- D GETDT^ACKQWL G:$D(DIRUT) EXIT D INIT^ACKQWL
- DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
- K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
- I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^ACKQWLD",ZTDESC="QUASAR - Print A&SP Capitation Report",ZTSAVE("ACK*")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
- DQ ;Entry point when queued.
- U IO
- D NOW^%DTC S ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0 K ^TMP("ACKQWLD",$J)
- D COMPILE,PRINT
- EXIT ;ALWAYS EXIT HERE
- K %I,ACKBFY,ACKCDT,ACKDA,ACKEM,ACKM,ACKPG,AS,CDR,CPT,DIR,DIRUT,DTOUT,DUOUT,I,ICD,LN,T,X,XAS,Y,ZIP,^TMP("ACKQWLD",$J)
- W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- Q
- ;
- COMPILE ;Compile properly sorted data in ^TMP global.
- N AS,CPT,ICD,XAS,ZIP
- ;For all visits.
- S I=0 F S I=$O(^ACK(509850.7,ACKDA,3,I)) Q:'I D
- .S X=^ACK(509850.7,ACKDA,3,I,0)
- .S ^TMP("ACKQWLD",$J,1,$P(X,U,5),$P(X,U))=$P(X,U,2,4)
- .Q
- ;For ICD statistics.
- S I=0 F S I=$O(^ACK(509850.7,ACKDA,1,I)) Q:'I D
- .S X=^ACK(509850.7,ACKDA,1,I,0)
- .S ^TMP("ACKQWLD",$J,2,$P(X,U,4),$P(X,U),$P(X,U,5))=$P(X,U,2,3)
- .Q
- ;For CPT statistics.
- S I=0 F S I=$O(^ACK(509850.7,ACKDA,2,I)) Q:'I D
- .S X=^ACK(509850.7,ACKDA,2,I,0)
- .S ^TMP("ACKQWLD",$J,3,$P(X,U,4),+X,$P(X,U,5))=$P(X,U,2,3)
- .Q
- Q
- PRINT ;Print/display results.
- D DHD I '$O(^TMP("ACKQWLD",$J,0)) D LINE W !!,"No data found for report specifications." Q
- D HD1
- ZIP ;For all visits.
- S AS=0 F S AS=$O(^TMP("ACKQWLD",$J,1,AS)) Q:'AS!($D(DIRUT)) D
- .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1
- .S XAS=$S(AS=203:"Audiology",1:"Speech")
- .W !!,XAS,":"
- .S (ZIP,T)="" F S ZIP=$O(^TMP("ACKQWLD",$J,1,AS,ZIP)) Q:ZIP=""!($D(DIRUT)) D
- ..I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD1
- ..S X=^TMP("ACKQWLD",$J,1,AS,ZIP)
- ..W !,ZIP,?20,$J($P(X,U,2),5),?30,$J($P(X,U,3),5),?40,$J($P(X,U),5)
- ..S $P(T,U)=T+X,$P(T,U,2)=$P(T,U,2)+$P(X,U,2),$P(T,U,3)=$P(T,U,3)+$P(X,U,3)
- .Q:$D(DIRUT)
- .S $P(LN,"-",48)="" W !,LN
- .W !,XAS," Total: ",?20,$J($P(T,U,2),5),?30,$J($P(T,U,3),5),?40,$J(+T,5)
- Q:$D(DIRUT)
- ICD ;For ICD statistics.
- D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
- S AS=0 F S AS=$O(^TMP("ACKQWLD",$J,2,AS)) Q:'AS!($D(DIRUT)) D
- .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
- .S XAS=$S(AS=203:"Audiology",1:"Speech")
- .W !!,XAS,":"
- .S ICD="" F S ICD=$O(^TMP("ACKQWLD",$J,2,AS,ICD)) Q:ICD=""!($D(DIRUT)) D
- ..S (ZIP,X)="" F S ZIP=$O(^TMP("ACKQWLD",$J,2,AS,ICD,ZIP)) Q:ZIP=""!($D(DIRUT)) D
- ...I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD2
- ...S Y=^TMP("ACKQWLD",$J,2,AS,ICD,ZIP) F I=1,2 S $P(X,U,I)=$P(X,U,I)+$P(Y,U,I)
- ..Q:$D(DIRUT)
- ..W !,ICD,?20,$J($P(X,U),5),?30,$J($P(X,U,2),5)
- .Q:$D(DIRUT)
- Q:$D(DIRUT)
- CPT ;For CPT statistics.
- D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
- S AS=0 F S AS=$O(^TMP("ACKQWLD",$J,3,AS)) Q:'AS!($D(DIRUT)) D
- .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
- .S XAS=$S(AS=203:"Audiology",1:"Speech")
- .W !!,XAS,":"
- .S CPT=0 F S CPT=$O(^TMP("ACKQWLD",$J,3,AS,CPT)) Q:'CPT!($D(DIRUT)) D
- ..S (ZIP,X)="" F S ZIP=$O(^TMP("ACKQWLD",$J,3,AS,CPT,ZIP)) Q:ZIP=""!($D(DIRUT)) D
- ...I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD3
- ...S Y=^TMP("ACKQWLD",$J,3,AS,CPT,ZIP) F I=1,2 S $P(X,U,I)=$P(X,U,I)+$P(Y,U,I)
- ..Q:$D(DIRUT)
- ..W !,CPT,?20,$J($P(X,U),5),?30,$J($P(X,U,2),5)
- .Q:$D(DIRUT)
- Q:$D(DIRUT)
- CDR ;For CDR information.
- D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
- S (CDR,T)=0 F S CDR=$O(^ACK(509850.7,ACKDA,4,CDR)) Q:'CDR!($D(DIRUT)) D
- .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DIRUT) D DHD,HD4
- .S X=^ACK(509850.7,ACKDA,4,CDR,0)
- .S Y=$O(^ACK(509850,"B",$P(X,U),0))
- .S Y=$P($G(^ACK(509850,+Y,0)),U,2)
- .W !,$P(X,U),?10,Y,?60,$J($P(X,U,2),6,2)
- .S T=T+$P(X,U,2)
- Q:$D(DIRUT)
- W !,"Total:",?60,$J(T,6,2),!!
- Q
- DHD ;
- N X
- S ACKPG=ACKPG+1 W @IOF,"Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
- F X="Audiology & Speech Pathology","Capitation Report","for",$$XDAT^ACKQUTL(ACKM) W ! D CNTR^ACKQUTL(X)
- W ! Q
- HD1 ;Header for all visits.
- N X
- W !,"ZIP CODE",?21,"VISITS",?31,"UNIQUE",?42,"C&P"
- D LINE
- Q
- HD2 ;Header for ICD statistics.
- N X
- W !,"ICD",?21,"VISITS",?31,"UNIQUE"
- D LINE
- Q
- HD3 ;Header for CPT statistics.
- N X
- W !,"CPT",?21,"VISITS",?31,"UNIQUE"
- D LINE
- Q
- HD4 ;Header for CDR statistics.
- N X
- W !,"CDR ACCOUNT",?58,"% WORKLOAD"
- D LINE
- Q
- LINE S X="",$P(X,"-",IOM)="-" W !,X Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQWLD 4936 printed Jan 18, 2025@03:34:11 Page 2
- ACKQWLD ;AUG/JLTP BIR/PTD-Print A&SP Capitation Report ; [ 03/28/96 10:45 AM ]
- +1 ;;3.0;QUASAR;;Feb 11, 2000
- +2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- OPTN ;Introduce option.
- +1 WRITE @IOF,!,"This option produces a four-part capitation report.",!,"It includes demographic, diagnostic, procedure, and CDR data.",!
- +2 DO GETDT^ACKQWL
- if $DATA(DIRUT)
- GOTO EXIT
- DO INIT^ACKQWL
- DEV WRITE !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
- +1 KILL %ZIS,IOP
- SET %ZIS="QM"
- SET %ZIS("B")=""
- DO ^%ZIS
- IF POP
- WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."
- GOTO EXIT
- +2 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="DQ^ACKQWLD"
- SET ZTDESC="QUASAR - Print A&SP Capitation Report"
- SET ZTSAVE("ACK*")=""
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- GOTO EXIT
- DQ ;Entry point when queued.
- +1 USE IO
- +2 DO NOW^%DTC
- SET ACKCDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%)
- SET ACKPG=0
- KILL ^TMP("ACKQWLD",$JOB)
- +3 DO COMPILE
- DO PRINT
- EXIT ;ALWAYS EXIT HERE
- +1 KILL %I,ACKBFY,ACKCDT,ACKDA,ACKEM,ACKM,ACKPG,AS,CDR,CPT,DIR,DIRUT,DTOUT,DUOUT,I,ICD,LN,T,X,XAS,Y,ZIP,^TMP("ACKQWLD",$JOB)
- +2 if $EXTRACT(IOST)'="C"
- WRITE @IOF
- DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 QUIT
- +4 ;
- COMPILE ;Compile properly sorted data in ^TMP global.
- +1 NEW AS,CPT,ICD,XAS,ZIP
- +2 ;For all visits.
- +3 SET I=0
- FOR
- SET I=$ORDER(^ACK(509850.7,ACKDA,3,I))
- if 'I
- QUIT
- Begin DoDot:1
- +4 SET X=^ACK(509850.7,ACKDA,3,I,0)
- +5 SET ^TMP("ACKQWLD",$JOB,1,$PIECE(X,U,5),$PIECE(X,U))=$PIECE(X,U,2,4)
- +6 QUIT
- End DoDot:1
- +7 ;For ICD statistics.
- +8 SET I=0
- FOR
- SET I=$ORDER(^ACK(509850.7,ACKDA,1,I))
- if 'I
- QUIT
- Begin DoDot:1
- +9 SET X=^ACK(509850.7,ACKDA,1,I,0)
- +10 SET ^TMP("ACKQWLD",$JOB,2,$PIECE(X,U,4),$PIECE(X,U),$PIECE(X,U,5))=$PIECE(X,U,2,3)
- +11 QUIT
- End DoDot:1
- +12 ;For CPT statistics.
- +13 SET I=0
- FOR
- SET I=$ORDER(^ACK(509850.7,ACKDA,2,I))
- if 'I
- QUIT
- Begin DoDot:1
- +14 SET X=^ACK(509850.7,ACKDA,2,I,0)
- +15 SET ^TMP("ACKQWLD",$JOB,3,$PIECE(X,U,4),+X,$PIECE(X,U,5))=$PIECE(X,U,2,3)
- +16 QUIT
- End DoDot:1
- +17 QUIT
- PRINT ;Print/display results.
- +1 DO DHD
- IF '$ORDER(^TMP("ACKQWLD",$JOB,0))
- DO LINE
- WRITE !!,"No data found for report specifications."
- QUIT
- +2 DO HD1
- ZIP ;For all visits.
- +1 SET AS=0
- FOR
- SET AS=$ORDER(^TMP("ACKQWLD",$JOB,1,AS))
- if 'AS!($DATA(DIRUT))
- QUIT
- Begin DoDot:1
- +2 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD1
- +3 SET XAS=$SELECT(AS=203:"Audiology",1:"Speech")
- +4 WRITE !!,XAS,":"
- +5 SET (ZIP,T)=""
- FOR
- SET ZIP=$ORDER(^TMP("ACKQWLD",$JOB,1,AS,ZIP))
- if ZIP=""!($DATA(DIRUT))
- QUIT
- Begin DoDot:2
- +6 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD1
- +7 SET X=^TMP("ACKQWLD",$JOB,1,AS,ZIP)
- +8 WRITE !,ZIP,?20,$JUSTIFY($PIECE(X,U,2),5),?30,$JUSTIFY($PIECE(X,U,3),5),?40,$JUSTIFY($PIECE(X,U),5)
- +9 SET $PIECE(T,U)=T+X
- SET $PIECE(T,U,2)=$PIECE(T,U,2)+$PIECE(X,U,2)
- SET $PIECE(T,U,3)=$PIECE(T,U,3)+$PIECE(X,U,3)
- End DoDot:2
- +10 if $DATA(DIRUT)
- QUIT
- +11 SET $PIECE(LN,"-",48)=""
- WRITE !,LN
- +12 WRITE !,XAS," Total: ",?20,$JUSTIFY($PIECE(T,U,2),5),?30,$JUSTIFY($PIECE(T,U,3),5),?40,$JUSTIFY(+T,5)
- End DoDot:1
- +13 if $DATA(DIRUT)
- QUIT
- ICD ;For ICD statistics.
- +1 if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD2
- +2 SET AS=0
- FOR
- SET AS=$ORDER(^TMP("ACKQWLD",$JOB,2,AS))
- if 'AS!($DATA(DIRUT))
- QUIT
- Begin DoDot:1
- +3 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD2
- +4 SET XAS=$SELECT(AS=203:"Audiology",1:"Speech")
- +5 WRITE !!,XAS,":"
- +6 SET ICD=""
- FOR
- SET ICD=$ORDER(^TMP("ACKQWLD",$JOB,2,AS,ICD))
- if ICD=""!($DATA(DIRUT))
- QUIT
- Begin DoDot:2
- +7 SET (ZIP,X)=""
- FOR
- SET ZIP=$ORDER(^TMP("ACKQWLD",$JOB,2,AS,ICD,ZIP))
- if ZIP=""!($DATA(DIRUT))
- QUIT
- Begin DoDot:3
- +8 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD2
- +9 SET Y=^TMP("ACKQWLD",$JOB,2,AS,ICD,ZIP)
- FOR I=1,2
- SET $PIECE(X,U,I)=$PIECE(X,U,I)+$PIECE(Y,U,I)
- End DoDot:3
- +10 if $DATA(DIRUT)
- QUIT
- +11 WRITE !,ICD,?20,$JUSTIFY($PIECE(X,U),5),?30,$JUSTIFY($PIECE(X,U,2),5)
- End DoDot:2
- +12 if $DATA(DIRUT)
- QUIT
- End DoDot:1
- +13 if $DATA(DIRUT)
- QUIT
- CPT ;For CPT statistics.
- +1 if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD3
- +2 SET AS=0
- FOR
- SET AS=$ORDER(^TMP("ACKQWLD",$JOB,3,AS))
- if 'AS!($DATA(DIRUT))
- QUIT
- Begin DoDot:1
- +3 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD3
- +4 SET XAS=$SELECT(AS=203:"Audiology",1:"Speech")
- +5 WRITE !!,XAS,":"
- +6 SET CPT=0
- FOR
- SET CPT=$ORDER(^TMP("ACKQWLD",$JOB,3,AS,CPT))
- if 'CPT!($DATA(DIRUT))
- QUIT
- Begin DoDot:2
- +7 SET (ZIP,X)=""
- FOR
- SET ZIP=$ORDER(^TMP("ACKQWLD",$JOB,3,AS,CPT,ZIP))
- if ZIP=""!($DATA(DIRUT))
- QUIT
- Begin DoDot:3
- +8 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD3
- +9 SET Y=^TMP("ACKQWLD",$JOB,3,AS,CPT,ZIP)
- FOR I=1,2
- SET $PIECE(X,U,I)=$PIECE(X,U,I)+$PIECE(Y,U,I)
- End DoDot:3
- +10 if $DATA(DIRUT)
- QUIT
- +11 WRITE !,CPT,?20,$JUSTIFY($PIECE(X,U),5),?30,$JUSTIFY($PIECE(X,U,2),5)
- End DoDot:2
- +12 if $DATA(DIRUT)
- QUIT
- End DoDot:1
- +13 if $DATA(DIRUT)
- QUIT
- CDR ;For CDR information.
- +1 if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD4
- +2 SET (CDR,T)=0
- FOR
- SET CDR=$ORDER(^ACK(509850.7,ACKDA,4,CDR))
- if 'CDR!($DATA(DIRUT))
- QUIT
- Begin DoDot:1
- +3 IF $Y>(IOSL-5)
- if $EXTRACT(IOST)="C"
- DO PAUSE^ACKQUTL
- if $DATA(DIRUT)
- QUIT
- DO DHD
- DO HD4
- +4 SET X=^ACK(509850.7,ACKDA,4,CDR,0)
- +5 SET Y=$ORDER(^ACK(509850,"B",$PIECE(X,U),0))
- +6 SET Y=$PIECE($GET(^ACK(509850,+Y,0)),U,2)
- +7 WRITE !,$PIECE(X,U),?10,Y,?60,$JUSTIFY($PIECE(X,U,2),6,2)
- +8 SET T=T+$PIECE(X,U,2)
- End DoDot:1
- +9 if $DATA(DIRUT)
- QUIT
- +10 WRITE !,"Total:",?60,$JUSTIFY(T,6,2),!!
- +11 QUIT
- DHD ;
- +1 NEW X
- +2 SET ACKPG=ACKPG+1
- WRITE @IOF,"Printed: ",ACKCDT,?(IOM-8),"Page: ",ACKPG,!
- +3 FOR X="Audiology & Speech Pathology","Capitation Report","for",$$XDAT^ACKQUTL(ACKM)
- WRITE !
- DO CNTR^ACKQUTL(X)
- +4 WRITE !
- QUIT
- HD1 ;Header for all visits.
- +1 NEW X
- +2 WRITE !,"ZIP CODE",?21,"VISITS",?31,"UNIQUE",?42,"C&P"
- +3 DO LINE
- +4 QUIT
- HD2 ;Header for ICD statistics.
- +1 NEW X
- +2 WRITE !,"ICD",?21,"VISITS",?31,"UNIQUE"
- +3 DO LINE
- +4 QUIT
- HD3 ;Header for CPT statistics.
- +1 NEW X
- +2 WRITE !,"CPT",?21,"VISITS",?31,"UNIQUE"
- +3 DO LINE
- +4 QUIT
- HD4 ;Header for CDR statistics.
- +1 NEW X
- +2 WRITE !,"CDR ACCOUNT",?58,"% WORKLOAD"
- +3 DO LINE
- +4 QUIT
- LINE SET X=""
- SET $PIECE(X,"-",IOM)="-"
- WRITE !,X
- QUIT