ACHSDFE ; IHS/ITSC/PMF - DEFERRED SERVICES EXPENDITURE REPORT ;7/27/10 16:12
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,23**;JUN 11, 2001;Build 43
;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
;
BDT ; --- Input date range
;{ABK,. 5/20/10}S ACHSBDT=$$DATE^ACHS("B","DEFERRED SERVICES EXPENDITURE")
S ACHSBDT=$$DATE^ACHS("B","UNMET NEEDS EXPENDITURE")
I ACHSBDT<1 D END Q
;{ABK, 5/20/10}S ACHSEDT=$$DATE^ACHS("E","DEFERRED SERVICES EXPENDITURE")
S ACHSEDT=$$DATE^ACHS("E","UNMET NEEDS EXPENDITURE")
G:ACHSEDT<1 BDT
I $$EBB^ACHS(ACHSBDT,ACHSEDT) G BDT
DEV ; --- Select device
W !!
S %ZIS="QOP"
D ^%ZIS
I POP D HOME^%ZIS D END Q
I '$D(IO("Q")) G START
;{ABK, 5/20/10}S ZTDESC="DEFERRED SERVICES EXPENDITURE REPORT",ZTRTN="START^ACHSDFE",ZTIO="",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
S ZTDESC="UNMET NEEDS EXPENDITURE REPORT",ZTRTN="START^ACHSDFE",ZTIO="",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
F %="ACHSBDT","ACHSEDT","ACHSQIO" S ZTSAVE(%)=""
D ^%ZTLOAD
G DEV:'$D(ZTSK)
D END
Q
;
START ;EP - From TaskMan
N ACHSPAN,ACHSYS
D BRPT^ACHS
;{ABK, 5/20/10}S ACHSYS=$$C^ACHS("CHS DENIAL/DEFERRED SERVICES",80)
S ACHSYS=$$C^ACHS("CHS UNMET NEEDS",80)
S ACHSPAN=$$C^ACHS("BETWEEN "_$$FMTE^XLFDT(ACHSBDT)_" AND "_$$FMTE^XLFDT(ACHSEDT),80)
;{ABK, 5/20/10}S ACHSRPT=$$C^ACHS("DEFERRED SERVICES EXPENDITURE REPORT",80)
S ACHSRPT=$$C^ACHS("UNMET NEEDS EXPENDITURE REPORT",80)
D HDR
;
DATE ; --- Loop thru dates
S ACHSBDT=$O(^ACHSDEF(DUZ(2),"D","AISSUE",ACHSBDT))
I ACHSBDT'=+ACHSBDT D END Q
I ACHSBDT>ACHSEDT D END Q
;
;
S ACHSA=0
DOC ; --- Loop thru documents
S ACHSA=$O(^ACHSDEF(DUZ(2),"D","AISSUE",ACHSBDT,ACHSA))
;
G DATE:ACHSA'=+ACHSA
G DOC:$$DF^ACHS(0,14)="Y" ;'DEFERRED SERVICE CANCELLED'?
G DOC:$E($$DF^ACHS(0,1))="#" ;'CHS DEFERRED SERVICE NUMBER' PHANTOM
G DOC:'$$DF^ACHS(500,7) ;'DATE SERVICE PROVIDED'
;
;
S ACHSCT=$$DF^ACHS(100,1) ;'DEFERRED SERVICE CATEGORY' PTR
S ACHSCAT=$E($P($G(^ACHSDFC(ACHSCT,0)),U),1,20) ;'CATEGORY';ACHS*3.1*23 ADDED $E
S ACHSSCT=$$DF^ACHS(100,4) ;'DEFERRED SERVICE SUBCATEGORY'
S ACHSSCT=$P($G(^ACHSDFC(ACHSCT,1,ACHSSCT,0)),U) ;'SUBCATEGORY'
S ACHSSCT=$E(ACHSSCT,1,20) ;
;
;TPF HERE IS A MAJOR PROBLEM, HE LOOKS AT THE LAST ENTRY ONLY
;LOOK AT 'DEFERRED SERVICE DIAG'
;I $D(^ACHSDEF(DUZ(2),"D",ACHSA,200)) D
;.S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,0)),U,3) ;LAST ENTRY
;.I DIAGPTR="" S ACHSDIAG="UNDEFINED" Q
;.S ACHSDIAG=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAGPTR,0)),U)
;.S ACHSDIAG=$P($G(^ICD9(ACHSDIAG,0)),U)
;
;REPLACE ABOVE WITH CALL TO DIAG
;
;LOOK AT 'DEFERRED SERVICE PROC'
;I $D(^ACHSDEF(DUZ(2),"D",ACHSA,300)) D
;.S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,0)),U,3)) ;LAST ENTRY
;.I DIAGPTR="" S ACHSDIAG="UNDEFINED" Q
;.S ACHSDIAG=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,DIAGPTR,0)),U)
;.S ACHSDIAG=$P($G(^ICPT(ACHSDIAG,0)),U)
;
;
;
;
;'PURCHASE ORDER NUMBER'
S ACHSPON=$$DF^ACHS(500,8)
S ACHSPO1=$P(ACHSPON,"-",1)
S ACHSPO1=$E(ACHSPO1,$L(ACHSPO1))
S ACHSPO2=$P(ACHSPON,"-",3)
S ACHSPOT=1_ACHSPO1_ACHSPO2
;
S ACHSPO=$O(^ACHSF(DUZ(2),"D","B",ACHSPOT,0)),ACHSPAY=""
;
;IS THERE A 'PAY ADJUSTMENT'
I ACHSPO,$D(^ACHSF(DUZ(2),"D",ACHSPO,"PA")) D
.S ACHSPAY=$P($G(^ACHSF(DUZ(2),"D",ACHSPO,"PA")),U)
E I ACHSPO S ACHSPAY=$P($G(^ACHSF(DUZ(2),"D",ACHSPO,0)),U,9),ACHSPAY=$J(ACHSPAY,8,2)_"OBL"
;
I $Y>ACHSBM D HDR Q:$G(ACHSQUIT)
;ACHS*3.1*23 MOD NXT 5 LINES TO PRINT
;W !,$$DF^ACHS(0,1),?14,$$FMTE^XLFDT($$DF^ACHS(0,2)),?28,ACHSCAT,?31,ACHSSCT,?52,$$FMTE^XLFDT(ACHSBDT),?58,$J($FN(ACHSPAY,",",2),8)
S X=$$DF^ACHS(0,2) S ACHSDDT="",ACHSDDT=$E($P(X,U,2),4,5)_"/"_$E($P(X,U,2),6,7)_"/"_$E($P(X,U,2),2,3)
S X=ACHSBDT S ACHSBDT=$E($P(X,U,2),4,5)_"/"_$E($P(X,U,2),6,7)_"/"_$E($P(X,U,2),2,3)
W !,$$DF^ACHS(0,1),?13,ACHSDDT,?22,ACHSCAT,?53,ACHSBDT,?61,$J($FN(ACHSPAY,",",2),8)
W !,?22,ACHSSCT
D DIAG,PROC
G DOC
;
DIAG ;GET PRINT ALL DIAGS
S DIAG=0
F X=1:1 S DIAG=$O(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG)) Q:'DIAG D
.;ACHS*3.1*23 CHG NXT SECTION WAS PRINTING POINTER
.;S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0),"UNDEFINED"),U)
.;I X'=1 W !?74,DIAGPTR
.;E W ?74,DIAGPTR
.S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0)),U)
.Q:'+DIAGPTR
.W:X'=1 !
.;ACHS*3.1*23
.;W ?70,$P($$ICDDX^ICDCODE($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0)),U),0),U,2)
.W ?70,$P($$ICDDX^ICDEX($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0)),U),,,"I"),U,2)
I X>1 W "/"
E W ?70,"/"
Q
;GET AND PRINT ALL PROCEDURES
PROC ;
S PROC=0
F X=1:1 S PROC=$O(^ACHSDEF(DUZ(2),"D",ACHSA,300,PROC)) Q:'PROC D
.;ACHS*3.1*23 CHANGED NEXT SECTION WAS PRINTING POINTER
.;S PROCPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,PROC,0),"UNDEFINED"),U)
.;W !?74,PROCPTR
.S PROCPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,PROC,0)),U)
.Q:'+PROCPTR
.W !?70,$P($$CPT^ICPTCOD(PROCPTR),U,2)
Q
;
END ; --- End, Kill, Quit
D RTRN^ACHS,ERPT^ACHS
K ACHSFNM,ACHSCAT,ACHSCT,ACHSSCT,ACHSDIAG,ACHSBDT,ACHSPO,ACHSPO1,ACHSPO2,ACHSPOT,ACHSPAY,ACHSEDT,ACHSTIME,ACHS
Q
;
HDR ; --- Paginate, write header
D RTRN^ACHS
;ACHS*3.1*23 MODS TO HEADER
;W @IOF,!!,ACHSYS,!,ACHSRPT,!,ACHSPAN,!,ACHSTIME,!,$$REPEAT^XLFSTR("=",79),!!!,"DEF SVC #",?14,"DEF SVC DATE",?27,"CAT SUB CATEGORY",?52,"DT OF SVC",?58,"AMT",?74,"DIAG/"
W !?74,"PROC"
W @IOF,!!,ACHSYS,!,ACHSRPT,!,ACHSPAN,!,ACHSTIME,!,$$REPEAT^XLFSTR("=",79)
W !!!,"DEF SVC #",?13,"DEF SVC",?22,"CATEGORY/",?52,"DATE OF SVC",?64,"AMT",?70,"DIAG/"
W !?14,"DATE",?22,"SUB CATEGORY",?70,"PROC"
;
W !,$$REPEAT^XLFSTR("-",79),!!
Q
;
ACHSDFE ; IHS/ITSC/PMF - DEFERRED SERVICES EXPENDITURE REPORT ;7/27/10 16:12
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,23**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
+3 ;
BDT ; --- Input date range
+1 ;{ABK,. 5/20/10}S ACHSBDT=$$DATE^ACHS("B","DEFERRED SERVICES EXPENDITURE")
+2 SET ACHSBDT=$$DATE^ACHS("B","UNMET NEEDS EXPENDITURE")
+3 IF ACHSBDT<1
DO END
QUIT
+4 ;{ABK, 5/20/10}S ACHSEDT=$$DATE^ACHS("E","DEFERRED SERVICES EXPENDITURE")
+5 SET ACHSEDT=$$DATE^ACHS("E","UNMET NEEDS EXPENDITURE")
+6 IF ACHSEDT<1
GOTO BDT
+7 IF $$EBB^ACHS(ACHSBDT,ACHSEDT)
GOTO BDT
DEV ; --- Select device
+1 WRITE !!
+2 SET %ZIS="QOP"
+3 DO ^%ZIS
+4 IF POP
DO HOME^%ZIS
DO END
QUIT
+5 IF '$DATA(IO("Q"))
GOTO START
+6 ;{ABK, 5/20/10}S ZTDESC="DEFERRED SERVICES EXPENDITURE REPORT",ZTRTN="START^ACHSDFE",ZTIO="",ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+7 SET ZTDESC="UNMET NEEDS EXPENDITURE REPORT"
SET ZTRTN="START^ACHSDFE"
SET ZTIO=""
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+8 FOR %="ACHSBDT","ACHSEDT","ACHSQIO"
SET ZTSAVE(%)=""
+9 DO ^%ZTLOAD
+10 IF '$DATA(ZTSK)
GOTO DEV
+11 DO END
+12 QUIT
+13 ;
START ;EP - From TaskMan
+1 NEW ACHSPAN,ACHSYS
+2 DO BRPT^ACHS
+3 ;{ABK, 5/20/10}S ACHSYS=$$C^ACHS("CHS DENIAL/DEFERRED SERVICES",80)
+4 SET ACHSYS=$$C^ACHS("CHS UNMET NEEDS",80)
+5 SET ACHSPAN=$$C^ACHS("BETWEEN "_$$FMTE^XLFDT(ACHSBDT)_" AND "_$$FMTE^XLFDT(ACHSEDT),80)
+6 ;{ABK, 5/20/10}S ACHSRPT=$$C^ACHS("DEFERRED SERVICES EXPENDITURE REPORT",80)
+7 SET ACHSRPT=$$C^ACHS("UNMET NEEDS EXPENDITURE REPORT",80)
+8 DO HDR
+9 ;
DATE ; --- Loop thru dates
+1 SET ACHSBDT=$ORDER(^ACHSDEF(DUZ(2),"D","AISSUE",ACHSBDT))
+2 IF ACHSBDT'=+ACHSBDT
DO END
QUIT
+3 IF ACHSBDT>ACHSEDT
DO END
QUIT
+4 ;
+5 ;
+6 SET ACHSA=0
DOC ; --- Loop thru documents
+1 SET ACHSA=$ORDER(^ACHSDEF(DUZ(2),"D","AISSUE",ACHSBDT,ACHSA))
+2 ;
+3 IF ACHSA'=+ACHSA
GOTO DATE
+4 ;'DEFERRED SERVICE CANCELLED'?
IF $$DF^ACHS(0,14)="Y"
GOTO DOC
+5 ;'CHS DEFERRED SERVICE NUMBER' PHANTOM
IF $EXTRACT($$DF^ACHS(0,1))="#"
GOTO DOC
+6 ;'DATE SERVICE PROVIDED'
IF '$$DF^ACHS(500,7)
GOTO DOC
+7 ;
+8 ;
+9 ;'DEFERRED SERVICE CATEGORY' PTR
SET ACHSCT=$$DF^ACHS(100,1)
+10 ;'CATEGORY';ACHS*3.1*23 ADDED $E
SET ACHSCAT=$EXTRACT($PIECE($GET(^ACHSDFC(ACHSCT,0)),U),1,20)
+11 ;'DEFERRED SERVICE SUBCATEGORY'
SET ACHSSCT=$$DF^ACHS(100,4)
+12 ;'SUBCATEGORY'
SET ACHSSCT=$PIECE($GET(^ACHSDFC(ACHSCT,1,ACHSSCT,0)),U)
+13 ;
SET ACHSSCT=$EXTRACT(ACHSSCT,1,20)
+14 ;
+15 ;TPF HERE IS A MAJOR PROBLEM, HE LOOKS AT THE LAST ENTRY ONLY
+16 ;LOOK AT 'DEFERRED SERVICE DIAG'
+17 ;I $D(^ACHSDEF(DUZ(2),"D",ACHSA,200)) D
+18 ;.S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,0)),U,3) ;LAST ENTRY
+19 ;.I DIAGPTR="" S ACHSDIAG="UNDEFINED" Q
+20 ;.S ACHSDIAG=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAGPTR,0)),U)
+21 ;.S ACHSDIAG=$P($G(^ICD9(ACHSDIAG,0)),U)
+22 ;
+23 ;REPLACE ABOVE WITH CALL TO DIAG
+24 ;
+25 ;LOOK AT 'DEFERRED SERVICE PROC'
+26 ;I $D(^ACHSDEF(DUZ(2),"D",ACHSA,300)) D
+27 ;.S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,0)),U,3)) ;LAST ENTRY
+28 ;.I DIAGPTR="" S ACHSDIAG="UNDEFINED" Q
+29 ;.S ACHSDIAG=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,DIAGPTR,0)),U)
+30 ;.S ACHSDIAG=$P($G(^ICPT(ACHSDIAG,0)),U)
+31 ;
+32 ;
+33 ;
+34 ;
+35 ;'PURCHASE ORDER NUMBER'
+36 SET ACHSPON=$$DF^ACHS(500,8)
+37 SET ACHSPO1=$PIECE(ACHSPON,"-",1)
+38 SET ACHSPO1=$EXTRACT(ACHSPO1,$LENGTH(ACHSPO1))
+39 SET ACHSPO2=$PIECE(ACHSPON,"-",3)
+40 SET ACHSPOT=1_ACHSPO1_ACHSPO2
+41 ;
+42 SET ACHSPO=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSPOT,0))
SET ACHSPAY=""
+43 ;
+44 ;IS THERE A 'PAY ADJUSTMENT'
+45 IF ACHSPO
IF $DATA(^ACHSF(DUZ(2),"D",ACHSPO,"PA"))
Begin DoDot:1
+46 SET ACHSPAY=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSPO,"PA")),U)
End DoDot:1
+47 IF '$TEST
IF ACHSPO
SET ACHSPAY=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSPO,0)),U,9)
SET ACHSPAY=$JUSTIFY(ACHSPAY,8,2)_"OBL"
+48 ;
+49 IF $Y>ACHSBM
DO HDR
IF $GET(ACHSQUIT)
QUIT
+50 ;ACHS*3.1*23 MOD NXT 5 LINES TO PRINT
+51 ;W !,$$DF^ACHS(0,1),?14,$$FMTE^XLFDT($$DF^ACHS(0,2)),?28,ACHSCAT,?31,ACHSSCT,?52,$$FMTE^XLFDT(ACHSBDT),?58,$J($FN(ACHSPAY,",",2),8)
+52 SET X=$$DF^ACHS(0,2)
SET ACHSDDT=""
SET ACHSDDT=$EXTRACT($PIECE(X,U,2),4,5)_"/"_$EXTRACT($PIECE(X,U,2),6,7)_"/"_$EXTRACT($PIECE(X,U,2),2,3)
+53 SET X=ACHSBDT
SET ACHSBDT=$EXTRACT($PIECE(X,U,2),4,5)_"/"_$EXTRACT($PIECE(X,U,2),6,7)_"/"_$EXTRACT($PIECE(X,U,2),2,3)
+54 WRITE !,$$DF^ACHS(0,1),?13,ACHSDDT,?22,ACHSCAT,?53,ACHSBDT,?61,$JUSTIFY($FNUMBER(ACHSPAY,",",2),8)
+55 WRITE !,?22,ACHSSCT
+56 DO DIAG
DO PROC
+57 GOTO DOC
+58 ;
DIAG ;GET PRINT ALL DIAGS
+1 SET DIAG=0
+2 FOR X=1:1
SET DIAG=$ORDER(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG))
IF 'DIAG
QUIT
Begin DoDot:1
+3 ;ACHS*3.1*23 CHG NXT SECTION WAS PRINTING POINTER
+4 ;S DIAGPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0),"UNDEFINED"),U)
+5 ;I X'=1 W !?74,DIAGPTR
+6 ;E W ?74,DIAGPTR
+7 SET DIAGPTR=$PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0)),U)
+8 IF '+DIAGPTR
QUIT
+9 IF X'=1
WRITE !
+10 ;ACHS*3.1*23
+11 ;W ?70,$P($$ICDDX^ICDCODE($P($G(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0)),U),0),U,2)
+12 WRITE ?70,$PIECE($$ICDDX^ICDEX($PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,200,DIAG,0)),U),,,"I"),U,2)
End DoDot:1
+13 IF X>1
WRITE "/"
+14 IF '$TEST
WRITE ?70,"/"
+15 QUIT
+16 ;GET AND PRINT ALL PROCEDURES
PROC ;
+1 SET PROC=0
+2 FOR X=1:1
SET PROC=$ORDER(^ACHSDEF(DUZ(2),"D",ACHSA,300,PROC))
IF 'PROC
QUIT
Begin DoDot:1
+3 ;ACHS*3.1*23 CHANGED NEXT SECTION WAS PRINTING POINTER
+4 ;S PROCPTR=$P($G(^ACHSDEF(DUZ(2),"D",ACHSA,300,PROC,0),"UNDEFINED"),U)
+5 ;W !?74,PROCPTR
+6 SET PROCPTR=$PIECE($GET(^ACHSDEF(DUZ(2),"D",ACHSA,300,PROC,0)),U)
+7 IF '+PROCPTR
QUIT
+8 WRITE !?70,$PIECE($$CPT^ICPTCOD(PROCPTR),U,2)
End DoDot:1
+9 QUIT
+10 ;
END ; --- End, Kill, Quit
+1 DO RTRN^ACHS
DO ERPT^ACHS
+2 KILL ACHSFNM,ACHSCAT,ACHSCT,ACHSSCT,ACHSDIAG,ACHSBDT,ACHSPO,ACHSPO1,ACHSPO2,ACHSPOT,ACHSPAY,ACHSEDT,ACHSTIME,ACHS
+3 QUIT
+4 ;
HDR ; --- Paginate, write header
+1 DO RTRN^ACHS
+2 ;ACHS*3.1*23 MODS TO HEADER
+3 ;W @IOF,!!,ACHSYS,!,ACHSRPT,!,ACHSPAN,!,ACHSTIME,!,$$REPEAT^XLFSTR("=",79),!!!,"DEF SVC #",?14,"DEF SVC DATE",?27,"CAT SUB CATEGORY",?52,"DT OF SVC",?58,"AMT",?74,"DIAG/"
+4 WRITE !?74,"PROC"
+5 WRITE @IOF,!!,ACHSYS,!,ACHSRPT,!,ACHSPAN,!,ACHSTIME,!,$$REPEAT^XLFSTR("=",79)
+6 WRITE !!!,"DEF SVC #",?13,"DEF SVC",?22,"CATEGORY/",?52,"DATE OF SVC",?64,"AMT",?70,"DIAG/"
+7 WRITE !?14,"DATE",?22,"SUB CATEGORY",?70,"PROC"
+8 ;
+9 WRITE !,$$REPEAT^XLFSTR("-",79),!!
+10 QUIT
+11 ;
