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

ACHSGAO.m

Go to the documentation of this file. 
  1. ACHSGAO ; IHS/OIT/FCJ -version 2-GAO REPORT-DENIAL AND DEF LIST BY ISSUE DATE ; 30 Jul 2010  10:39 AM
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,23**;JUNE 11, 2001;Build 43
  1.  ;;
  1. ST ;
  1.  K X2,X3
  1.  I '$D(DUZ(2)) W !,"DUZ(2) Must be set" Q
  1.  D ^ACHSVAR
  1.  K ^XTMP("ACHSGAO",$J)
  1.  ;SELECT FAC
  1.  D SEL Q:Y<0
  1.  ;
  1. BDT ; --- Beginning date
  1.  S ACHSBDT=$$DATE^ACHS("B","GAO UNMET NEED-DENIED SERVICES")
  1.  Q:$D(DUOUT)!(Y="")
  1.  G:ACHSBDT<1 EXT
  1.  ;
  1. EDT ; --- Ending date
  1.  S ACHSEDT=$$DATE^ACHS("E","GAO UNMET NEED-DENIED SERVICES")
  1.  G:ACHSEDT<1 BDT
  1.  I $$EBB^ACHS(ACHSBDT,ACHSEDT) G BDT
  1.  ;
  1. A1 ;
  1.  S ACHSXHRN=0,ACHSIEN=0,ACHSCNT=0,ACHSDCT=0,ACHSLN=0
  1.  S Y=ACHSBDT X ^DD("DD") S ACHS("BDT")=Y,Y=ACHSEDT X ^DD("DD") S ACHS("EDT")=Y
  1.  S ACHST1=$$C^XBFUNC($S(ACHSBDT=1:"***   ALL UNMET NEED AND DENIED SERVICES   ***",1:"For the period "_ACHS("BDT")_" through "_ACHS("EDT")),80)
  1.  D BRPT^ACHSFU
  1.  D HDR
  1.  D LP1
  1.  D LP2
  1.  D SAV
  1.  D EXT
  1.  Q
  1. SEL ;SELECT FACILITY
  1.  S ACHSFAC="",DIC(0)="AE",DIC="^ACHSDEN("
  1.  D ^DIC
  1.  Q:Y<0
  1.  S ACHSFAC=+Y,ACHSFACN=$P(^AUTTLOC(ACHSFAC,0),U,10)
  1.  Q
  1. LP1 ; DENIALS
  1.  W !!,"Denials"
  1.  S ACHSISU=ACHSBDT-1
  1.  F  S ACHSISU=$O(^ACHSDEN(ACHSFAC,"D","AISSUE",ACHSISU)) Q:+ACHSISU=0!(ACHSISU>ACHSEDT)  D
  1.  .S DA="" F  S DA=$O(^ACHSDEN(ACHSFAC,"D","AISSUE",ACHSISU,DA)) Q:DA=""  D  Q:$D(DUOUT)!$D(DTOUT)
  1.  ..S ACHS(0)=$G(^ACHSDEN(ACHSFAC,"D",DA,0))
  1.  ..S (ACHSDTYP,ACHSREG,ACHSPTID,ACHSISDT,ACHSRDT,ACHSMDT,ACHSPRI,ACHSPDT,ACHSPRTY,ACHSSTYP)="",ACHS("$")=0
  1.  ..Q:ACHS(0)=""
  1.  ..Q:$P(ACHS(0),U,8)="Y"  ; CANCELLED REQUEST
  1.  ..I $P(ACHS(0),U,6)="N" Q:$P($G(^ACHSDEN(ACHSFAC,"D",DA,10)),U)=""  S ACHSXHRN=ACHSXHRN+1,ACHSPTID=ACHSFACN_"X"_$E(100000+ACHSXHRN,2,7),ACHSREG=0
  1.  ..I $P(ACHS(0),U,6)="Y" Q:$P(ACHS(0),U,7)=""  S ACHSHRN=$$HRN^ACHS($P(ACHS(0),U,7),ACHSFAC),ACHSPTID=ACHSFACN_$E(1000000+ACHSHRN,2,7),ACHSREG=1
  1.  ..Q:ACHSPTID=""
  1.  ..W "." S ACHSCNT=ACHSCNT+1
  1.  ..S Y=ACHSISU X ^DD("DD") S ACHSISDT=Y
  1.  ..;IF DENIAL IN RCIS THEN SET THE ACHSRDT REF DT AND THE ACHSMDT MANAGED CARE DATE
  1.  ..S ACHSREF="",ACHSREF=$O(^BMCREF("CD",$P(ACHS(0),U),ACHSREF))
  1.  ..I ACHSREF D
  1.  ...S Y=$P(^BMCREF(ACHSREF,0),U) X ^DD("DD") S ACHSRDT=Y
  1.  ...S Y=$P($G(^BMCREF(ACHSREF,11)),U,24) I Y X ^DD("DD") S ACHSMDT=Y
  1.  ...;IF PO IN RCIS THEN SET THE PAID DATE OF THE FIRST PO  ACHSPDT-FINAL PAY DATE OR FINAL INTERIUM PAY
  1.  ...I $D(^BMCREF(ACHSREF,41)) S ACHSDFN=0 F  S ACHSDFN=$O(^BMCREF(ACHSREF,41,ACHSDFN)) Q:ACHSDFN'?1N.N  D  Q:ACHSPDT
  1.  ....I $D(^ACHSF(ACHSFAC,"D",ACHSDFN,"PA")) S ACHSPTY="" D PDT
  1.  ..S ACHSPRI=$P($G(^ACHSMPRI($P($G(^ACHSDEN(ACHSFAC,"D",DA,400)),U,2),0)),U)
  1.  ..I $P($G(^ACHSDEN(ACHSFAC,"D",DA,100)),U)="Y" S (ACHS,ACHS1)="" D
  1.  ...S ACHS=$P($G(^ACHSDEN(ACHSFAC,"D",DA,100)),U,2)
  1.  ...Q:ACHS=""  S ACHS1=$P($G(^AUTTVNDR(ACHS,11)),U,3)
  1.  ...I ACHS1 S ACHSPRTY=$P(^AUTTVTYP(ACHS1,0),U,2)
  1.  ..S ACHS("$")=$S(+$P(^ACHSDEN(ACHSFAC,"D",DA,100),U,9):+$P(^(100),U,9),1:+$P(^(100),U,8))
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,200)) F DA(1)=0:0 S DA(1)=$O(^ACHSDEN(ACHSFAC,"D",DA,200,DA(1))) Q:'DA(1)  I $D(^(DA(1),0)) S ACHS("$")=ACHS("$")+$S(+$P(^(0),U,3):$P(^(0),U,3),1:+$P(^(0),U,2))
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,210)) F DA(1)=0:0 S DA(1)=$O(^ACHSDEN(ACHSFAC,"D",DA,210,DA(1))) Q:'DA(1)  I $D(^(DA(1),0)) S ACHS("$")=ACHS("$")+$S(+$P(^(0),U,7):+$P(^(0),U,7),1:+$P(^(0),U,6))
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,250)) S ACHSREA=$P($G(^ACHSDENS($P(^ACHSDEN(ACHSFAC,"D",DA,250),U),0)),U)
  1.  ..;DECISION-TEST $P(ACHS(0),U,8)="R" DEFAULT DENINED IF SET THEN REVERSED
  1.  ..S ACHSDEC=$S($P(ACHS(0),U,8):"REVERSED",1:"DENINED")
  1.  ..;ACHSSTYP-TYPE OF SERVICE ACHSDTYP=SERVICES TYPE
  1.  ..S X="",X=$P($G(^ACHSDEN(ACHSFAC,"D",DA,100)),U,10) S ACHSSTYP=$S(X="I":"INPATIENT",X="O":"OUTPATIENT",X="A":"AMBULANCE","P":"PATIENT ESCORT","D":"DENTAL",1:"")
  1.  ..S X="",X=$P($G(^ACHSDEN(ACHSFAC,"D",DA,400)),U) S ACHSDTYP=$S(X="N":"NOT DEFERRED",X="S":"SURGICAL",X="E":"EVALUATION/DIAG",X="D":"DENTAL",X="M":"MENTAL HEALTH",X="C":"COSMETIC SURGERY",X="O":"OPHTHALMOLOGY",1:"")
  1.  ..S (LN2,LN3)="",LN2=ACHSSTYP_"^"_ACHSDTYP_"^"
  1.  ..;ICD AND CPT DATA
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,500)) S X=0 F  S X=$O(^ACHSDEN(ACHSFAC,"D",DA,500,X)) Q:X'?1N.N  D
  1.  ...;S LN2="^"_$P(^ICD9($P(^ACHSDEN(ACHSFAC,"D",DA,500,X,0),U),0),U)  ;ACHS*3.1*23
  1.  ...S LN2="^"_$P($$ICDDX^ICDEX($P(^ACHSDEN(ACHSFAC,"D",DA,500,X,0),U),,,"I"),2)  ;ACHS*3.1*23
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,700)) S X=0 F  S X=$O(^ACHSDEN(ACHSFAC,"D",DA,700,X)) Q:X'?1N.N  D
  1.  ...;S LN3=$P(^ICPT($P(^ACHSDEN(ACHSFAC,"D",DA,700,X,0),U),0),U)_"^"  ;ACHS*3.1*23
  1.  ...S LN3=$P($$CPT^ICPTCOD($P(^ACHSDEN(ACHSFAC,"D",DA,700,X,0),U)),U,2)_"^"  ;ACHS*3.1*23
  1.  ..D XTMP
  1.  ..;APPEALS 430 AND 431 IS THE MULTIPLE
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,431)) S X=0 F  S X=$O(^ACHSDEN(ACHSFAC,"D",DA,431,X)) Q:X'?1N.N  D
  1.  ...S ACHSAPST="",ACHSAP="",ACHSAPST=$P(^ACHSDEN(ACHSFAC,"D",DA,431,X,0),U,2)
  1.  ...Q:ACHSAPST=""
  1.  ...I ACHSAPST,$D(^ACHSDENA(ACHSAPST)) S ACHSAP=$P(^ACHSDENA(ACHSAPST,0),U)
  1.  ...S ACHSIEN=ACHSIEN+1
  1.  ...S ^XTMP($J,"ACHSGAO",ACHSIEN)=ACHSLN_"D^"_ACHSAP_"^"_$P(^ACHSDEN(ACHSFAC,"D",DA,431,X,0),U,5)
  1.  ..;COMMENTS FIELD 900 WORD
  1.  ..I $D(^ACHSDEN(ACHSFAC,"D",DA,900)) S X=0 F  S X=$O(^ACHSDEN(ACHSFAC,"D",DA,900,X)) Q:X'?1N.N  D
  1.  ...S ACHSIEN=ACHSIEN+1
  1.  ...S ^XTMP("ACHSGAO",$J,ACHSIEN)=ACHSLN_"E^"_^ACHSDEN(ACHSFAC,"D",DA,900,X,0)
  1.  Q
  1. LP2 ;UNMET NEED (DEFERRALS)
  1.  K DUOUT,DTOUT
  1.  W !,"Unmet Need Services"
  1.  S ACHSISU=ACHSBDT-1
  1.  F  S ACHSISU=$O(^ACHSDEF(ACHSFAC,"D","AISSUE",ACHSISU)) Q:+ACHSISU=0!(ACHSISU>ACHSEDT)  D
  1.  .S DA="" F  S DA=$O(^ACHSDEF(ACHSFAC,"D","AISSUE",ACHSISU,DA)) Q:DA=""  D  Q:$D(DUOUT)!$D(DTOUT)
  1.  ..S ACHS(0)=$G(^ACHSDEF(ACHSFAC,"D",DA,0))
  1.  ..S (ACHSDTYP,ACHSREG,ACHSPTID,ACHSISDT,ACHSRDT,ACHSMDT,ACHSPRI,ACHSPDT,ACHSPRTY,ACHSSTYP,ACHSCAT,ACHSPO)="",ACHS("$")=0
  1.  ..Q:ACHS(0)=""
  1.  ..Q:$P(ACHS(0),U,8)="Y"  ; CANCELLED REQUEST
  1.  ..I $P(ACHS(0),U,5)="N" Q:$P(ACHS(0),U,7)=""  S ACHSXHRN=ACHSXHRN+1,ACHSPTID=ACHSFACN_"X"_$E(100000+ACHSXHRN,2,7),ACHSREG=0
  1.  ..I $P(ACHS(0),U,5)="Y" Q:$P(ACHS(0),U,6)=""  S ACHSHRN=$$HRN^ACHS($P(ACHS(0),U,6),ACHSFAC),ACHSPTID=ACHSFACN_$E(1000000+ACHSHRN,2,7),ACHSREG=1
  1.  ..Q:ACHSPTID=""
  1.  ..W "." S ACHSDCT=ACHSDCT+1
  1.  ..S Y=ACHSISU X ^DD("DD") S ACHSISDT=Y
  1.  ..;PO SET IF PAID
  1.  ..S ACHSPO=$P($G(^ACHSDEF(ACHSFAC,"D",DA,500)),U,8) I ACHSPO D
  1.  ...S ACHSPO=1_$E(ACHSPO,2)_$E(ACHSPO,8,12) S ACHSDFN="",ACHSDFN=$O(^ACHSF(ACHSFAC,"D","B",ACHSPO,0))
  1.  ...Q:'ACHSDFN
  1.  ...I $D(^ACHSF(ACHSFAC,"D",ACHSDFN,"PA")) S ACHSPTY="" D PDT
  1.  ..S ACHS("$")=$P($G(^ACHSDEF(ACHSFAC,"D",DA,100)),U,5)
  1.  ..S ACHSREA="UNMET NEED",ACHSDEC="DEFFERED"
  1.  ..;ACHSSTYP-TYPE OF SERVICE ACHSDTYP=SERVICES TYPE
  1.  ..S X="",X=$P($G(^ACHSDEF(ACHSFAC,"D",DA,100)),U,2) S ACHSSTYP=$S(X="I":"INPATIENT",X="O":"OUTPATIENT",1:"")
  1.  ..S X="",X=$P($G(^ACHSDEF(ACHSFAC,"D",DA,100)),U) I X S ACHSDTYP=$P(^ACHSDFC(X,0),U)
  1.  ..S X1="",X1=$P($G(^ACHSDEF(ACHSFAC,"D",DA,100)),U,4) I X1 S ACHSCAT=$P(^ACHSDFC(X,1,X1,0),U)
  1.  ..S (LN2,LN3)="",LN2=ACHSSTYP_"^"_ACHSDTYP_"^"_ACHSCAT
  1.  ..;ICD AND CPT DATA
  1.  ..I $D(^ACHSDEF(ACHSFAC,"D",DA,200)) S X=0 F  S X=$O(^ACHSDEF(ACHSFAC,"D",DA,200,X)) Q:X'?1N.N  D
  1.  ...;S LN2=LN2_"^"_$P(^ICD9($P(^ACHSDEF(ACHSFAC,"D",DA,200,X,0),U),0),U)  ;ACHS*3.1*23
  1.  ...S LN2=LN2_"^"_$P($$ICDDX^ICDCODE($P(^ACHSDEF(ACHSFAC,"D",DA,200,X,0),U)),U,2)  ;ACHS*3.1*23
  1.  ..I $D(^ACHSDEF(ACHSFAC,"D",DA,300)) S X=0 F  S X=$O(^ACHSDEF(ACHSFAC,"D",DA,300,X)) Q:X'?1N.N  D
  1.  ...;S LN3=$P(^ICPT($P(^ACHSDEF(ACHSFAC,"D",DA,300,X,0),U),0),U)_"^"          ;ACHS*3.1*23
  1.  ...S LN3=$P($$CPT^ICPTCOD($P(^ACHSDEF(ACHSFAC,"D",DA,300,X,0),U)),U,2)_"^"  ;ACHS*3.1*23
  1.  ..D XTMP
  1.  ..;COMMENTS FIELD 400 WORD
  1.  ..I $D(^ACHSDEF(ACHSFAC,"D",DA,400)) S X=0 F  S X=$O(^ACHSDEF(ACHSFAC,"D",DA,400,X)) Q:X'?1N.N  D
  1.  ...S ACHSIEN=ACHSIEN+1
  1.  ...S ^XTMP("ACHSGAO",$J,ACHSIEN)=ACHSLN_"E^"_^ACHSDEF(ACHSFAC,"D",DA,400,X,0)
  1.  Q
  1. XTMP ;SET XTMP GLOBAL WITH DATA
  1.  ;ACHSISDT-ISSUE DATE; ACHSPTID-PAT ID; ACHSRDT-REF INIT DT; ACHSMDT-MANAGE CARE DECESION DT;ACHSPDT-FINAL PAY DATE; ACHSPRI-CHS PRIORITY;
  1.  ;ACHSPRTY-VENDOR TYPE; ACHS("$")-ESTIMATED AMOUNT FOR ALL PROVIDERS;ACHSREA-PRIM DENIAL REASON;ACHSDEC-REVERSED-DENIED-DEFFERED
  1.  S ACHSIEN=ACHSIEN+1,ACHSLN=ACHSLN+1
  1.  S ^XTMP("ACHSGAO",$J,ACHSIEN)=ACHSLN_"A"_"^"_ACHSISDT_"^"_ACHSPTID_"^"_ACHSRDT_"^"_ACHSMDT_"^"_ACHSPDT_"^"_ACHSPRI_"^"_ACHSPRTY_"^"_ACHS("$")_"^"_ACHSREA_"^"_ACHSDEC
  1.  S ACHSIEN=ACHSIEN+1,^XTMP("ACHSGAO",$J,ACHSIEN)=ACHSLN_"B^"_LN2
  1.  S ACHSIEN=ACHSIEN+1,^XTMP("ACHSGAO",$J,ACHSIEN)=ACHSLN_"C^"_LN3
  1.  Q
  1.  ;
  1. PDT ;SET PAY DATE IF AVAILABLE
  1.  S ACHSPTY=$P(^ACHSF(ACHSFAC,"D",ACHSDFN,"PA"),U,4)
  1.  S Y=$S(ACHSPTY="F":$P(^ACHSF(ACHSFAC,"D",ACHSDFN,"PA"),U,3),1:$P($G(^ACHSF(ACHSFAC,"D",ACHSDFN,"IP")),U,3))
  1.  I Y X ^DD("DD") S ACHSPDT=Y
  1.  Q
  1. SAV ;SAVE GLOBAL AND SEND TO AREA
  1.  N X1,XBCON,XBE,XBF,XBQ,XBQSHO,XBFN,XBGL,XBFLT,XBMED,XBS1
  1.  S XBFN="chsgao"_ACHSFACN_".txt"
  1.  S XBGL="XTMP(("_$J_",""ACHSGAO"","
  1.  S XBF=$J
  1.  S XBE=$J
  1.  S XBFLT=1
  1.  S XBMED="F"
  1.  S XBCON=1
  1.  D ^XBGSAVE
  1.  Q
  1. EXT ;
  1.  W !!,"TOTAL UNMET NEED:",ACHSCNT,?40,"TOTAL DEFFERALS: ",ACHSDCT
  1.  ;K ^XTMP("ACHSGAO",$J)
  1.  K ACHSDTYP,ACHSREG,ACHSPTID,ACHSISDT,ACHSRDT,ACHSMDT,ACHSPRI,ACHSPDT,ACHSPRTY,ACHSSTYP,ACHSFC,ACHSIEN,ACHSFYDT,ACHSFYWK,ACHSHRN
  1.  K ACHS1,ACHSACFY,ACHSAP,ACHSAPST,ACHSCAT,ACHSCFY,ACHSCNT,ACHSDCT,ACHSDEC,ACHSDFN,ACHSDTYP,ACHSERR,ACHSFAC,ACHSFACN,ACHSXHRN
  1.  K ACHSISDT,ACHSISU,ACHSLN,ACHSMDT,ACHSPDT,ACHSPO,ACHSPRI,ACHSPRTY,ACHSPTID,ACHSPTY,ACHSRDT,ACHSREA,ACHSREF,ACHSREG,ACHSSTYP
  1.  D ERPT^ACHS,^ACHSVAR    ;ACHS*3.1*19 ADDED ACHSVAR
  1.  Q
  1.  ;
  1. HDR ; Print header.
  1.  S ACHSPG=ACHSPG+1
  1.  W @IOF,!!,$$C^XBFUNC("***  CONTRACT HEALTH CARE SYSTEM REPORT  ***",80),!!
  1.  W ACHSLOC,!?20,"UNMET NEED-DENIED DOCUMENTS BY ISSUE DATE",!,ACHSTIME,!!,ACHST1
  1.  Q