source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQDWL1.m@ 1310

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
 ;