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

ACHSDFS.m

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