ACKQDWL1 ;AUG/JLTP HCIOFO/BH-Compile A&SP Capitation Data - CONTINUED ; [ 12/05/95 12:03 PM ]
;;3.0;QUASAR;**1**;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
N CPT,DFN,DIE,DR,I,ICD,VAPA,VAERR,CPTIEN,ICDIEN
K ^TMP("ACKQWL",$J) D FYSTATS,MONTH,STUFF
Q
;
FYSTATS ;
; Create array of Selected Divisions
N ACKQQK6,ACK1,ACKQQEC,EC
S ACK1=""
F S ACK1=$O(ACKDIV(ACK1)) Q:ACK1="" D
. S ACKDIVS($P(ACKDIV(ACK1),U,1))=""
;
; 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=$$GET1^DIQ(509850.6,ACKV_",",4,"I") Q:ACKSTOP=""
..S ACKREDIT=$S(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
..S ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I") I ACKVDVN="" Q
..Q:'$D(ACKDIVS(ACKVDVN))
..;
..S ACKZIP=$$ZIP(DFN)
..; Unique Visit this FY PRE this month
..S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
..S ICD="" F S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD="" D
...; Unique PTS W/ICD FY PRE this Month
...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
..S CPT="" F S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT="" D
...; Unique PTS W/CPT FY PRE this Month
...S ACKQQK6="" S ACKQQK6=$O(^ACK(509850.6,ACKV,3,"B",CPT,ACKQQK6))
...I ACKQQK6="" Q
...S ACKQQEC=$$GET1^DIQ(509850.61,ACKQQK6_","_ACKV_",",.07)
...I ACKQQEC'="" Q ; Entry created by EC code
...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
..S EC="" F S EC=$O(^ACK(509850.6,ACKV,7,"B",EC)) Q:EC="" D
...; Unique PTS W/EC FY PRE this Month
...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
Q
;
ZIP(DFN) ; Pass back ZIP code for patient
D ADD^VADPT S ACKZIP=$S(VAPA(6):VAPA(6),1:0)
K VAPA
Q ACKZIP
;
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 ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I") Q:'$D(ACKDIVS(ACKVDVN))
..S ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I") Q:ACKSTOP=""
..S ACKREDIT=$S(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
..S ACKTELE=0 I ACKSTOP="AT"!(ACKSTOP="ST") S ACKTELE=1
..S ACKZIP=$$ZIP(DFN)
..;
..; Add to the clinic counts within stop code if not telephone
..I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,1)+1
..; ....and if telephone
..I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,2)+1
..; If C&P add one to the count within Audiology or Speech
..I $P(ACKV(0),U,5) D
...S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,4)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,4)+1
...;
..;
..; Add Unique entry if not on the previous Fiscal Year list
..I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)) D
...S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
..;
..;
..;
..S ICD="" F S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD="" D
...S ICDIEN=""
...F S ICDIEN=$O(^ACK(509850.6,ACKV,1,"B",ICD,ICDIEN)) Q:ICDIEN="" D
....I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD)),U,1)+1
....;
....I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD)),U,2)+1
....;
...I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)) D
....S $P(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,1,ACKREDIT,ICD)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
..;
..S CPT="" N ACKQQUIT
..F S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT="" D
...S CPTIEN="",ACKQQUIT=""
...F S CPTIEN=$O(^ACK(509850.6,ACKV,3,"B",CPT,CPTIEN)) Q:CPTIEN="" D
....S ACKQQUIT=$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.07)
....I ACKQQUIT'="" Q ; Entry created by EC code
....I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT)),U,1)+$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.03,"I")
....;
....I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT)),U,2)+$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.03,"I")
....;
...I ACKQQUIT="",'$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)) D
....S $P(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,2,ACKREDIT,CPT)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
...S ACKQQUIT=""
..;
..;
..S EC=""
..F S EC=$O(^ACK(509850.6,ACKV,7,"B",EC)) Q:EC="" D
...S ECIEN=""
...F S ECIEN=$O(^ACK(509850.6,ACKV,7,"B",EC,ECIEN)) Q:ECIEN="" D
....I 'ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC),U,1)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC)),U,1)+$$GET1^DIQ(509850.615,ECIEN_","_ACKV_",",.03,"I")
....;
....I ACKTELE S $P(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC),U,2)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC)),U,2)+$$GET1^DIQ(509850.615,ECIEN_","_ACKV_",",.03,"I")
....;
...I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)) D
....S $P(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC),U,3)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,5,ACKREDIT,EC)),U,3)+1,^TMP("ACKQWL",$J,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
Q
;
STUFF ;
;
K ^TMP("ACKQWL",$J,"U")
K ^TMP("ACKQWL",$J,"PRE")
N ACKD,ACKTYPE,ACKCLIN,ACKCODE,ACKSTR
;
S (ACKD,ACKTYPE,ACKCLIN,ACKCODE)=""
;
F S ACKD=$O(^TMP("ACKQWL",$J,ACKD)) Q:ACKD="" D
.F S ACKTYPE=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE)) Q:ACKTYPE="" D
..F S ACKCLIN=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN)) Q:ACKCLIN="" D
...F S ACKCODE=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN,ACKCODE)) Q:ACKCODE="" D
....;
....S ACKSTR=^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN,ACKCODE)
....S ACKC=ACKCODE
....;
....; Create new Workload file level to write data to.
.... S DIC="^ACK(509850.7,"_ACKDA_",5,"_ACKD_","_ACKTYPE_","
.... S DIC(0)="L",DIC("P")="509850.75"_ACKTYPE_"A"
.... S DA=ACKC,DA(2)=ACKDA,DA(1)=ACKD,X=ACKC ; DINUM=ACKC
.... K DD,DO D FILE^DICN
.... S ACKC=+$P(Y,U,1)
....;
....I ACKTYPE=1!(ACKTYPE=2)!(ACKTYPE=5) D Q
.....; File away results for ICD9 (ACKTYPE=1), CPT (ACKTYPE=2)
.....; and EC (ACKTYPE=5)
.....I ACKCLIN="A" D Q
......N ACKA
......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",10)=$P(ACKSTR,U,1)
......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",20)=$P(ACKSTR,U,2)
......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",30)=$P(ACKSTR,U,3)
......D FILE^DIE("","ACKA")
.....I ACKCLIN="S" D Q
......N ACKA
......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",40)=$P(ACKSTR,U,1)
......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",50)=$P(ACKSTR,U,2)
......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",60)=$P(ACKSTR,U,3)
......D FILE^DIE("","ACKA")
.....Q
.....;
....I ACKTYPE=3 D Q
.....; File away results for ZIP Codes (ACKTYPE=3)
.....I ACKCLIN="A" D Q
......N ACKA
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",10)=$P(ACKSTR,U,1)
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",20)=$P(ACKSTR,U,2)
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",30)=$P(ACKSTR,U,3)
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",40)=$P(ACKSTR,U,4)
......D FILE^DIE("","ACKA")
.....I ACKCLIN="S" D Q
......N ACKA
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",50)=$P(ACKSTR,U,1)
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",60)=$P(ACKSTR,U,2)
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",70)=$P(ACKSTR,U,3)
......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",80)=$P(ACKSTR,U,4)
......D FILE^DIE("","ACKA")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQDWL1 8523 printed Dec 13, 2024@02:32:07 Page 2
ACKQDWL1 ;AUG/JLTP HCIOFO/BH-Compile A&SP Capitation Data - CONTINUED ; [ 12/05/95 12:03 PM ]
+1 ;;3.0;QUASAR;**1**;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
+4 NEW CPT,DFN,DIE,DR,I,ICD,VAPA,VAERR,CPTIEN,ICDIEN
+5 KILL ^TMP("ACKQWL",$JOB)
DO FYSTATS
DO MONTH
DO STUFF
+6 QUIT
+7 ;
FYSTATS ;
+1 ; Create array of Selected Divisions
+2 NEW ACKQQK6,ACK1,ACKQQEC,EC
+3 SET ACK1=""
+4 FOR
SET ACK1=$ORDER(ACKDIV(ACK1))
if ACK1=""
QUIT
Begin DoDot:1
+5 SET ACKDIVS($PIECE(ACKDIV(ACK1),U,1))=""
End DoDot:1
+6 ;
+7 ; Gather uniques from begin of FY to now to screen against.
+8 FOR ACKD=ACKBFY:0
SET ACKD=$ORDER(^ACK(509850.6,"B",ACKD))
if 'ACKD!(ACKD>ACKM)
QUIT
Begin DoDot:1
+9 SET ACKV=0
FOR
SET ACKV=$ORDER(^ACK(509850.6,"B",ACKD,ACKV))
if 'ACKV
QUIT
Begin DoDot:2
+10 SET ACKV(0)=$GET(^ACK(509850.6,ACKV,0))
if ACKV(0)=""
QUIT
+11 SET DFN=$PIECE(ACKV(0),U,2)
if 'DFN
QUIT
+12 SET ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I")
if ACKSTOP=""
QUIT
+13 SET ACKREDIT=$SELECT(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
+14 SET ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I")
IF ACKVDVN=""
QUIT
+15 if '$DATA(ACKDIVS(ACKVDVN))
QUIT
+16 ;
+17 SET ACKZIP=$$ZIP(DFN)
+18 ; Unique Visit this FY PRE this month
+19 SET ^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
+20 SET ICD=""
FOR
SET ICD=$ORDER(^ACK(509850.6,ACKV,1,"B",ICD))
if ICD=""
QUIT
Begin DoDot:3
+21 ; Unique PTS W/ICD FY PRE this Month
+22 SET ^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
End DoDot:3
+23 SET CPT=""
FOR
SET CPT=$ORDER(^ACK(509850.6,ACKV,3,"B",CPT))
if CPT=""
QUIT
Begin DoDot:3
+24 ; Unique PTS W/CPT FY PRE this Month
+25 SET ACKQQK6=""
SET ACKQQK6=$ORDER(^ACK(509850.6,ACKV,3,"B",CPT,ACKQQK6))
+26 IF ACKQQK6=""
QUIT
+27 SET ACKQQEC=$$GET1^DIQ(509850.61,ACKQQK6_","_ACKV_",",.07)
+28 ; Entry created by EC code
IF ACKQQEC'=""
QUIT
+29 SET ^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
End DoDot:3
+30 SET EC=""
FOR
SET EC=$ORDER(^ACK(509850.6,ACKV,7,"B",EC))
if EC=""
QUIT
Begin DoDot:3
+31 ; Unique PTS W/EC FY PRE this Month
+32 SET ^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
ZIP(DFN) ; Pass back ZIP code for patient
+1 DO ADD^VADPT
SET ACKZIP=$SELECT(VAPA(6):VAPA(6),1:0)
+2 KILL VAPA
+3 QUIT ACKZIP
+4 ;
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
+5 SET ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I")
if '$DATA(ACKDIVS(ACKVDVN))
QUIT
+6 SET ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I")
if ACKSTOP=""
QUIT
+7 SET ACKREDIT=$SELECT(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
+8 SET ACKTELE=0
IF ACKSTOP="AT"!(ACKSTOP="ST")
SET ACKTELE=1
+9 SET ACKZIP=$$ZIP(DFN)
+10 ;
+11 ; Add to the clinic counts within stop code if not telephone
+12 IF 'ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP),U,1)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP)),U,1)+1
+13 ; ....and if telephone
+14 IF ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP),U,2)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP)),U,2)+1
+15 ; If C&P add one to the count within Audiology or Speech
+16 IF $PIECE(ACKV(0),U,5)
Begin DoDot:3
+17 SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP),U,4)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP)),U,4)+1
+18 ;
End DoDot:3
+19 ;
+20 ; Add Unique entry if not on the previous Fiscal Year list
+21 IF '$DATA(^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN))
IF '$DATA(^TMP("ACKQWL",$JOB,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN))
Begin DoDot:3
+22 SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP),U,3)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,3,ACKREDIT,ACKZIP)),U,3)+1
SET ^TMP("ACKQWL",$JOB,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
End DoDot:3
+23 ;
+24 ;
+25 ;
+26 SET ICD=""
FOR
SET ICD=$ORDER(^ACK(509850.6,ACKV,1,"B",ICD))
if ICD=""
QUIT
Begin DoDot:3
+27 SET ICDIEN=""
+28 FOR
SET ICDIEN=$ORDER(^ACK(509850.6,ACKV,1,"B",ICD,ICDIEN))
if ICDIEN=""
QUIT
Begin DoDot:4
+29 IF 'ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,1,ACKREDIT,ICD),U,1)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,1,ACKREDIT,ICD)),U,1)+1
+30 ;
+31 IF ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,1,ACKREDIT,ICD),U,2)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,1,ACKREDIT,ICD)),U,2)+1
+32 ;
End DoDot:4
+33 IF '$DATA(^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN))
IF '$DATA(^TMP("ACKQWL",$JOB,"U",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN))
Begin DoDot:4
+34 SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,1,ACKREDIT,ICD),U,3)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,1,ACKREDIT,ICD)),U,3)+1
SET ^TMP("ACKQWL",$JOB,"U",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
End DoDot:4
End DoDot:3
+35 ;
+36 SET CPT=""
NEW ACKQQUIT
+37 FOR
SET CPT=$ORDER(^ACK(509850.6,ACKV,3,"B",CPT))
if CPT=""
QUIT
Begin DoDot:3
+38 SET CPTIEN=""
SET ACKQQUIT=""
+39 FOR
SET CPTIEN=$ORDER(^ACK(509850.6,ACKV,3,"B",CPT,CPTIEN))
if CPTIEN=""
QUIT
Begin DoDot:4
+40 SET ACKQQUIT=$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.07)
+41 ; Entry created by EC code
IF ACKQQUIT'=""
QUIT
+42 IF 'ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,2,ACKREDIT,CPT),U,1)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,2,ACKREDIT,CPT)),U,1)+$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.03,"I")
+43 ;
+44 IF ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,2,ACKREDIT,CPT),U,2)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,2,ACKREDIT,CPT)),U,2)+$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.03,"I")
+45 ;
End DoDot:4
+46 IF ACKQQUIT=""
IF '$DATA(^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN))
IF '$DATA(^TMP("ACKQWL",$JOB,"U",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN))
Begin DoDot:4
+47 SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,2,ACKREDIT,CPT),U,3)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,2,ACKREDIT,CPT)),U,3)+1
SET ^TMP("ACKQWL",$JOB,"U",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
End DoDot:4
+48 SET ACKQQUIT=""
End DoDot:3
+49 ;
+50 ;
+51 SET EC=""
+52 FOR
SET EC=$ORDER(^ACK(509850.6,ACKV,7,"B",EC))
if EC=""
QUIT
Begin DoDot:3
+53 SET ECIEN=""
+54 FOR
SET ECIEN=$ORDER(^ACK(509850.6,ACKV,7,"B",EC,ECIEN))
if ECIEN=""
QUIT
Begin DoDot:4
+55 IF 'ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,5,ACKREDIT,EC),U,1)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,5,ACKREDIT,EC)),U,1)+$$GET1^DIQ(509850.615,ECIEN_","_ACKV_",",.03,"I")
+56 ;
+57 IF ACKTELE
SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,5,ACKREDIT,EC),U,2)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,5,ACKREDIT,EC)),U,2)+$$GET1^DIQ(509850.615,ECIEN_","_ACKV_",",.03,"I")
+58 ;
End DoDot:4
+59 IF '$DATA(^TMP("ACKQWL",$JOB,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN))
IF '$DATA(^TMP("ACKQWL",$JOB,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN))
Begin DoDot:4
+60 SET $PIECE(^TMP("ACKQWL",$JOB,ACKVDVN,5,ACKREDIT,EC),U,3)=$PIECE($GET(^TMP("ACKQWL",$JOB,ACKVDVN,5,ACKREDIT,EC)),U,3)+1
SET ^TMP("ACKQWL",$JOB,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+61 QUIT
+62 ;
STUFF ;
+1 ;
+2 KILL ^TMP("ACKQWL",$JOB,"U")
+3 KILL ^TMP("ACKQWL",$JOB,"PRE")
+4 NEW ACKD,ACKTYPE,ACKCLIN,ACKCODE,ACKSTR
+5 ;
+6 SET (ACKD,ACKTYPE,ACKCLIN,ACKCODE)=""
+7 ;
+8 FOR
SET ACKD=$ORDER(^TMP("ACKQWL",$JOB,ACKD))
if ACKD=""
QUIT
Begin DoDot:1
+9 FOR
SET ACKTYPE=$ORDER(^TMP("ACKQWL",$JOB,ACKD,ACKTYPE))
if ACKTYPE=""
QUIT
Begin DoDot:2
+10 FOR
SET ACKCLIN=$ORDER(^TMP("ACKQWL",$JOB,ACKD,ACKTYPE,ACKCLIN))
if ACKCLIN=""
QUIT
Begin DoDot:3
+11 FOR
SET ACKCODE=$ORDER(^TMP("ACKQWL",$JOB,ACKD,ACKTYPE,ACKCLIN,ACKCODE))
if ACKCODE=""
QUIT
Begin DoDot:4
+12 ;
+13 SET ACKSTR=^TMP("ACKQWL",$JOB,ACKD,ACKTYPE,ACKCLIN,ACKCODE)
+14 SET ACKC=ACKCODE
+15 ;
+16 ; Create new Workload file level to write data to.
+17 SET DIC="^ACK(509850.7,"_ACKDA_",5,"_ACKD_","_ACKTYPE_","
+18 SET DIC(0)="L"
SET DIC("P")="509850.75"_ACKTYPE_"A"
+19 ; DINUM=ACKC
SET DA=ACKC
SET DA(2)=ACKDA
SET DA(1)=ACKD
SET X=ACKC
+20 KILL DD,DO
DO FILE^DICN
+21 SET ACKC=+$PIECE(Y,U,1)
+22 ;
+23 IF ACKTYPE=1!(ACKTYPE=2)!(ACKTYPE=5)
Begin DoDot:5
+24 ; File away results for ICD9 (ACKTYPE=1), CPT (ACKTYPE=2)
+25 ; and EC (ACKTYPE=5)
+26 IF ACKCLIN="A"
Begin DoDot:6
+27 NEW ACKA
+28 SET ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",10)=$PIECE(ACKSTR,U,1)
+29 SET ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",20)=$PIECE(ACKSTR,U,2)
+30 SET ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",30)=$PIECE(ACKSTR,U,3)
+31 DO FILE^DIE("","ACKA")
End DoDot:6
QUIT
+32 IF ACKCLIN="S"
Begin DoDot:6
+33 NEW ACKA
+34 SET ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",40)=$PIECE(ACKSTR,U,1)
+35 SET ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",50)=$PIECE(ACKSTR,U,2)
+36 SET ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",60)=$PIECE(ACKSTR,U,3)
+37 DO FILE^DIE("","ACKA")
End DoDot:6
QUIT
+38 QUIT
+39 ;
End DoDot:5
QUIT
+40 IF ACKTYPE=3
Begin DoDot:5
+41 ; File away results for ZIP Codes (ACKTYPE=3)
+42 IF ACKCLIN="A"
Begin DoDot:6
+43 NEW ACKA
+44 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",10)=$PIECE(ACKSTR,U,1)
+45 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",20)=$PIECE(ACKSTR,U,2)
+46 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",30)=$PIECE(ACKSTR,U,3)
+47 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",40)=$PIECE(ACKSTR,U,4)
+48 DO FILE^DIE("","ACKA")
End DoDot:6
QUIT
+49 IF ACKCLIN="S"
Begin DoDot:6
+50 NEW ACKA
+51 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",50)=$PIECE(ACKSTR,U,1)
+52 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",60)=$PIECE(ACKSTR,U,2)
+53 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",70)=$PIECE(ACKSTR,U,3)
+54 SET ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",80)=$PIECE(ACKSTR,U,4)
+55 DO FILE^DIE("","ACKA")
End DoDot:6
QUIT
End DoDot:5
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+56 QUIT
+57 ;
