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

ACHSCHF.m

Go to the documentation of this file. 
  1. ACHSCHF ; IHS/ITSC/TPF/PMF - C H E F REIMBURSEMENT SEARCHES ;   
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15,16**;JUN 11, 2001
  1.  ;ACHS*3.1*15 12.15.2009 IHS/OIT/FCJ ADDED COMMENTS RE-ARRANGED PRINT AND ADDED TOTALS
  1.  ;ACHS*3.1*16 11.09.2009 IHS.OIT.FCJ CHANGES FOR BLANKET PRINTING AND AMENDMENT TOTALS
  1.  ;
  1.  S ACHSIO=IO,ACHSTODA=+$$PARM^ACHS(2,27)
  1. TODA ; Input total obl/disbursement amt.
  1.  S Y(1)="   CHEF reimbursement requests will be printed for patients whose obligation",Y="   OR paid amounts exceeds this amount."
  1.  S ACHSTODA=$$DIR^XBDIR("N","Enter TOTAL OBLIGATION/DISBURSEMENT AMOUNT on which to report",ACHSTODA,"",.Y,"",2)
  1.  G:$D(DUOUT)!$D(DTOUT) K
  1.  W !?5,"$",$FN(ACHSTODA,",",2)
  1. BDT ; Input begin date.
  1.  S ACHSBDT=$$DATE^ACHS("B","CHEF by Date of Service")
  1.  G TODA:$D(DUOUT),K:$D(DTOUT)!(ACHSBDT<1)
  1. EDT ; Input End date.
  1.  S ACHSEDT=$$DATE^ACHS("E","CHEF by Date of Service")
  1.  G K:$D(DTOUT)!(ACHSEDT<1),BDT:$D(DUOUT),BDT:$$EBB^ACHS(ACHSBDT,ACHSEDT)
  1. B ; Input type of service.
  1.  W !!,"TYPE of service:"
  1.  S ACHSTOS=$P($G(^DD(9002080.01,3,0)),U,3)
  1.  F ACHS=1:1 S ACHS(ACHS)=$P(ACHSTOS,";",ACHS) Q:ACHS(ACHS)=""  W ?20,$P(ACHS(ACHS),":",1),"   ",$P(ACHS(ACHS),":",2),!
  1.  W !,"Select TYPE of service (1 - ",ACHS-1,"  'A' = 'ALL') ALL // "
  1.  D READ^ACHSFU
  1.  Q:$D(DTOUT)
  1.  S:Y="" Y="A"
  1.  G BDT:$D(DUOUT),B3:Y="A"
  1.  I ($E(Y)="?")!(Y<1)!(Y>(ACHS-1)) W !!,"Enter an ""A"" to view documents for all types of service,",!,"otherwise, enter a number from 1 to ",ACHS-1,".",! G B
  1. B3 ;
  1.  S ACHSRPT=$S(Y="A":"ALL",1:+Y)
  1. DEV ; Select device/ztload.
  1.  S %ZIS="OPQ"
  1.  D ^%ZIS,SLV^ACHSFU:$D(IO("S"))
  1.  I POP D HOME^%ZIS G K
  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.  S ZTRTN="START^ACHSCHF",ZTDESC="CHS C H E F "_ACHSRPT_" Report, "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT)_"."
  1.  F %="ACHSBDT","ACHSEDT","ACHSRPT","ACHSTODA" S ZTSAVE(%)=""
  1.  D ^%ZTLOAD
  1.  G:'$D(ZTSK) DEV
  1.  K ZTSK
  1.  G K
  1.  ;
  1. START ;EP - From TaskMan.
  1.  K ^TMP("ACHSCHF",$J)
  1.  D FC^ACHSUF
  1.  I $G(ACHSERR)=1 G K
  1.  S ACHS("_")="",$P(ACHS("_"),"_",80)="",ACHSTAB=0
  1.  S ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
  1.  S ACHSTOS=$P($G(^DD(9002080.01,3,0)),U,3),ACHSSTS=$P($G(^DD(9002080.01,11,0)),U,3),X2="2$",X3=0,ACHST3=$$C^XBFUNC($S(ACHSRPT:$P($P(ACHSTOS,";",ACHSRPT),":",2)_" documents ONLY",1:"All Documents")_", $"_$FN(ACHSTODA,",",2)_" Threshold",80)
  1.  D BRPT^ACHSFU,WAIT^DICD:'$D(ZTQUEUED)
  1.  S ACHSLOC=$$LOC^ACHS
  1.  X:$D(IO("S")) ACHSPPO
  1.  S ACHSTRAN=""
  1.  G TRAN
  1.  ;
  1. DATE ;
  1.  S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT))
  1.  G PRINT:ACHSBDT=""!(ACHSBDT>ACHSEDT)
  1.  S ACHSTRAN=""
  1. TRAN ; Process transaction.
  1.  S ACHSTRAN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTRAN))
  1.  G DATE:ACHSTRAN=""
  1.  S ACHSDIEN=0
  1. DIEN ;
  1.  S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTRAN,ACHSDIEN))
  1.  G:ACHSDIEN="" TRAN
  1.  I ACHSRPT'="ALL",$$DOC^ACHS(0,4)'=ACHSRPT G DIEN
  1.  F ACHSTIEN=0:0 S ACHSTIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTRAN,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN=""  Q:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0))  I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,22) D SET
  1.  G DIEN
  1.  ;
  1. SET ;EP - Set work values. 
  1.  S DFN=$$DOC^ACHS(0,22)
  1.  S ACHSTRA0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0))
  1.  S ^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,ACHSTRAN)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4)_U_$P(^(0),U,12)_U_$P(^(0),U,8)
  1.  I '$D(^TMP("ACHSCHF",$J,DFN,0))!($D(^(0))=10) S ^(0)=""
  1.  I "IS"[ACHSTRAN S $P(^TMP("ACHSCHF",$J,DFN,0),U)=$P($G(^TMP("ACHSCHF",$J,DFN,0)),U)+$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4) Q
  1.  I "C"[ACHSTRAN S $P(^TMP("ACHSCHF",$J,DFN,0),U)=$P($G(^TMP("ACHSCHF",$J,DFN,0)),U)-$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4) Q
  1.  S $P(^TMP("ACHSCHF",$J,DFN,0),U,2)=$P($G(^TMP("ACHSCHF",$J,DFN,0)),U,2)+$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4)
  1.  Q
  1. SETBS ;EP -Set work values for blankets and SLO  ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ
  1.  S DFN=$P(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0),U,2)
  1.  I '$D(^TMP("ACHSCHF",$J,DFN,0))!($D(^(0))=10) S ^(0)=""
  1.  S ACHSPROV=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,8)
  1.  ;IF DOS IS PROVIDED THEN THE CONTRACT CAN BE TESTED FOR BY UNCOMMENTING NXT LINE AND 3 LINE DOWN
  1.  ;D ^ACHSUCN
  1.  S ACHSPROV=$E($P($G(^AUTTVNDR(ACHSPROV,0)),U),1,17)
  1.  ;I $G(C) S ACHSPROV="*"_$E(ACHSPROV,1,16)
  1.  S ^TMP("ACHSCHF",$J,DFN,"BLK",ACHS)=^ACHSCHEF(DUZ(2),1,ACHSCHEF,3,ACHS,0)
  1.  S $P(^TMP("ACHSCHF",$J,DFN,"BLK",ACHS),U,5)=ACHSPROV
  1.  S $P(^TMP("ACHSCHF",$J,DFN,0),U)=$P($G(^TMP("ACHSCHF",$J,DFN,0)),U)+$P($G(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3,ACHS)),U,3)
  1.  Q
  1.  ;
  1. PRINT ;
  1.  S DFN=0
  1. P1 ;
  1.  S DFN=$O(^TMP("ACHSCHF",$J,DFN))
  1.  G:'DFN END
  1.  I $P($G(^TMP("ACHSCHF",$J,DFN,0)),U)<ACHSTODA,$P($G(^TMP("ACHSCHF",$J,DFN,0)),U,2)<ACHSTODA G P1
  1.  D HDR
  1.  ;ACHS*3.1*15 12.15.2009 IHS/OIT/FCJ ADDED ACHS("IPD") TO NXT LINE
  1.  S (ACHSDIEN,ACHS("TAO"),ACHS("PD"),ACHS("IPD"))=0
  1. P2 ;
  1.  S ACHSDIEN=$O(^TMP("ACHSCHF",$J,DFN,ACHSDIEN))
  1.  ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ MODIFIED NXT LINE TO PRINT BLANKET/SLO INFO
  1.  I 'ACHSDIEN D PAT G END:$G(ACHSQUIT),P1
  1.  S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
  1.  S (ACHSTIEN,ACHSTAO,ACHSPD,ACHSP3RD)=0,ACHSDOS=""
  1. P3 ;
  1.  S ACHSTIEN=$O(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN))
  1.  I 'ACHSTIEN D POSUM G P2
  1.  S ACHSTRAN=$O(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,""))
  1.  I ACHSTRAN="P" S ACHSDOS=$$FMTE^XLFDT($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,10))
  1.  I "IS"[ACHSTRAN S ACHSTAO=ACHSTAO+$P($G(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,ACHSTRAN)),U)
  1.  I "C"[ACHSTRAN S ACHSTAO=ACHSTAO-$P($G(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,ACHSTRAN)),U)
  1.  I "IS"'[ACHSTRAN S ACHSPD=ACHSPD+$P($G(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,ACHSTRAN)),U)
  1.  I "C"[ACHSTRAN S ACHSPD=ACHSPD-$P($G(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,ACHSTRAN)),U)
  1.  S ACHSP3RD=ACHSP3RD+$P($G(^TMP("ACHSCHF",$J,DFN,ACHSDIEN,ACHSTIEN,ACHSTRAN)),U,3)
  1.  G P3
  1.  ;
  1. END ; Ask RTRN, write IOF. 
  1.  W @IOF
  1. K ;EP - Kill vars, do ERPT, quit.
  1.  D EN^XBVK("ACHS"),^ACHSVAR
  1.  ;ACHS*3.1*15 12.15.2009 IHS/OIT/FCJ ADDED ACHS("IPD") TO NXT LINE ACHS*3.1*16 ADDED ACHS,ACHSPCNT
  1.  K DA,DFN,DR,ACHS("IPD"),ACHS,ACHSPCNT
  1.  K ^TMP("ACHSCHF",$J)
  1.  D ERPT^ACHS,KILL^AUPNPAT
  1.  Q
  1.  ;
  1. HDR ;
  1.  S Y=DFN
  1.  D ^AUPNPAT
  1.  W @IOF,!,ACHS("*"),!,$$C^XBFUNC("CATASTROPHIC HEALTH EMERGENCY FUND REIMBURSEMENT SEARCH"),!,ACHS("*"),!,ACHSTIME,!,ACHST2,!,ACHST3,!,ACHS("*")
  1.  W !!,$P($G(^DPT(DFN,0)),U),!,$S(SEX="F":"Female",SEX="M":"Male",1:"<sex missing>"),", born ",$$FMTE^XLFDT(DOB),", SSN: ",SSN,", HRN: ",$$HRN^ACHS(DFN,DUZ(2))
  1.  D EN^ACHSRP31
  1. H ;EP
  1.  ;ACHS*3.1*15 12.15.2009 IHS/OIT/FCJ CHANGED NXT LINE COLUMNS
  1.  W !,"|13. PROVIDER",?18,"|14. DOS",?31,"|15. P.O. #",?43,"|16. OBL",?54,"|17. PAID",?65,"|18. DATE PD",?78,"|"
  1.  W !,"|-----------------",?18,"|------------",?31,"|-----------",?43,"|----------",?54,"|----------",?65,"|------------|"
  1.  Q
  1.  ;
  1. POSUM ;EP - Add one PO.
  1.  S ACHSPROV=$P(ACHSDOCR,U,8),ACHSEDOS=DT,ACHSACO=""
  1.  D ^ACHSUCN
  1.  S ACHSPROV=$E($P($G(^AUTTVNDR(ACHSPROV,0)),U),1,17)
  1.  I $G(C) S ACHSPROV="*"_$E(ACHSPROV,1,16)
  1.  S ACHSPO=$P(ACHSDOCR,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOCR,U)  ;ACHS*3.1*16 11.09.2009 IHS.OIT.FCJ
  1.  S ACHSDTP=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,3)    ;ACHS*3.1*16 11.09.2009 IHS.OIT.FCJ
  1. POSUM2 ;EP - FOR BLANKETS AND SLO   ;ACHS*3.1*16 11.09.2009 IHS.OIT.FCJ
  1.  W !,"|",ACHSPROV
  1.  ;ACHS*3.1*16 11.09.2009 IHS.OIT.FCJ CHANGED NXT LINE TO PRNT ACHSPO INSTEAD OF $P(ACHSDOCR,U,14),"-",ACHSFC,"-",$P(ACHSDOCR,U)
  1.  W ?18,"|",ACHSDOS,?31,"|",ACHSPO,?43,"|",$J($FN(ACHSTAO,",",2),10),?54,"|",$J($FN(ACHSPD,",",2),10)
  1.  ;ACHS*3.1*16 11.09.2009 IHS.OIT.FCJ CHANGED NXT LINE TO PRNT ACHSDTP INSTEAD OF $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")
  1.  W ?65,"|",$$FMTE^XLFDT(ACHSDTP),?78,"|"
  1.  S ACHS("TAO")=ACHS("TAO")+ACHSTAO,ACHS("PD")=ACHS("PD")+ACHSPD
  1.  ;ACHS*3.1*15 12.15.2009 IHS/OIT/FCJ ADDED NXT LINE FOR TOTAL IHS PAID
  1.  S ACHS("IPD")=ACHS("IPD")+$S(ACHSPD=0:ACHSTAO,1:ACHSPD)
  1.  K ACHSPROV,ACHSEDOS,ACHSACO,C
  1.  Q
  1.  ;
  1. PAT ;EP -  Print summary patient info.
  1.  ;ACHS*3.1*15 12.15.2009 IHS/OIT/FCJ CHANGED NXT SECTION TO PRINT SUBTOTALS AND CHANGED FIELD NUMBERS
  1.  W !,"|",$$REPEAT^XLFSTR("-",42),"|==========|==========|------------",?78,"|",!,"|19. SUB-TOTALS",$$REPEAT^XLFSTR(".",28),?43,"|",$J($FN(ACHS("TAO"),",",2),10),?54,"|",$J($FN(ACHS("PD"),",",2),10),?65,"|",?78,"|"
  1.  W !,"|------------------------------------------",?43,"|----------",?54,"|----------",?65,"|------------|"
  1.  W !,"|20. TOTAL IHS COSTS",$$REPEAT^XLFSTR(".",23),?43,"|",?54,"|",$J($FN(ACHS("IPD"),",",2),10),?65,"|",?78,"|"
  1.  W !,"|21. LESS THRESHOLD",$$REPEAT^XLFSTR(".",24),?43,"|",?54,"|",$J($FN(ACHSTODA,",",2),10),?65,"|",?78,"|"
  1.  W !,"|22. NET ELIGIBLE FROM FUND",$$REPEAT^XLFSTR(".",16),?43,"|",?54,"|",$J($FN(ACHS("IPD")-ACHSTODA,",",2),10),?65,"|",?78,"|"
  1.  ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ 2 NEW LINES TO PRT % REQUESTED AMT, MOD LINE 23 TO ADD AMENDMENT PAID AND NEW LINE 24 FOR PENDING AMENDMENTS,ADDED ACHSTOTA AND ACHSTOTR TO LINE 25
  1.  S:'$G(ACHSPCNT) ACHSPCNT=1
  1.  W !,"|22.a PERCENT OF LINE 22 TO BE REIMBURSED",$$REPEAT^XLFSTR(".",2),?43,"|",?54,"|",$J($FN(ACHSPCNT*((ACHS("IPD")-ACHSTODA)),",",2),10),?65,"|",?78,"|"
  1.  W !,"|23. LESS ADVANCES TO DATE",$$REPEAT^XLFSTR(".",17),"|",?54,"|",$J($FN(($G(ACHSTOTL)+$G(ACHSTOTR)),",",2),10),?65,"|",?78,"|"
  1.  W !,"|24. LESS AMENDMENTS PENDING PAYMENT",$$REPEAT^XLFSTR(".",7),"|",?54,"|",$J($FN($G(ACHSTOTA),",",2),10),?65,"|",?78,"|"
  1.  W !,"|25. TOTAL REQUESTED AMOUNT",$$REPEAT^XLFSTR(".",16),?20,"|",?54,"|",$J($FN(ACHSPCNT*(ACHS("IPD")-ACHSTODA)-$G(ACHSTOTL)-$G(ACHSTOTA)-$G(ACHSTOTR),",",2),10),?65,"|",?78,"|"
  1.  ;W !,"|25. TOTAL REQUESTED AMOUNT",$$REPEAT^XLFSTR(".",16),?20,"|",?54,"|",$J($FN(ACHS("TAO")-$G(ACHSTODA)-$G(ACHSTOTL),",",2),10),?65,"|",?78,"|"
  1.  D RTRN^ACHS
  1.  Q
  1.  ;