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 Apr 09, 2024@21:35 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
