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