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

ACHSCHF1.m

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