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