ACHSDFS ; IHS/ITSC/PMF - ACCRUED DEFERRED SERVICES REPORT ;7/27/10 16:07
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001
;;ACHD*3*1T;Y2K FIX;CS 2991221
;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
;
BEG ; --- Select Begin/End dates for report.
;{ABK, 4/1/10}S ACHDBDT=$$DATE^ACHS("B","ACCRUED DEFERRED SERVICES")
S ACHDBDT=$$DATE^ACHS("B","ACCRUED UNMET NEEDS")
G END:ACHDBDT<1
;{ABK, 4/1/10}S ACHDEDT=$$DATE^ACHS("E","ACCRUED DEFERRED SERVICES")
S ACHDEDT=$$DATE^ACHS("E","ACCRUED UNMET NEEDS")
G BEG:ACHDEDT<1
I $$EBB^ACHS(ACHDBDT,ACHDEDT) G BEG
S ACHDHAT=""
DEV ; --- Select device for report.
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS D END Q
G:'$D(IO("Q")) START
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
;
;
S ZTRTN="START^ACHSDFS",ZTDESC=$P($P($T(ACHSDFS),";",2)," ",4,99)_(ACHDBDT+17000000)_" TO "_(ACHDEDT+17000000),ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOST ;Y2000
;
F %="ACHSQIO","ACHDBDT","ACHDEDT","ACHDCFY" S ZTSAVE(%)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
END ; --- KILL vars, close device, quit.
K ACHD,ACHDBDT,ACHDCHS,ACHDCOST,ACHDEDT,ACHDHAT,ACHSQIO,ACHDUNIT,ZTIO,ZTSK
D ^%ZISC
Q
;
START ;EP - From TaskMan.
N ACHDFT,ACHDSU,ACHDCAT,ACHDSUB,ACHDTYPE,ACHDCNT,ACHDTOT
K ^TMP($J,"ACHSDFS")
;
;{ABK, 4/1/10}S ACHDCHS=$$C^ACHS("CHS DENIAL/DEFERRED SERVICES",80)
S ACHDCHS=$$C^ACHS("CHS UNMET NEEDS",80)
;{ABK, 4/1/10}S ACHDTITL=$$C^ACHS("ACCRUED DEFERRED SERVICES REPORT",80)
S ACHDTITL=$$C^ACHS("ACCRUED UNMET NEEDS REPORT",80)
S ACHDFT=$$C^ACHS("From "_$$FMTE^XLFDT(ACHDBDT)_" To "_$$FMTE^XLFDT(ACHDEDT),80),ACHDSU=$$LOC^ACHS,ACHDUSR=$$USR^ACHS
S ACHDISDT=ACHDBDT-1
S ACHDFY=$E(ACHDISDT,1,3)+1700
ISSUEDT ; --- Move thru Issue date x-ref.
S ACHDISDT=$O(^ACHSDEF(DUZ(2),"D","AISSUE",ACHDISDT))
G PRINT:+ACHDISDT=0!(ACHDISDT>ACHDEDT)
S ACHDFY(1)=$E(ACHDISDT,1,3)+1700
S (ACHSA,ACHDCAT,ACHDSUB,ACHDTYPE)=0
IEN ; --- Process a document.
S ACHSA=$O(^ACHSDEF(DUZ(2),"D","AISSUE",ACHDISDT,ACHSA))
G ISSUEDT:+ACHSA=0,IEN:'$D(^ACHSDEF(DUZ(2),"D",ACHSA,0))
G IEN:$$DF^ACHS(0,14)="Y",IEN:$E($$DF^ACHS(0,1))="#"
;
S X=$G(^ACHSDEF(DUZ(2),"D",ACHSA,100))
S ACHDTYPE=$P(X,U,2)
S ACHDCOST=$P(X,U,5)
S ACHDUNIT=$P(X,U,3)
G IEN:$P(X,U)<1,IEN:$P(X,U,4)<1
S ACHDCAT="C"_$P(X,U),ACHDSUB="S"_$P(X,U,4)
S ACHDCNT(ACHDCAT)=$G(ACHDCNT(ACHDCAT))+ACHDUNIT
S ACHDTOT(ACHDCAT)=$G(ACHDTOT(ACHDCAT))+ACHDCOST
S ACHDCNT(ACHDCAT,ACHDSUB)=$G(ACHDCNT(ACHDCAT,ACHDSUB))+ACHDUNIT
S ACHDTOT(ACHDCAT,ACHDSUB)=$G(ACHDTOT(ACHDCAT,ACHDSUB))+ACHDCOST
G IEN
;
PRINT ;
S X=""
F S X=$O(ACHDCNT(X)) Q:X="" S ^TMP($J,"ACHSDFS",X,"TOTAL")=ACHDCNT(X)_U_ACHDTOT(X) S Y="" F S Y=$O(ACHDCNT(X,Y)) Q:Y="" S ^TMP($J,"ACHSDFS",X,Y,"TOTAL")=ACHDCNT(X,Y)_U_ACHDTOT(X,Y)
D BRPT^ACHS
S ACHDX=""
F S ACHDX=$O(^TMP($J,"ACHSDFS",ACHDX)) Q:ACHDX="" S ACHDCAT=$P($G(^ACHSDFC($E(ACHDX,2),0)),U) W @IOF D HDR,PRNT1,HDR1,PRNTX,CATTOT
D RTRN^ACHS,ERPT^ACHS
D END
Q
;
PRNTX ;
S ACHDY=""
F S ACHDY=$O(^TMP($J,"ACHSDFS",ACHDX,ACHDY)) Q:ACHDY=""!(ACHDY="TOTAL") S ACHDSUB=$P($G(^ACHSDFC($E(ACHDX,2,99),1,$E(ACHDY,2,99),0)),U) D
. W !?7,ACHDSUB,?60,$J($FN($P($G(^TMP($J,"ACHSDFS",ACHDX,ACHDY,"TOTAL")),U),","),5),$J($FN($P($G(^TMP($J,"ACHSDFS",ACHDX,ACHDY,"TOTAL")),U,2),","),14),!
. I $Y>ACHSBM D HDR,HDR1
;
Q
;
PRNT1 ;
W !!?5,"CATEGORY OF SERVICE: ",ACHDCAT,!
Q
;
CATTOT ;
W !!,$$REPEAT^XLFSTR("-",79),!!?12,"TOTAL CATEGORY ",ACHDCAT,?60,$J($FN($P($G(^TMP($J,"ACHSDFS",ACHDX,"TOTAL")),U),","),5),$J("$"_$FN($P($G(^TMP($J,"ACHSDFS",ACHDX,"TOTAL")),U,2),","),14)
Q
;
HDR ; --- Report pagination control.
D RTRN^ACHS
I ACHDFY(1) S:ACHDFY(1)'=ACHDFY ACHDFY=ACHDFY_" TO "_ACHDFY(1)
W !!,ACHDCHS,!,ACHDTITL,!,$$C^ACHS("FISCAL YEAR "_ACHDFY,80),!,ACHDFT,!!!,"FACILITY: ",ACHDSU,?(66-$L(ACHDUSR)),"PREPARED BY: ",ACHDUSR,!!!,"CLINICAL DIRECTOR SIGNATURE:",$$REPEAT^XLFSTR("_",51),!!,$$REPEAT^XLFSTR("*",79),!!
Q
;
HDR1 ;
W !?7,"SUBCATEGORY OF SERVICE",?60,"UNITS",?70,"EST. COST",!,$$REPEAT^XLFSTR("-",79),!
Q
;
ACHSDFS ; IHS/ITSC/PMF - ACCRUED DEFERRED SERVICES REPORT ;7/27/10 16:07
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001
+2 ;;ACHD*3*1T;Y2K FIX;CS 2991221
+3 ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
+4 ;
BEG ; --- Select Begin/End dates for report.
+1 ;{ABK, 4/1/10}S ACHDBDT=$$DATE^ACHS("B","ACCRUED DEFERRED SERVICES")
+2 SET ACHDBDT=$$DATE^ACHS("B","ACCRUED UNMET NEEDS")
+3 IF ACHDBDT<1
GOTO END
+4 ;{ABK, 4/1/10}S ACHDEDT=$$DATE^ACHS("E","ACCRUED DEFERRED SERVICES")
+5 SET ACHDEDT=$$DATE^ACHS("E","ACCRUED UNMET NEEDS")
+6 IF ACHDEDT<1
GOTO BEG
+7 IF $$EBB^ACHS(ACHDBDT,ACHDEDT)
GOTO BEG
+8 SET ACHDHAT=""
DEV ; --- Select device for report.
+1 SET %ZIS="OPQ"
+2 DO ^%ZIS
+3 IF POP
DO HOME^%ZIS
DO END
QUIT
+4 IF '$DATA(IO("Q"))
GOTO START
+5 KILL IO("Q")
+6 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+7 ;
+8 ;
+9 ;Y2000
SET ZTRTN="START^ACHSDFS"
SET ZTDESC=$PIECE($PIECE($TEXT(ACHSDFS),";",2)," ",4,99)_(ACHDBDT+17000000)_" TO "_(ACHDEDT+17000000)
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOST
+10 ;
+11 FOR %="ACHSQIO","ACHDBDT","ACHDEDT","ACHDCFY"
SET ZTSAVE(%)=""
+12 DO ^%ZTLOAD
+13 IF '$DATA(ZTSK)
GOTO DEV
END ; --- KILL vars, close device, quit.
+1 KILL ACHD,ACHDBDT,ACHDCHS,ACHDCOST,ACHDEDT,ACHDHAT,ACHSQIO,ACHDUNIT,ZTIO,ZTSK
+2 DO ^%ZISC
+3 QUIT
+4 ;
START ;EP - From TaskMan.
+1 NEW ACHDFT,ACHDSU,ACHDCAT,ACHDSUB,ACHDTYPE,ACHDCNT,ACHDTOT
+2 KILL ^TMP($JOB,"ACHSDFS")
+3 ;
+4 ;{ABK, 4/1/10}S ACHDCHS=$$C^ACHS("CHS DENIAL/DEFERRED SERVICES",80)
+5 SET ACHDCHS=$$C^ACHS("CHS UNMET NEEDS",80)
+6 ;{ABK, 4/1/10}S ACHDTITL=$$C^ACHS("ACCRUED DEFERRED SERVICES REPORT",80)
+7 SET ACHDTITL=$$C^ACHS("ACCRUED UNMET NEEDS REPORT",80)
+8 SET ACHDFT=$$C^ACHS("From "_$$FMTE^XLFDT(ACHDBDT)_" To "_$$FMTE^XLFDT(ACHDEDT),80)
SET ACHDSU=$$LOC^ACHS
SET ACHDUSR=$$USR^ACHS
+9 SET ACHDISDT=ACHDBDT-1
+10 SET ACHDFY=$EXTRACT(ACHDISDT,1,3)+1700
ISSUEDT ; --- Move thru Issue date x-ref.
+1 SET ACHDISDT=$ORDER(^ACHSDEF(DUZ(2),"D","AISSUE",ACHDISDT))
+2 IF +ACHDISDT=0!(ACHDISDT>ACHDEDT)
GOTO PRINT
+3 SET ACHDFY(1)=$EXTRACT(ACHDISDT,1,3)+1700
+4 SET (ACHSA,ACHDCAT,ACHDSUB,ACHDTYPE)=0
IEN ; --- Process a document.
+1 SET ACHSA=$ORDER(^ACHSDEF(DUZ(2),"D","AISSUE",ACHDISDT,ACHSA))
+2 IF +ACHSA=0
GOTO ISSUEDT
IF '$DATA(^ACHSDEF(DUZ(2),"D",ACHSA,0))
GOTO IEN
+3 IF $$DF^ACHS(0,14)="Y"
GOTO IEN
IF $EXTRACT($$DF^ACHS(0,1))="#"
GOTO IEN
+4 ;
+5 SET X=$GET(^ACHSDEF(DUZ(2),"D",ACHSA,100))
+6 SET ACHDTYPE=$PIECE(X,U,2)
+7 SET ACHDCOST=$PIECE(X,U,5)
+8 SET ACHDUNIT=$PIECE(X,U,3)
+9 IF $PIECE(X,U)<1
GOTO IEN
IF $PIECE(X,U,4)<1
GOTO IEN
+10 SET ACHDCAT="C"_$PIECE(X,U)
SET ACHDSUB="S"_$PIECE(X,U,4)
+11 SET ACHDCNT(ACHDCAT)=$GET(ACHDCNT(ACHDCAT))+ACHDUNIT
+12 SET ACHDTOT(ACHDCAT)=$GET(ACHDTOT(ACHDCAT))+ACHDCOST
+13 SET ACHDCNT(ACHDCAT,ACHDSUB)=$GET(ACHDCNT(ACHDCAT,ACHDSUB))+ACHDUNIT
+14 SET ACHDTOT(ACHDCAT,ACHDSUB)=$GET(ACHDTOT(ACHDCAT,ACHDSUB))+ACHDCOST
+15 GOTO IEN
+16 ;
PRINT ;
+1 SET X=""
+2 FOR
SET X=$ORDER(ACHDCNT(X))
IF X=""
QUIT
SET ^TMP($JOB,"ACHSDFS",X,"TOTAL")=ACHDCNT(X)_U_ACHDTOT(X)
SET Y=""
FOR
SET Y=$ORDER(ACHDCNT(X,Y))
IF Y=""
QUIT
SET ^TMP($JOB,"ACHSDFS",X,Y,"TOTAL")=ACHDCNT(X,Y)_U_ACHDTOT(X,Y)
+3 DO BRPT^ACHS
+4 SET ACHDX=""
+5 FOR
SET ACHDX=$ORDER(^TMP($JOB,"ACHSDFS",ACHDX))
IF ACHDX=""
QUIT
SET ACHDCAT=$PIECE($GET(^ACHSDFC($EXTRACT(ACHDX,2),0)),U)
WRITE @IOF
DO HDR
DO PRNT1
DO HDR1
DO PRNTX
DO CATTOT
+6 DO RTRN^ACHS
DO ERPT^ACHS
+7 DO END
+8 QUIT
+9 ;
PRNTX ;
+1 SET ACHDY=""
+2 FOR
SET ACHDY=$ORDER(^TMP($JOB,"ACHSDFS",ACHDX,ACHDY))
IF ACHDY=""!(ACHDY="TOTAL")
QUIT
SET ACHDSUB=$PIECE($GET(^ACHSDFC($EXTRACT(ACHDX,2,99),1,$EXTRACT(ACHDY,2,99),0)),U)
Begin DoDot:1
+3 WRITE !?7,ACHDSUB,?60,$JUSTIFY($FNUMBER($PIECE($GET(^TMP($JOB,"ACHSDFS",ACHDX,ACHDY,"TOTAL")),U),","),5),$JUSTIFY($FNUMBER($PIECE($GET(^TMP($JOB,"ACHSDFS",ACHDX,ACHDY,"TOTAL")),U,2),","),14),!
+4 IF $Y>ACHSBM
DO HDR
DO HDR1
End DoDot:1
+5 ;
+6 QUIT
+7 ;
PRNT1 ;
+1 WRITE !!?5,"CATEGORY OF SERVICE: ",ACHDCAT,!
+2 QUIT
+3 ;
CATTOT ;
+1 WRITE !!,$$REPEAT^XLFSTR("-",79),!!?12,"TOTAL CATEGORY ",ACHDCAT,?60,$JUSTIFY($FNUMBER($PIECE($GET(^TMP($JOB,"ACHSDFS",ACHDX,"TOTAL")),U),","),5),$JUSTIFY("$"_$FNUMBER($PIECE($GET(^TMP($JOB,"ACHSDFS",ACHDX,"TOTAL")),U,2),","),14)
+2 QUIT
+3 ;
HDR ; --- Report pagination control.
+1 DO RTRN^ACHS
+2 IF ACHDFY(1)
IF ACHDFY(1)'=ACHDFY
SET ACHDFY=ACHDFY_" TO "_ACHDFY(1)
+3 WRITE !!,ACHDCHS,!,ACHDTITL,!,$$C^ACHS("FISCAL YEAR "_ACHDFY,80),!,ACHDFT,!!!,"FACILITY: ",ACHDSU,?(66-$LENGTH(ACHDUSR)),"PREPARED BY: ",ACHDUSR,!!!,"CLINICAL DIRECTOR SIGNATURE:",$$REPEAT^XLFSTR("_",51),!!,$$REPEAT^XLFSTR("*",79),!!
+4 QUIT
+5 ;
HDR1 ;
+1 WRITE !?7,"SUBCATEGORY OF SERVICE",?60,"UNITS",?70,"EST. COST",!,$$REPEAT^XLFSTR("-",79),!
+2 QUIT
+3 ;
