Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACKQDWL1

ACKQDWL1.m

Go to the documentation of this file. 
  1. 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
  1.  ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
  1.  ;
  1.  N CPT,DFN,DIE,DR,I,ICD,VAPA,VAERR,CPTIEN,ICDIEN
  1.  K ^TMP("ACKQWL",$J) D FYSTATS,MONTH,STUFF
  1.  Q
  1.  ;
  1. FYSTATS ;
  1.  ;  Create array of Selected Divisions
  1.  N ACKQQK6,ACK1,ACKQQEC,EC
  1.  S ACK1=""
  1.  F  S ACK1=$O(ACKDIV(ACK1)) Q:ACK1=""  D
  1.  . S ACKDIVS($P(ACKDIV(ACK1),U,1))=""
  1.  ;
  1.  ;  Gather uniques from begin of FY to now to screen against.
  1.  F ACKD=ACKBFY:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKM)  D
  1.  .S ACKV=0 F  S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV  D
  1.  ..S ACKV(0)=$G(^ACK(509850.6,ACKV,0)) Q:ACKV(0)=""
  1.  ..S DFN=$P(ACKV(0),U,2) Q:'DFN
  1.  ..S ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I") Q:ACKSTOP=""
  1.  ..S ACKREDIT=$S(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
  1.  ..S ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I") I ACKVDVN="" Q 
  1.  ..Q:'$D(ACKDIVS(ACKVDVN))
  1.  ..;
  1.  ..S ACKZIP=$$ZIP(DFN)
  1.  ..;  Unique Visit this FY PRE this month
  1.  ..S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)=""
  1.  ..S ICD="" F  S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD=""  D
  1.  ...;  Unique PTS W/ICD FY PRE this Month 
  1.  ...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,1,ACKREDIT,ACKZIP,ICD,DFN)=""
  1.  ..S CPT="" F  S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT=""  D
  1.  ...;  Unique PTS W/CPT FY PRE this Month
  1.  ...S ACKQQK6="" S ACKQQK6=$O(^ACK(509850.6,ACKV,3,"B",CPT,ACKQQK6))
  1.  ...I ACKQQK6="" Q
  1.  ...S ACKQQEC=$$GET1^DIQ(509850.61,ACKQQK6_","_ACKV_",",.07)
  1.  ...I ACKQQEC'="" Q    ;  Entry created by EC code
  1.  ...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,2,ACKREDIT,ACKZIP,CPT,DFN)=""
  1.  ..S EC="" F  S EC=$O(^ACK(509850.6,ACKV,7,"B",EC)) Q:EC=""  D
  1.  ...;  Unique PTS W/EC FY PRE this Month
  1.  ...S ^TMP("ACKQWL",$J,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)=""
  1.  Q
  1.  ;
  1. ZIP(DFN) ;  Pass back ZIP code for patient
  1.  D ADD^VADPT S ACKZIP=$S(VAPA(6):VAPA(6),1:0)
  1.  K VAPA
  1.  Q ACKZIP
  1.  ;
  1. MONTH ;  Gather stats from selected month.
  1.  F ACKD=ACKM:0 S ACKD=$O(^ACK(509850.6,"B",ACKD)) Q:'ACKD!(ACKD>ACKEM)  D
  1.  .S ACKV=0 F  S ACKV=$O(^ACK(509850.6,"B",ACKD,ACKV)) Q:'ACKV  D
  1.  ..S ACKV(0)=$G(^ACK(509850.6,ACKV,0)) Q:ACKV(0)=""
  1.  ..S DFN=$P(ACKV(0),U,2) Q:'DFN 
  1.  ..S ACKVDVN=$$GET1^DIQ(509850.6,ACKV_",",60,"I") Q:'$D(ACKDIVS(ACKVDVN)) 
  1.  ..S ACKSTOP=$$GET1^DIQ(509850.6,ACKV_",",4,"I") Q:ACKSTOP=""
  1.  ..S ACKREDIT=$S(ACKSTOP="A"!(ACKSTOP="AT"):"A",ACKSTOP="S"!(ACKSTOP="ST"):"S")
  1.  ..S ACKTELE=0 I ACKSTOP="AT"!(ACKSTOP="ST") S ACKTELE=1
  1.  ..S ACKZIP=$$ZIP(DFN)
  1.  ..;
  1.  ..;  Add to the clinic counts within stop code if not telephone
  1.  ..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
  1.  ..;  ....and if telephone
  1.  ..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
  1.  ..;  If C&P add one to the count within Audiology or Speech
  1.  ..I $P(ACKV(0),U,5) D
  1.  ...S $P(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP),U,4)=$P($G(^TMP("ACKQWL",$J,ACKVDVN,3,ACKREDIT,ACKZIP)),U,4)+1
  1.  ...;  
  1.  ..;
  1.  ..;  Add Unique entry if not on the previous Fiscal Year list
  1.  ..I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,3,ACKREDIT,ACKZIP,DFN)) D 
  1.  ...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)=""
  1.  ..;
  1.  ..;
  1.  ..;
  1.  ..S ICD="" F  S ICD=$O(^ACK(509850.6,ACKV,1,"B",ICD)) Q:ICD=""  D
  1.  ...S ICDIEN=""
  1.  ...F  S ICDIEN=$O(^ACK(509850.6,ACKV,1,"B",ICD,ICDIEN)) Q:ICDIEN=""  D
  1.  ....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
  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
  1.  ....;
  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
  1.  ....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)=""
  1.  ..;
  1.  ..S CPT="" N ACKQQUIT
  1.  ..F  S CPT=$O(^ACK(509850.6,ACKV,3,"B",CPT)) Q:CPT=""  D
  1.  ...S CPTIEN="",ACKQQUIT=""
  1.  ...F  S CPTIEN=$O(^ACK(509850.6,ACKV,3,"B",CPT,CPTIEN)) Q:CPTIEN=""  D
  1.  ....S ACKQQUIT=$$GET1^DIQ(509850.61,CPTIEN_","_ACKV_",",.07)
  1.  ....I ACKQQUIT'="" Q    ;  Entry created by EC code
  1.  ....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")
  1.  ....;
  1.  ....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")
  1.  ....;
  1.  ...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
  1.  ....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)=""
  1.  ...S ACKQQUIT=""
  1.  ..;
  1.  ..;
  1.  ..S EC=""
  1.  ..F  S EC=$O(^ACK(509850.6,ACKV,7,"B",EC)) Q:EC=""  D
  1.  ...S ECIEN=""
  1.  ...F  S ECIEN=$O(^ACK(509850.6,ACKV,7,"B",EC,ECIEN)) Q:ECIEN=""  D
  1.  ....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")
  1.  ....;
  1.  ....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")
  1.  ....;
  1.  ...I '$D(^TMP("ACKQWL",$J,"PRE",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)),'$D(^TMP("ACKQWL",$J,"U",ACKVDVN,5,ACKREDIT,ACKZIP,EC,DFN)) D
  1.  ....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)=""
  1.  Q
  1.  ;
  1. STUFF ;
  1.  ;
  1.  K ^TMP("ACKQWL",$J,"U")
  1.  K ^TMP("ACKQWL",$J,"PRE")
  1.  N ACKD,ACKTYPE,ACKCLIN,ACKCODE,ACKSTR
  1.  ;
  1.  S (ACKD,ACKTYPE,ACKCLIN,ACKCODE)=""
  1.  ;
  1.  F  S ACKD=$O(^TMP("ACKQWL",$J,ACKD)) Q:ACKD=""  D
  1.  .F  S ACKTYPE=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE)) Q:ACKTYPE=""  D
  1.  ..F  S ACKCLIN=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN)) Q:ACKCLIN=""  D
  1.  ...F  S ACKCODE=$O(^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN,ACKCODE)) Q:ACKCODE=""  D
  1.  ....;
  1.  ....S ACKSTR=^TMP("ACKQWL",$J,ACKD,ACKTYPE,ACKCLIN,ACKCODE)
  1.  ....S ACKC=ACKCODE
  1.  ....;
  1.  ....;  Create new Workload file level to write data to. 
  1.  .... S DIC="^ACK(509850.7,"_ACKDA_",5,"_ACKD_","_ACKTYPE_","
  1.  .... S DIC(0)="L",DIC("P")="509850.75"_ACKTYPE_"A"
  1.  .... S DA=ACKC,DA(2)=ACKDA,DA(1)=ACKD,X=ACKC  ;  DINUM=ACKC
  1.  .... K DD,DO D FILE^DICN
  1.  .... S ACKC=+$P(Y,U,1)
  1.  ....;
  1.  ....I ACKTYPE=1!(ACKTYPE=2)!(ACKTYPE=5) D  Q
  1.  .....;  File away results for ICD9 (ACKTYPE=1), CPT (ACKTYPE=2)
  1.  .....;                        and EC (ACKTYPE=5) 
  1.  .....I ACKCLIN="A" D  Q
  1.  ......N ACKA
  1.  ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",10)=$P(ACKSTR,U,1)
  1.  ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",20)=$P(ACKSTR,U,2)
  1.  ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",30)=$P(ACKSTR,U,3)
  1.  ......D FILE^DIE("","ACKA")
  1.  .....I ACKCLIN="S" D  Q
  1.  ......N ACKA
  1.  ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",40)=$P(ACKSTR,U,1)
  1.  ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",50)=$P(ACKSTR,U,2)
  1.  ......S ACKA(509850.75_ACKTYPE,ACKC_","_ACKD_","_ACKDA_",",60)=$P(ACKSTR,U,3)
  1.  ......D FILE^DIE("","ACKA")
  1.  .....Q
  1.  .....;
  1.  ....I ACKTYPE=3 D  Q
  1.  .....;  File away results for ZIP Codes (ACKTYPE=3)
  1.  .....I ACKCLIN="A" D  Q
  1.  ......N ACKA
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",10)=$P(ACKSTR,U,1)
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",20)=$P(ACKSTR,U,2)
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",30)=$P(ACKSTR,U,3)
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",40)=$P(ACKSTR,U,4)
  1.  ......D FILE^DIE("","ACKA")
  1.  .....I ACKCLIN="S" D  Q
  1.  ......N ACKA
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",50)=$P(ACKSTR,U,1)
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",60)=$P(ACKSTR,U,2)
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",70)=$P(ACKSTR,U,3)
  1.  ......S ACKA(509850.753,ACKC_","_ACKD_","_ACKDA_",",80)=$P(ACKSTR,U,4)
  1.  ......D FILE^DIE("","ACKA")
  1.  Q
  1.  ;