ACHSCHF1 ; IHS/ITSC/TPF/PMF - PRINT C H E F REIMBURSEMENT REQUEST ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15,16,23**;JUN 11, 2001;Build 43
;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ NEW SUBTOTALS, COMMENTS AND MED PRIORITY CHANGE
;ACHS*3.1*16 11.6.2009 IHS.OIT.FCJ ADDED BLANKET DISPLAY, % requested, AMENDMENT TOTALS
;AND NEW CALC FOR ADVANCES TO DATE, CFR UPDATE
;
D SEL^ACHSCHF2
Q:+Y<1
S ACHSCHEF=+Y
DEV ; Select device/ztload.
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) D K Q
I %="B" D VIEWR^XBLM("START^ACHSCHF1"),EN^XBVK("VALM"),K Q
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS D K 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^ACHSCHF1",ZTDESC="PRINT C H E F REIMBURSEMENT REQUEST, CASE "_$P($G(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0)),U)
F %="ACHSCHEF" S ZTSAVE(%)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
K ZTSK
D K
Q
;
START ;EP - From TaskMan.
D ^ACHSVAR
K ^TMP("ACHSCHF",$J)
S ACHS("IPD")=0 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ ADDED NEW LINE FOR IHS PAID SUB TOTAL
S ACHSTODA=$$PARM^ACHS(2,27),ACHSPO="",ACHS("-")=$$REPEAT^XLFSTR("-",77),ACHSTAB=20,(ACHSDRG,ACHSMPRI)="",ACHSEOCB=9999999,ACHSEOCE="0000000"
F S ACHSPO=$O(^ACHSCHEF(DUZ(2),1,ACHSCHEF,1,"B",ACHSPO)) Q:ACHSPO="" D
. S ACHSDIEN=$O(^ACHSF(DUZ(2),"D","B",1_$E(ACHSPO)_$P(ACHSPO,"-",3),0))
. S ACHSMPRI=ACHSMPRI_","_$$DOC^ACHS(3,6)
. I $$DOC^ACHS(8,1) S ACHSDRG=ACHSDRG_","_$P($G(^ICD($$DOC^ACHS(8,1),0)),U)
. I $$DOC^ACHS(3,1)<ACHSEOCB S ACHSEOCB=$$DOC^ACHS(3,1)
. I $$DOC^ACHS(3,2)>ACHSEOCE S ACHSEOCE=$$DOC^ACHS(3,2)
. S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
. S ACHSTIEN=0
. F S ACHSTIEN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN)) Q:'ACHSTIEN S ACHSTRAN=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,2) D SET^ACHSCHF
.Q
S ACHSPCNT=.01*$P(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0),U,4) S:ACHSPCNT=0 ACHSPCNT=1 ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ NEW LINE FOR %
;
B1 ;BLANKETS AND SLO ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ
I $D(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3)) D
.S ACHS=0
.F S ACHS=$O(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3,ACHS)) Q:ACHS'?1N.N D
..S ACHSPO=$O(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3,"B",ACHSPO)) Q:ACHSPO=""
..S ACHSDIEN=$O(^ACHSF(DUZ(2),"D","B",1_$E(ACHSPO)_$P(ACHSPO,"-",3),0))
..W !,ACHSPO," ",ACHSDIEN
..D SETBS^ACHSCHF
;
A1 ;TOTAL AMENDMENTS ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ
S (ACHSTOTA,ACHSTOTR)=0
I $D(^ACHSCHEF(DUZ(2),1,ACHSCHEF,4)) D
.S ACHS=0
.F S ACHS=$O(^ACHSCHEF(DUZ(2),1,ACHSCHEF,4,ACHS)) Q:ACHS'?1N.N D
..S ACHSST=$P(^ACHSCHEF(DUZ(2),1,ACHSCHEF,4,ACHS,0),U,4),ACHSAMT=$P(^(0),U,2)
..I ACHSST="P" S ACHSTOTR=ACHSTOTR+ACHSAMT
..E S ACHSTOTA=ACHSTOTA+ACHSAMT
;
S DFN=0
U IO
P1 ;
S DFN=$O(^TMP("ACHSCHF",$J,DFN))
G:'DFN END
D HDR
G:$G(ACHSQUIT) END
S (ACHSDIEN,ACHS("TAO"),ACHS("PD"))=0
P2 ;
S ACHSDIEN=$O(^TMP("ACHSCHF",$J,DFN,ACHSDIEN))
;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ ADDED PB TO NXT LINE
I 'ACHSDIEN D PB,BOT G 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^ACHSCHF 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
;
PB ;SECTION TO PRINT BLANKET INFORMATION ;ACHS*3.1*16 IHS.OIT.FCJ
S ACHS=0
F S ACHS=$O(^TMP("ACHSCHF",$J,DFN,"BLK",ACHS)) Q:ACHS'?1N.N D
.S ACHSDOS=""
.S ACHSPO=$P(^TMP("ACHSCHF",$J,DFN,"BLK",ACHS),U),ACHSPROV=$P(^(ACHS),U,5)
.S ACHSTAO=$P(^TMP("ACHSCHF",$J,DFN,"BLK",ACHS),U,2)
.S ACHSPD=$P(^TMP("ACHSCHF",$J,DFN,"BLK",ACHS),U,3),ACHSDTP=$P(^(ACHS),U,4)
.I 'ACHSPD S ACHSPD=ACHSTAO
.D POSUM2^ACHSCHF
Q
END ; Ask RTRN, write IOF.
D RTRN^ACHS
W @IOF
K ;EP - Kill vars, do ERPT, quit.
D EN^XBVK("ACHS"),^ACHSVAR
K DA,DFN,DR,^TMP("ACHSCHF",$J),ACHSREM,X ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ ADDED ACHSREM AND X
D ERPT^ACHS
Q
;
HDR ; Write header of CHEF sheet.
W @IOF,!,"|",ACHS("-"),"|",!,"|",$$C^XBFUNC("CATASTROPHIC HEALTH EMERGENCY FUND REIMBURSEMENT REQUEST",76),?78,"|"
D LN
;
W !,"|1. AREA",?30,"|2. ORDERING FACILITY",?60,"|3. CHEF NUMBER",?78,"|"
W !,"|",$$VAL^XBDIQ1(9999999.06,DUZ(2),.04)
W ?30,"|",$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)
S DA(1)=DUZ(2),DA=ACHSCHEF
W ?60,"|",$$VAL^XBDIQ1(9002064.11,.DA,.01)
W ?78,"|"
D LN
;
W !,"|4. PATIENT NAME",?30,"|5. DATE OF BIRTH",?60,"|6. SEX M/F",?78,"|"
W !,"|",$$VAL^XBDIQ1(2,DFN,.01)
W ?30,"|",$$DOB^AUPNPAT(DFN,"E")
W ?60,"|",$$SEX^AUPNPAT(DFN),?78,"|"
D LN
;
;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED NXT 2 LINES FOR FORMAT CHANGE
W !,"|7. TRIBE: " I $P($G(^AUPNPAT(DFN,11)),U,08)'="" W $P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,08),0),U,2)
W ?20,"|8. EPISODE OF CARE ",$$FMTE^XLFDT(ACHSEOCB)," TO ",$$FMTE^XLFDT(ACHSEOCE),?78,"|"
D LN
;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED FORMAT IN NXT LINE;ACHS*3.1*23 REMV REF TO ICD9
W !,"|9. DX,ICD CM, OR , DRG#",?25,"|10. CAT. CODE",?39,"|11. TRAUMA CD",?54,"|12. MEDICAL PRIORITY",?78,"|"
;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED MEDICAL PRIORITY FIELD TO THE FIRST PO ONLY
;W !,"|",$E(ACHSDRG,2,23),?25,"|",?39,"|",?54,"|",$E(ACHSMPRI,2,23),?78,"|"
W !,"|",$E(ACHSDRG,2,23),?25,"|",?39,"|",?54,"|",?64,$P(ACHSMPRI,",",2),?78,"|"
D LN
;
D RTRN^ACHS
Q:$G(ACHSQUIT)
;
S ACHSTAB=0
;ACHS*3.1*15 IHS.OIT.FCJ COMMENTED OUT NXT 3 LINES
; W !,"|12. ALTERNATE RESOURCES",?26,"|13. CONTRACT SOURCE",?48,"|14. EPISODE OF CARE",?78,"|"
;W !,"| (See Below)",?26,"|Provider marked w/'*'",?48,"|",$$FMTE^XLFDT(ACHSEOCB)," TO ",$$FMTE^XLFDT(ACHSEOCE),?78,"|"
;D LN
D EN^ACHSRP31,LN
;
S ACHSTAB=20
D H^ACHSCHF
Q
;
BOT ; Print bottom of CHEF.
S ACHSTOTL=$P($G(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0)),U,3)
D PAT^ACHSCHF
Q:$G(ACHSQUIT)
S ACHSREM=""
I $D(^ACHSCHEF(DUZ(2),1,ACHSCHEF,2)) D
.S X=0 F S X=$O(^ACHSCHEF(DUZ(2),1,ACHSCHEF,2,X)) Q:X'?1N.N D
..S ACHSREM=ACHSREM_" "_^ACHSCHEF(DUZ(2),1,ACHSCHEF,2,X,0) Q:$L(ACHSREM)>79
D LN
W !,"|I hereby certify that the information and costs listed are associated with",?78,"|",!,"|this catastrophic illness/incident, and that case management has been",?78,"|"
W !,"|performed. 42.CFR SEC 136 HAS BEEN MET.",?78,"|" ;ACHS*3.1*16 IHS.OIT.FCJ ADDED 1 TO THE SEC 36
D LN
W !,"|26. SRVC UNIT DIRECTOR / Date",?30,"|27. CASE MANAGER / Date",?57,"|28. AREA CERT / Date",?78,"|"
W !,"|",?30,"|",?57,"|",?78,"|"
D LN
;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED NXT SECTION FOR FORMAT CHANGE AND ADDED REMARKS
;REMARKS LIMITED TO 33 ON FIRST LINE AND 46 ON THE SECOND
;W !,"|39. AREA CHSO APPROVAL / Date",?30,"|30. 42.CFR SEC.36 MET",?57,"|31. REMARKS",?78,"|"
W !,"|29. AREA CHSO APPROVAL / Date",?30,"|30. REMARKS: ",$E(ACHSREM,1,33)
W ?78,"|"
W !,"|",?30,"|",$E(ACHSREM,34,79)
W ?78,"|"
W !,"|",$$REPEAT^XLFSTR("-",77),?78,"|"
W !,"|TRAUMA CAUSE CODE: MV=MOTORVEHICLE, F=FALL, S=SUICIDE,",?78,"|",!,"|A=ASSAULT, B=BURN, D=DROWNING, O=OTHER, U=UNKNOWN",?78,"|"
W !,"|* indicates provider is a contract source",?78,"|"
D LN
Q
;
LN ;
W !,"|",ACHS("-"),"|"
Q
;
ACHSCHF1 ; IHS/ITSC/TPF/PMF - PRINT C H E F REIMBURSEMENT REQUEST ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15,16,23**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ NEW SUBTOTALS, COMMENTS AND MED PRIORITY CHANGE
+3 ;ACHS*3.1*16 11.6.2009 IHS.OIT.FCJ ADDED BLANKET DISPLAY, % requested, AMENDMENT TOTALS
+4 ;AND NEW CALC FOR ADVANCES TO DATE, CFR UPDATE
+5 ;
+6 DO SEL^ACHSCHF2
+7 IF +Y<1
QUIT
+8 SET ACHSCHEF=+Y
DEV ; Select device/ztload.
+1 SET %=$$PB^ACHS
+2 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
DO K
QUIT
+3 IF %="B"
DO VIEWR^XBLM("START^ACHSCHF1")
DO EN^XBVK("VALM")
DO K
QUIT
+4 SET %ZIS="OPQ"
+5 DO ^%ZIS
+6 IF POP
DO HOME^%ZIS
DO K
QUIT
+7 IF '$DATA(IO("Q"))
GOTO START
+8 KILL IO("Q")
+9 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+10 SET ZTRTN="START^ACHSCHF1"
SET ZTDESC="PRINT C H E F REIMBURSEMENT REQUEST, CASE "_$PIECE($GET(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0)),U)
+11 FOR %="ACHSCHEF"
SET ZTSAVE(%)=""
+12 DO ^%ZTLOAD
+13 IF '$DATA(ZTSK)
GOTO DEV
+14 KILL ZTSK
+15 DO K
+16 QUIT
+17 ;
START ;EP - From TaskMan.
+1 DO ^ACHSVAR
+2 KILL ^TMP("ACHSCHF",$JOB)
+3 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ ADDED NEW LINE FOR IHS PAID SUB TOTAL
SET ACHS("IPD")=0
+4 SET ACHSTODA=$$PARM^ACHS(2,27)
SET ACHSPO=""
SET ACHS("-")=$$REPEAT^XLFSTR("-",77)
SET ACHSTAB=20
SET (ACHSDRG,ACHSMPRI)=""
SET ACHSEOCB=9999999
SET ACHSEOCE="0000000"
+5 FOR
SET ACHSPO=$ORDER(^ACHSCHEF(DUZ(2),1,ACHSCHEF,1,"B",ACHSPO))
IF ACHSPO=""
QUIT
Begin DoDot:1
+6 SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"D","B",1_$EXTRACT(ACHSPO)_$PIECE(ACHSPO,"-",3),0))
+7 SET ACHSMPRI=ACHSMPRI_","_$$DOC^ACHS(3,6)
+8 IF $$DOC^ACHS(8,1)
SET ACHSDRG=ACHSDRG_","_$PIECE($GET(^ICD($$DOC^ACHS(8,1),0)),U)
+9 IF $$DOC^ACHS(3,1)<ACHSEOCB
SET ACHSEOCB=$$DOC^ACHS(3,1)
+10 IF $$DOC^ACHS(3,2)>ACHSEOCE
SET ACHSEOCE=$$DOC^ACHS(3,2)
+11 SET ACHSDOCR=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
+12 SET ACHSTIEN=0
+13 FOR
SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN))
IF 'ACHSTIEN
QUIT
SET ACHSTRAN=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,2)
DO SET^ACHSCHF
+14 QUIT
End DoDot:1
+15 ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ NEW LINE FOR %
SET ACHSPCNT=.01*$PIECE(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0),U,4)
IF ACHSPCNT=0
SET ACHSPCNT=1
+16 ;
B1 ;BLANKETS AND SLO ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ
+1 IF $DATA(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3))
Begin DoDot:1
+2 SET ACHS=0
+3 FOR
SET ACHS=$ORDER(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3,ACHS))
IF ACHS'?1N.N
QUIT
Begin DoDot:2
+4 SET ACHSPO=$ORDER(^ACHSCHEF(DUZ(2),1,ACHSCHEF,3,"B",ACHSPO))
IF ACHSPO=""
QUIT
+5 SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"D","B",1_$EXTRACT(ACHSPO)_$PIECE(ACHSPO,"-",3),0))
+6 WRITE !,ACHSPO," ",ACHSDIEN
+7 DO SETBS^ACHSCHF
End DoDot:2
End DoDot:1
+8 ;
A1 ;TOTAL AMENDMENTS ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ
+1 SET (ACHSTOTA,ACHSTOTR)=0
+2 IF $DATA(^ACHSCHEF(DUZ(2),1,ACHSCHEF,4))
Begin DoDot:1
+3 SET ACHS=0
+4 FOR
SET ACHS=$ORDER(^ACHSCHEF(DUZ(2),1,ACHSCHEF,4,ACHS))
IF ACHS'?1N.N
QUIT
Begin DoDot:2
+5 SET ACHSST=$PIECE(^ACHSCHEF(DUZ(2),1,ACHSCHEF,4,ACHS,0),U,4)
SET ACHSAMT=$PIECE(^(0),U,2)
+6 IF ACHSST="P"
SET ACHSTOTR=ACHSTOTR+ACHSAMT
+7 IF '$TEST
SET ACHSTOTA=ACHSTOTA+ACHSAMT
End DoDot:2
End DoDot:1
+8 ;
+9 SET DFN=0
+10 USE IO
P1 ;
+1 SET DFN=$ORDER(^TMP("ACHSCHF",$JOB,DFN))
+2 IF 'DFN
GOTO END
+3 DO HDR
+4 IF $GET(ACHSQUIT)
GOTO END
+5 SET (ACHSDIEN,ACHS("TAO"),ACHS("PD"))=0
P2 ;
+1 SET ACHSDIEN=$ORDER(^TMP("ACHSCHF",$JOB,DFN,ACHSDIEN))
+2 ;ACHS*3.1*16 11.9.2009 IHS.OIT.FCJ ADDED PB TO NXT LINE
+3 IF 'ACHSDIEN
DO PB
DO BOT
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^ACHSCHF
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 ;
PB ;SECTION TO PRINT BLANKET INFORMATION ;ACHS*3.1*16 IHS.OIT.FCJ
+1 SET ACHS=0
+2 FOR
SET ACHS=$ORDER(^TMP("ACHSCHF",$JOB,DFN,"BLK",ACHS))
IF ACHS'?1N.N
QUIT
Begin DoDot:1
+3 SET ACHSDOS=""
+4 SET ACHSPO=$PIECE(^TMP("ACHSCHF",$JOB,DFN,"BLK",ACHS),U)
SET ACHSPROV=$PIECE(^(ACHS),U,5)
+5 SET ACHSTAO=$PIECE(^TMP("ACHSCHF",$JOB,DFN,"BLK",ACHS),U,2)
+6 SET ACHSPD=$PIECE(^TMP("ACHSCHF",$JOB,DFN,"BLK",ACHS),U,3)
SET ACHSDTP=$PIECE(^(ACHS),U,4)
+7 IF 'ACHSPD
SET ACHSPD=ACHSTAO
+8 DO POSUM2^ACHSCHF
End DoDot:1
+9 QUIT
END ; Ask RTRN, write IOF.
+1 DO RTRN^ACHS
+2 WRITE @IOF
K ;EP - Kill vars, do ERPT, quit.
+1 DO EN^XBVK("ACHS")
DO ^ACHSVAR
+2 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ ADDED ACHSREM AND X
KILL DA,DFN,DR,^TMP("ACHSCHF",$JOB),ACHSREM,X
+3 DO ERPT^ACHS
+4 QUIT
+5 ;
HDR ; Write header of CHEF sheet.
+1 WRITE @IOF,!,"|",ACHS("-"),"|",!,"|",$$C^XBFUNC("CATASTROPHIC HEALTH EMERGENCY FUND REIMBURSEMENT REQUEST",76),?78,"|"
+2 DO LN
+3 ;
+4 WRITE !,"|1. AREA",?30,"|2. ORDERING FACILITY",?60,"|3. CHEF NUMBER",?78,"|"
+5 WRITE !,"|",$$VAL^XBDIQ1(9999999.06,DUZ(2),.04)
+6 WRITE ?30,"|",$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)
+7 SET DA(1)=DUZ(2)
SET DA=ACHSCHEF
+8 WRITE ?60,"|",$$VAL^XBDIQ1(9002064.11,.DA,.01)
+9 WRITE ?78,"|"
+10 DO LN
+11 ;
+12 WRITE !,"|4. PATIENT NAME",?30,"|5. DATE OF BIRTH",?60,"|6. SEX M/F",?78,"|"
+13 WRITE !,"|",$$VAL^XBDIQ1(2,DFN,.01)
+14 WRITE ?30,"|",$$DOB^AUPNPAT(DFN,"E")
+15 WRITE ?60,"|",$$SEX^AUPNPAT(DFN),?78,"|"
+16 DO LN
+17 ;
+18 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED NXT 2 LINES FOR FORMAT CHANGE
+19 WRITE !,"|7. TRIBE: "
IF $PIECE($GET(^AUPNPAT(DFN,11)),U,08)'=""
WRITE $PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,08),0),U,2)
+20 WRITE ?20,"|8. EPISODE OF CARE ",$$FMTE^XLFDT(ACHSEOCB)," TO ",$$FMTE^XLFDT(ACHSEOCE),?78,"|"
+21 DO LN
+22 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED FORMAT IN NXT LINE;ACHS*3.1*23 REMV REF TO ICD9
+23 WRITE !,"|9. DX,ICD CM, OR , DRG#",?25,"|10. CAT. CODE",?39,"|11. TRAUMA CD",?54,"|12. MEDICAL PRIORITY",?78,"|"
+24 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED MEDICAL PRIORITY FIELD TO THE FIRST PO ONLY
+25 ;W !,"|",$E(ACHSDRG,2,23),?25,"|",?39,"|",?54,"|",$E(ACHSMPRI,2,23),?78,"|"
+26 WRITE !,"|",$EXTRACT(ACHSDRG,2,23),?25,"|",?39,"|",?54,"|",?64,$PIECE(ACHSMPRI,",",2),?78,"|"
+27 DO LN
+28 ;
+29 DO RTRN^ACHS
+30 IF $GET(ACHSQUIT)
QUIT
+31 ;
+32 SET ACHSTAB=0
+33 ;ACHS*3.1*15 IHS.OIT.FCJ COMMENTED OUT NXT 3 LINES
+34 ; W !,"|12. ALTERNATE RESOURCES",?26,"|13. CONTRACT SOURCE",?48,"|14. EPISODE OF CARE",?78,"|"
+35 ;W !,"| (See Below)",?26,"|Provider marked w/'*'",?48,"|",$$FMTE^XLFDT(ACHSEOCB)," TO ",$$FMTE^XLFDT(ACHSEOCE),?78,"|"
+36 ;D LN
+37 DO EN^ACHSRP31
DO LN
+38 ;
+39 SET ACHSTAB=20
+40 DO H^ACHSCHF
+41 QUIT
+42 ;
BOT ; Print bottom of CHEF.
+1 SET ACHSTOTL=$PIECE($GET(^ACHSCHEF(DUZ(2),1,ACHSCHEF,0)),U,3)
+2 DO PAT^ACHSCHF
+3 IF $GET(ACHSQUIT)
QUIT
+4 SET ACHSREM=""
+5 IF $DATA(^ACHSCHEF(DUZ(2),1,ACHSCHEF,2))
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^ACHSCHEF(DUZ(2),1,ACHSCHEF,2,X))
IF X'?1N.N
QUIT
Begin DoDot:2
+7 SET ACHSREM=ACHSREM_" "_^ACHSCHEF(DUZ(2),1,ACHSCHEF,2,X,0)
IF $LENGTH(ACHSREM)>79
QUIT
End DoDot:2
End DoDot:1
+8 DO LN
+9 WRITE !,"|I hereby certify that the information and costs listed are associated with",?78,"|",!,"|this catastrophic illness/incident, and that case management has been",?78,"|"
+10 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED 1 TO THE SEC 36
WRITE !,"|performed. 42.CFR SEC 136 HAS BEEN MET.",?78,"|"
+11 DO LN
+12 WRITE !,"|26. SRVC UNIT DIRECTOR / Date",?30,"|27. CASE MANAGER / Date",?57,"|28. AREA CERT / Date",?78,"|"
+13 WRITE !,"|",?30,"|",?57,"|",?78,"|"
+14 DO LN
+15 ;ACHS*3.1*15 12.15.2008 IHS/OIT/FCJ CHANGED NXT SECTION FOR FORMAT CHANGE AND ADDED REMARKS
+16 ;REMARKS LIMITED TO 33 ON FIRST LINE AND 46 ON THE SECOND
+17 ;W !,"|39. AREA CHSO APPROVAL / Date",?30,"|30. 42.CFR SEC.36 MET",?57,"|31. REMARKS",?78,"|"
+18 WRITE !,"|29. AREA CHSO APPROVAL / Date",?30,"|30. REMARKS: ",$EXTRACT(ACHSREM,1,33)
+19 WRITE ?78,"|"
+20 WRITE !,"|",?30,"|",$EXTRACT(ACHSREM,34,79)
+21 WRITE ?78,"|"
+22 WRITE !,"|",$$REPEAT^XLFSTR("-",77),?78,"|"
+23 WRITE !,"|TRAUMA CAUSE CODE: MV=MOTORVEHICLE, F=FALL, S=SUICIDE,",?78,"|",!,"|A=ASSAULT, B=BURN, D=DROWNING, O=OTHER, U=UNKNOWN",?78,"|"
+24 WRITE !,"|* indicates provider is a contract source",?78,"|"
+25 DO LN
+26 QUIT
+27 ;
LN ;
+1 WRITE !,"|",ACHS("-"),"|"
+2 QUIT
+3 ;
