ACKQWL1 ;AUG/JLTP - Compile A&SP Capitation Data - CONTINUED ;30 Jan 2013 3:15 PM
;;3.0;QUASAR;**21**;;Build 40
;
; Reference/IA
; $$CODEC^ICDEX - 5747
;
N CPT,DFN,DIE,DR,I,ICD,VAPA,VAERR
K ^TMP("ACKQWL",$J) D FYSTATS,MONTH,STUFF
Q
FYSTATS ;Gather uniques from begin of FY to now to screen against.
F ACKD=ACKBFY:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKM) D
.S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
..S ACKV(0)=$G(^ACK(509850.6,ACKV,0)) Q:ACKV(0)=""
..S DFN=$P(ACKV(0),U,2) Q:'DFN S ACKSTOP=$P($G(^ACK(509850.6,ACKV,2)),U) Q:ACKSTOP=""
..D ADD^VADPT S ACKZIP=$S(VAPA(6):VAPA(6),1:0)
..S ^TMP("ACKQWL",$J,"PRE",3,ACKSTOP,ACKZIP,DFN)="" ;UNIQUE VISITS THIS FY PRE THIS MONTH
..S ICD="" F S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD="" D
...S ^TMP("ACKQWL",$J,"PRE",1,ACKSTOP,ACKZIP,ICD,DFN)="" ;UNIQUE PTS W/ICD FY PRE THIS MO
..S CPT="" F S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT="" D
...S ^TMP("ACKQWL",$J,"PRE",2,ACKSTOP,ACKZIP,CPT,DFN)="" ;UNIQUE PTS W/CPT FY PRE THIS MO
Q
MONTH ;Gather stats from selected month.
F ACKD=ACKM:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKEM) D
.S ACKV=0 F S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV D
..S ACKV(0)=$G(^ACK(509850.6,ACKV,0)) Q:ACKV(0)=""
..S DFN=$P(ACKV(0),U,2) Q:'DFN S ACKSTOP=$P($G(^ACK(509850.6,ACKV,2)),U) Q:ACKSTOP=""
..D ADD^VADPT S ACKZIP=$S(VAPA(6):VAPA(6),1:0)
..S ^TMP("ACKQWL",$J,3,ACKSTOP,ACKZIP)=$G(^TMP("ACKQWL",$J,3,ACKSTOP,ACKZIP))+1
..S:$P(ACKV(0),U,5) ^TMP("ACKQWL",$J,4,ACKSTOP,ACKZIP)=$G(^TMP("ACKQWL",$J,4,ACKSTOP,ACKZIP))+1
..S:$P(ACKV(0),U,5) $P(^TMP("ACKQWL",$J,3,ACKSTOP,ACKZIP),U,2)=$P(^TMP("ACKQWL",$J,3,ACKSTOP,ACKZIP),U,2)+1
..S:'$D(^TMP("ACKQWL",$J,"PRE",3,ACKSTOP,ACKZIP,DFN)) ^TMP("ACKQWL",$J,"U",3,ACKSTOP,ACKZIP,DFN)=""
..S ICD="" F S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD="" D
...S ^TMP("ACKQWL",$J,1,ACKSTOP,ACKZIP,ICD)=$G(^TMP("ACKQWL",$J,1,ACKSTOP,ACKZIP,ICD))+1
...S:'$D(^TMP("ACKQWL",$J,"PRE",1,ACKSTOP,ACKZIP,ICD,DFN)) ^TMP("ACKQWL",$J,"U",1,ACKSTOP,ACKZIP,ICD,DFN)=""
..S CPT="" F S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT="" D
...S ^TMP("ACKQWL",$J,2,ACKSTOP,ACKZIP,CPT)=$G(^TMP("ACKQWL",$J,2,ACKSTOP,ACKZIP,CPT))+1
...S:'$D(^TMP("ACKQWL",$J,"PRE",2,ACKSTOP,ACKZIP,CPT,DFN)) ^TMP("ACKQWL",$J,"U",2,ACKSTOP,ACKZIP,CPT,DFN)=""
Q
STUFF ;Stuff data into A&SP WORKLOAD file (#509850.7).
;First by visit only.
F ACKSTOP="A","S" S ACKZIP=-1 F S ACKZIP=$O(^TMP("ACKQWL",$J,3,ACKSTOP,ACKZIP)) Q:ACKZIP="" D
.S ACKNV=^TMP("ACKQWL",$J,3,ACKSTOP,ACKZIP)
.S (ACKNU,I)=0 F S I=$O(^TMP("ACKQWL",$J,"U",3,ACKSTOP,ACKZIP,I)) Q:'I S ACKNU=ACKNU+1
.S ACKCP=+$G(^TMP("ACKQWL",$J,4,ACKSTOP,ACKZIP))
.S DIE="^ACK(509850.7,",DA=ACKDA,DR="3///"""_ACKZIP_""""
.S DR(2,509850.73)=".01///"_ACKZIP_";.02////"_ACKCP_";.03////"_ACKNV_";.04////"_ACKNU_";.05////^S X=$S(ACKSTOP=""A"":203,1:204)"
.D ^DIE K DIE,DA,DR
;Then by ICD.
F ACKSTOP="A","S" S ACKZIP=-1 F S ACKZIP=$O(^TMP("ACKQWL",$J,1,ACKSTOP,ACKZIP)) Q:ACKZIP="" D
.S ACKICP=0 F S ACKICP=$O(^TMP("ACKQWL",$J,1,ACKSTOP,ACKZIP,ACKICP)) Q:'ACKICP D
..S ACKICD=$$CODEC^ICDEX(80,ACKICP)
..S ACKNV=^TMP("ACKQWL",$J,1,ACKSTOP,ACKZIP,ACKICP)
..S (ACKNU,I)=0 F S I=$O(^TMP("ACKQWL",$J,"U",1,ACKSTOP,ACKZIP,ACKICP,I)) Q:'I S ACKNU=ACKNU+1
..S DIE="^ACK(509850.7,",DA=ACKDA,DR="1///"""_ACKICD_""""
..S DR(2,509850.71)=".01///"_ACKICD_";.02////"_ACKNV_";.03////"_ACKNU_";.04////^S X=$S(ACKSTOP=""A"":203,1:204);.05///"_ACKZIP
..D ^DIE K DIE,DA,DR
;Then by CPT.
F ACKSTOP="A","S" S ACKZIP=-1 F S ACKZIP=$O(^TMP("ACKQWL",$J,2,ACKSTOP,ACKZIP)) Q:ACKZIP="" D
.S ACKCPP=0 F S ACKCPP=$O(^TMP("ACKQWL",$J,2,ACKSTOP,ACKZIP,ACKCPP)) Q:'ACKCPP D
..S ACKCPT=$P($G(^ICPT(ACKCPP,0)),U)
..S ACKNV=^TMP("ACKQWL",$J,2,ACKSTOP,ACKZIP,ACKCPP)
..S (ACKNU,I)=0 F S I=$O(^TMP("ACKQWL",$J,"U",2,ACKSTOP,ACKZIP,ACKCPP,I)) Q:'I S ACKNU=ACKNU+1
..S DIE="^ACK(509850.7,",DA=ACKDA,DR="2///"""_ACKCPT_""""
..S DR(2,509850.72)=".01///"_ACKCPT_";.02////"_ACKNV_";.03////"_ACKNU_";.04////^S X=$S(ACKSTOP=""A"":203,1:204);.05///"_ACKZIP
..D ^DIE K DIE,DA,DR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQWL1 4162 printed Oct 16, 2024@18:33:44 Page 2
ACKQWL1 ;AUG/JLTP - Compile A&SP Capitation Data - CONTINUED ;30 Jan 2013 3:15 PM
+1 ;;3.0;QUASAR;**21**;;Build 40
+2 ;
+3 ; Reference/IA
+4 ; $$CODEC^ICDEX - 5747
+5 ;
+6 NEW CPT,DFN,DIE,DR,I,ICD,VAPA,VAERR
+7 KILL ^TMP("ACKQWL",$JOB)
DO FYSTATS
DO MONTH
DO STUFF
+8 QUIT
FYSTATS ;Gather uniques from begin of FY to now to screen against.
+1 FOR ACKD=ACKBFY:0
SET ACKD=$ORDER(^ACK(509850.6,"B",ACKD))
if 'ACKD!(ACKD>ACKM)
QUIT
Begin DoDot:1
+2 SET ACKV=0
FOR
SET ACKV=$ORDER(^ACK(509850.6,"B",ACKD,ACKV))
if 'ACKV
QUIT
Begin DoDot:2
+3 SET ACKV(0)=$GET(^ACK(509850.6,ACKV,0))
if ACKV(0)=""
QUIT
+4 SET DFN=$PIECE(ACKV(0),U,2)
if 'DFN
QUIT
SET ACKSTOP=$PIECE($GET(^ACK(509850.6,ACKV,2)),U)
if ACKSTOP=""
QUIT
+5 DO ADD^VADPT
SET ACKZIP=$SELECT(VAPA(6):VAPA(6),1:0)
+6 ;UNIQUE VISITS THIS FY PRE THIS MONTH
SET ^TMP("ACKQWL",$JOB,"PRE",3,ACKSTOP,ACKZIP,DFN)=""
+7 SET ICD=""
FOR
SET ICD=$ORDER(^ACK(509850.6,ACKV,1,"B",ICD))
if ICD=""
QUIT
Begin DoDot:3
+8 ;UNIQUE PTS W/ICD FY PRE THIS MO
SET ^TMP("ACKQWL",$JOB,"PRE",1,ACKSTOP,ACKZIP,ICD,DFN)=""
End DoDot:3
+9 SET CPT=""
FOR
SET CPT=$ORDER(^ACK(509850.6,ACKV,3,"B",CPT))
if CPT=""
QUIT
Begin DoDot:3
+10 ;UNIQUE PTS W/CPT FY PRE THIS MO
SET ^TMP("ACKQWL",$JOB,"PRE",2,ACKSTOP,ACKZIP,CPT,DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
MONTH ;Gather stats from selected month.
+1 FOR ACKD=ACKM:0
SET ACKD=$ORDER(^ACK(509850.6,"B",ACKD))
if 'ACKD!(ACKD>ACKEM)
QUIT
Begin DoDot:1
+2 SET ACKV=0
FOR
SET ACKV=$ORDER(^ACK(509850.6,"B",ACKD,ACKV))
if 'ACKV
QUIT
Begin DoDot:2
+3 SET ACKV(0)=$GET(^ACK(509850.6,ACKV,0))
if ACKV(0)=""
QUIT
+4 SET DFN=$PIECE(ACKV(0),U,2)
if 'DFN
QUIT
SET ACKSTOP=$PIECE($GET(^ACK(509850.6,ACKV,2)),U)
if ACKSTOP=""
QUIT
+5 DO ADD^VADPT
SET ACKZIP=$SELECT(VAPA(6):VAPA(6),1:0)
+6 SET ^TMP("ACKQWL",$JOB,3,ACKSTOP,ACKZIP)=$GET(^TMP("ACKQWL",$JOB,3,ACKSTOP,ACKZIP))+1
+7 if $PIECE(ACKV(0),U,5)
SET ^TMP("ACKQWL",$JOB,4,ACKSTOP,ACKZIP)=$GET(^TMP("ACKQWL",$JOB,4,ACKSTOP,ACKZIP))+1
+8 if $PIECE(ACKV(0),U,5)
SET $PIECE(^TMP("ACKQWL",$JOB,3,ACKSTOP,ACKZIP),U,2)=$PIECE(^TMP("ACKQWL",$JOB,3,ACKSTOP,ACKZIP),U,2)+1
+9 if '$DATA(^TMP("ACKQWL",$JOB,"PRE",3,ACKSTOP,ACKZIP,DFN))
SET ^TMP("ACKQWL",$JOB,"U",3,ACKSTOP,ACKZIP,DFN)=""
+10 SET ICD=""
FOR
SET ICD=$ORDER(^ACK(509850.6,ACKV,1,"B",ICD))
if ICD=""
QUIT
Begin DoDot:3
+11 SET ^TMP("ACKQWL",$JOB,1,ACKSTOP,ACKZIP,ICD)=$GET(^TMP("ACKQWL",$JOB,1,ACKSTOP,ACKZIP,ICD))+1
+12 if '$DATA(^TMP("ACKQWL",$JOB,"PRE",1,ACKSTOP,ACKZIP,ICD,DFN))
SET ^TMP("ACKQWL",$JOB,"U",1,ACKSTOP,ACKZIP,ICD,DFN)=""
End DoDot:3
+13 SET CPT=""
FOR
SET CPT=$ORDER(^ACK(509850.6,ACKV,3,"B",CPT))
if CPT=""
QUIT
Begin DoDot:3
+14 SET ^TMP("ACKQWL",$JOB,2,ACKSTOP,ACKZIP,CPT)=$GET(^TMP("ACKQWL",$JOB,2,ACKSTOP,ACKZIP,CPT))+1
+15 if '$DATA(^TMP("ACKQWL",$JOB,"PRE",2,ACKSTOP,ACKZIP,CPT,DFN))
SET ^TMP("ACKQWL",$JOB,"U",2,ACKSTOP,ACKZIP,CPT,DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
STUFF ;Stuff data into A&SP WORKLOAD file (#509850.7).
+1 ;First by visit only.
+2 FOR ACKSTOP="A","S"
SET ACKZIP=-1
FOR
SET ACKZIP=$ORDER(^TMP("ACKQWL",$JOB,3,ACKSTOP,ACKZIP))
if ACKZIP=""
QUIT
Begin DoDot:1
+3 SET ACKNV=^TMP("ACKQWL",$JOB,3,ACKSTOP,ACKZIP)
+4 SET (ACKNU,I)=0
FOR
SET I=$ORDER(^TMP("ACKQWL",$JOB,"U",3,ACKSTOP,ACKZIP,I))
if 'I
QUIT
SET ACKNU=ACKNU+1
+5 SET ACKCP=+$GET(^TMP("ACKQWL",$JOB,4,ACKSTOP,ACKZIP))
+6 SET DIE="^ACK(509850.7,"
SET DA=ACKDA
SET DR="3///"""_ACKZIP_""""
+7 SET DR(2,509850.73)=".01///"_ACKZIP_";.02////"_ACKCP_";.03////"_ACKNV_";.04////"_ACKNU_";.05////^S X=$S(ACKSTOP=""A"":203,1:204)"
+8 DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+9 ;Then by ICD.
+10 FOR ACKSTOP="A","S"
SET ACKZIP=-1
FOR
SET ACKZIP=$ORDER(^TMP("ACKQWL",$JOB,1,ACKSTOP,ACKZIP))
if ACKZIP=""
QUIT
Begin DoDot:1
+11 SET ACKICP=0
FOR
SET ACKICP=$ORDER(^TMP("ACKQWL",$JOB,1,ACKSTOP,ACKZIP,ACKICP))
if 'ACKICP
QUIT
Begin DoDot:2
+12 SET ACKICD=$$CODEC^ICDEX(80,ACKICP)
+13 SET ACKNV=^TMP("ACKQWL",$JOB,1,ACKSTOP,ACKZIP,ACKICP)
+14 SET (ACKNU,I)=0
FOR
SET I=$ORDER(^TMP("ACKQWL",$JOB,"U",1,ACKSTOP,ACKZIP,ACKICP,I))
if 'I
QUIT
SET ACKNU=ACKNU+1
+15 SET DIE="^ACK(509850.7,"
SET DA=ACKDA
SET DR="1///"""_ACKICD_""""
+16 SET DR(2,509850.71)=".01///"_ACKICD_";.02////"_ACKNV_";.03////"_ACKNU_";.04////^S X=$S(ACKSTOP=""A"":203,1:204);.05///"_ACKZIP
+17 DO ^DIE
KILL DIE,DA,DR
End DoDot:2
End DoDot:1
+18 ;Then by CPT.
+19 FOR ACKSTOP="A","S"
SET ACKZIP=-1
FOR
SET ACKZIP=$ORDER(^TMP("ACKQWL",$JOB,2,ACKSTOP,ACKZIP))
if ACKZIP=""
QUIT
Begin DoDot:1
+20 SET ACKCPP=0
FOR
SET ACKCPP=$ORDER(^TMP("ACKQWL",$JOB,2,ACKSTOP,ACKZIP,ACKCPP))
if 'ACKCPP
QUIT
Begin DoDot:2
+21 SET ACKCPT=$PIECE($GET(^ICPT(ACKCPP,0)),U)
+22 SET ACKNV=^TMP("ACKQWL",$JOB,2,ACKSTOP,ACKZIP,ACKCPP)
+23 SET (ACKNU,I)=0
FOR
SET I=$ORDER(^TMP("ACKQWL",$JOB,"U",2,ACKSTOP,ACKZIP,ACKCPP,I))
if 'I
QUIT
SET ACKNU=ACKNU+1
+24 SET DIE="^ACK(509850.7,"
SET DA=ACKDA
SET DR="2///"""_ACKCPT_""""
+25 SET DR(2,509850.72)=".01///"_ACKCPT_";.02////"_ACKNV_";.03////"_ACKNU_";.04////^S X=$S(ACKSTOP=""A"":203,1:204);.05///"_ACKZIP
+26 DO ^DIE
KILL DIE,DA,DR
End DoDot:2
End DoDot:1
