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

ACHSEOB2.m

Go to the documentation of this file. 
  1. ACHSEOB2 ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (3/6) - PRINT EOBR ;   
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**21,23**;JUN 11, 2001;Build 43
  1.  ;ACHS*3.1*23 CHANGED E RECORD TO TEST FOR E OR J AND USE VAR ACHSREJ
  1.  ;
  1.  I ACHSEOIO'=IO S IOP=ACHSEOIO D ^%ZIS   ;ACHS*3.1*21
  1.  S ACHSREJ=$S($D(ACHSEOBR("E")):"E",$D(ACHSEOBR("J")):"J",1:"")   ;ACHS*3.1*23
  1.  U ACHSEOIO
  1.  W @IOF
  1.  I $P($P(^%ZIS(2,IOST(0),0),U,1),"-",1)="P",($D(^%ZIS(2,IOST(0),5))),$L($P(^(5),U,2)),$L($P(^(5),U,1)) W @($P(^%ZIS(2,IOST(0),5),U,2)) S IOM=90
  1.  W !!?20,"+++  EXPLANATION OF BENEFITS REPORT  +++",!,ACHSTIME
  1.  W !?5,"INDIAN HEALTH SERVICE",?47,"CONTRACT HEALTH SERVICES",!
  1.  ;
  1.  I +ACHSEOBR("A",8) W ?62,"CLAIM SEQ. COUNT ",$J(+$G(ACHSEOBR("A",8)),9)  ;CLAIM SEQUENCE COUNT
  1. A ;
  1.  W !!,"AREA OFFICE:   ",$E($P(^AUTTAREA($O(^AUTTAREA("C",ACHSEOBR("A",1),0)),0),U),1,17)
  1.  W ?34,"CHECK NUMB.: ",$G(ACHSEOBR("A",9))
  1.  W !!,"SERVICE UNIT:  ",$E($P(^AUTTSU($O(^AUTTSU("C",ACHSEOBR("A",1)_ACHSEOBR("A",2),0)),0),U),1,17)
  1.  ;
  1.  ; Labels begin in col 1 and 35.
  1.  ; Begin print info in col 20 and 48.
  1.  ;
  1.  W ?34,"REMITTANCE.: ",$G(ACHSEOBR("A",10))
  1.  W ?64,"DATE: ",$E(ACHSEOBR("A",11),5,6),"/",$E(ACHSEOBR("A",11),7,8),"/",$E(ACHSEOBR("A",11),1,4)
  1.  ;
  1.  W !!!,"PURCHASE ORDER NO: ",$G(ACHSEOBR("A",12))
  1.  W ?34,"CONTROL NO.: ",$G(ACHSEOBR("A",13)),"-",$G(ACHSEOBR("A",5))
  1. B ;
  1.  W !!,"AUTHORIZING FAC..: ",$G(ACHSEOBR("A",14))
  1.  W ?34,"PATIENT NAM: ",$G(ACHSEOBR("B",8)),!
  1.  I $O(^AUTTLOC("C",ACHSEOBR("A",14),0)) W ?19,"(",$P(^AUTTLOC($O(^AUTTLOC("C",ACHSEOBR("A",14),0)),0),U,2),")"
  1.  ;
  1.  W !,"DOCUMENT TYPE....: ",$G(ACHSEOBR("A",15))
  1.  W ?34,"HLTH REC NO: ",$G(ACHSEOBR("B",9))
  1.  ;
  1.  W !!,"AUTH. DATE.......: ",$$FMTE^XLFDT($G(ACHSEOBR("B",10))-17000000)
  1.  W ?34,"ACTUAL DAYS:",?47,$G(ACHSEOBR("B",11))
  1.  ;
  1.  ;D RTRN^ACHS
  1.  ;I $G(ACHSQUIT) D END Q
  1.  I IO=IO(0) D RTRN^ACHS I $G(ACHSQUIT) D END Q  ;ACHS*3.1*21
  1. C ;
  1.  W !!,"COMMON ACCTG NO..: ",$E($G(ACHSEOBR("C",8)),1,7)
  1.  W ?34,"DRG........: ",$E($G(ACHSEOBR("C",8)),1,7)
  1.  ; W ?47,"RATE QUOTE:" ; RQ is currently indicated with an "R" in the Contract number for those areas using RQ.   GTH 05-22-97
  1.  ;
  1.  W !,"INTEREST CAN.....: ",$G(ACHSEOBR("I",8))
  1.  W ?34,"DIS. STATUS: ",$G(ACHSEOBR("B",13))
  1.  W !!,"OBJECT CLASS CODE: ",$G(ACHSEOBR("C",9))
  1.  W ?34,"SERV BILLED:"
  1.  S X=$G(ACHSEOBR("C",10))
  1.  W ?47,$S(X="A":"PROFESSIONAL",X="B":"INPATIENT",X="C":"OUTPAT",X="D":"DENTAL",X="E":"ANCILLARY",X="F":"NON-PATIENT SPECIFIC",1:"UNKNOWN")
  1.  W !,"SERVICE CLASS CODE: ",$G(ACHSEOBR("B",14))
  1.  W ?34,"INTERST OCC: ",$G(ACHSEOBR("I",9))
  1.  W !!,"BLANKET IND......: ",$S($G(ACHSEOBR("C",11))="Y":"YES",$G(ACHSEOBR("C",11))="N":"NO",1:"??")
  1.  W ?34,"CONTRACT NO: ",$G(ACHSEOBR("C",12))
  1.  W !!,"INTERIM/FINAL IND: ",$S($G(ACHSEOBR("C",13))="F":"FINAL",$G(ACHSEOBR("C",13))="I":"INTERIM",1:"??")
  1.  W ?34,"VENDOR NO..: ",$G(ACHSEOBR("C",16))
  1. D ;
  1.  W !!,"EST SERV DATES...: "
  1.  I +$G(ACHSEOBR("C",14)) W $E(ACHSEOBR("C",14),5,6),"/",$E(ACHSEOBR("C",14),7,8),"/",$E(ACHSEOBR("C",14),1,4)
  1.  ;
  1.  W ?34,"VENDOR NAME: ",$E($G(ACHSEOBR("D",8)),1,30),!
  1.  ;
  1.  I +$G(ACHSEOBR("C",15)) W ?19,$E(ACHSEOBR("C",15),5,6),"/",$E(ACHSEOBR("C",15),7,8),"/",$E(ACHSEOBR("C",15),1,4)
  1.  ;
  1.  W !,"INTEREST RATE.(%): "
  1.  S X=$G(ACHSEOBR("I",10))
  1.  I X W $FN($E(X,1,2)_"."_$E(X,3,5),"",3)
  1.  ;
  1.  W !,"DAYS ELIGIBLE....: "
  1.  W:+$G(ACHSEOBR("I",11)) ACHSEOBR("I",11)
  1.  ;
  1.  ;D RTRN^ACHS
  1.  ;G END:$G(ACHSQUIT)
  1.  I IO=IO(0) D RTRN^ACHS G END:$G(ACHSQUIT)   ;ACHS*3.1*21
  1.  ;
  1.  S X=$G(ACHSEOBR("D",9))
  1.  D FMT
  1.  W !!!?19,"BILLED BY PROVIDER..........$",$G(X)
  1.  S X=$G(ACHSEOBR("D",10))
  1.  D FMT
  1.  W !?19,"ALLOWABLE AMOUNT............$",$G(X)
  1.  S X=$G(ACHSEOBR("D",11))
  1.  D FMT
  1.  W !?19,"AMOUNT PAID BY THIRD PARTY..$",$G(X)
  1. E ;
  1.  ;ACHS*3.1*23 CHANGED ALL "E" TO ACHSREJ
  1.  S X=$G(ACHSEOBR(ACHSREJ,8))
  1.  D FMT
  1.  W !?19,"FI PRINCIPLE PAYMENT........$",$G(X)
  1.  S X=$G(ACHSEOBR(ACHSREJ,10))
  1.  D FMT
  1.  W !?19,$S($G(ACHSEOBR(ACHSREJ,9))=1:"P.O.NBR",$G(ACHSEOBR(ACHSREJ,9))=2:"SHR 424",1:"???????")," OBLIGATION AMOUNT...$",$G(X)
  1.  ;
  1.  S X=$G(ACHSEOBR("I",12))
  1.  D FMT
  1.  W !?19,"INTEREST PAID...............$",$G(X)
  1.  ;
  1.  S X=$G(ACHSEOBR("I",13))
  1.  D FMT
  1.  W !?19,"ADDITIONAL PENALTY PAID.....$",$G(X)
  1.  ;
  1.  S X=$G(ACHSEOBR("I",14))
  1.  D FMT
  1.  W !?19,"TOTAL PAID THIS TRANSACTION.$",$G(X)
  1.  ;
  1.  ;D RTRN^ACHS
  1.  ;I $G(ACHSQUIT) D END Q
  1.  I IO=IO(0) D RTRN^ACHS I $G(ACHSQUIT) D END Q   ;ACHS*3.1*21
  1.  ;
  1.  W !!,"DIAGNOSIS CODES: "
  1.  ;F ACHS=12:1:16 W "   ",$G(ACHSEOBR("E",ACHS))
  1.  F ACHS=12:1 Q:'$D(ACHSEOBR(ACHSREJ,ACHS))  W $G(ACHSEOBR(ACHSREJ,ACHS))," " W:ACHS#8=0 !  ;ACHS*3.1*23
  1.  ;ACHS*3.1*23 END OF CHANGE E TO ACHSREJ
  1.  ;
  1.  W !,"PROCEDURE CODES:"
  1.  I $D(ACHSEOBR("G")) F ACHS=8:1:12 W "  ",$G(ACHSEOBR("G",ACHS))  ;ACHS*3.1*23 ADDED 2 CODES
  1.  ;
  1.  ;GET THE F ARRAY FIELDS FROM TMP GLOBAL   ;WHY DOES HE DO THIS?????
  1. F ;
  1.  D FHDR
  1. F1 ;
  1.  S ACHS=0
  1.  F  S ACHS=$O(^TMP("ACHSEOB",$J,"F",ACHS)) Q:+ACHS=0  D
  1.  .S ACHSX=$G(^TMP("ACHSEOB",$J,"F",ACHS))
  1.  .I IO'=IO(0),$Y>(IOSL-8) D HDR,FHDR
  1.  .K ACHSTEMP D REC2^ACHSEOBB(ACHSX,.ACHSTEMP)
  1.  .W !,$E($G(ACHSTEMP("F",8)),5,6),"/",$E($G(ACHSTEMP("F",8)),7,8),"/"
  1.  .W $E($G(ACHSTEMP("F",8)),3,4)," "
  1.  .W $E($G(ACHSTEMP("F",9)),5,6),"/",$E($G(ACHSTEMP("F",9)),7,8),"/"
  1.  .W $E($G(ACHSTEMP("F",9)),3,4)
  1.  .S X="",ACHSZ=$G(ACHSTEMP("F",10))
  1.  .F I=1:1:5 I $E(ACHSZ,I,I)'=" " S X=X_$E(ACHSZ,I,I)
  1.  .W ?20,$J(X,5),?31,$G(ACHSTEMP("F",11)),?37,"$"
  1.  .;S X=$E(ACHSX,43,51)
  1.  .S X=$G(ACHSTEMP("F",12))
  1.  .D FMT
  1.  .W X,?51,"$"
  1.  .;S X=$E(ACHSX,52,60)
  1.  .S X=$G(ACHSTEMP("F",13))
  1.  .D FMT
  1.  .W X,?65,$G(ACHSTEMP("F",14)),?72,$G(ACHSTEMP("F",15))," ",$G(ACHSTEMP("F",16))
  1.  Q
  1.  ;
  1. G ;
  1.  N DIWL,DIWR,DIWF
  1.  S DIWL=7,DIWR=79,DIWF="W"
  1.  W !
  1.  S ACHSMSG=""
  1.  F  S ACHSMSG=$O(ACHSEOBR("M","B",ACHSMSG)) Q:ACHSMSG=""  W !,ACHSMSG," -" D GW
  1.  ;D RTRN^ACHS
  1.   I IO=IO(0) D RTRN^ACHS  ;ACHS*3.1*21
  1.  ;
  1. END ;
  1.  I IO'=IO(0) D HOME^%ZIS  ;ACHS*3.1*21
  1.  I $P($P(^%ZIS(2,IOST(0),0),U,1),"-",1)="P",($D(^%ZIS(2,IOST(0),5))),$L($P(^(5),U,2)),$L($P(^(5),U,1)) W @($P(^%ZIS(2,IOST(0),5),U,1)) S IOM=80
  1.  K ACHSEOBR("M")
  1.  Q
  1.  ;
  1. GW ;
  1.  S ACHSMSGN="MESSAGE NOT ON FILE"
  1.  S ACHSZ="",ACHSZ=$O(^ACHSEOBM("B",ACHSMSG,ACHSZ))
  1.  I 'ACHSZ W ?6,ACHSMSGN Q
  1. GWA ;
  1.  S ACHSY=0
  1.  F  S ACHSY=$O(^ACHSEOBM(ACHSZ,1,ACHSY)) Q:+ACHSY=0  D
  1.  .S X=$$SB^ACHS($$RPL^ACHS(^ACHSEOBM(ACHSZ,1,ACHSY,0),"  "," "))
  1.  .D ^DIWP
  1.  .I IO'=IO(0),$Y>(IOSL-8) D HDR
  1.  D ^DIWW
  1.  Q
  1.  ;
  1. FMT ;
  1.  I X["*" S X=" *********" Q
  1.  I X'["." S X=$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X))
  1.  S X=$J($FN(X,",P",2),11)
  1.  Q
  1.  ;
  1. HDR ;
  1.  W !!?32,"+++ Continued +++",@IOF,!!?16,"+++ EOBR FOR PURCHASE ORDER NO '",ACHSEOBR("A",12),"' +++",!?32,"+++ Continued +++",!,ACHSTIME,!!
  1.  Q
  1.  ;
  1. FHDR ;
  1.  W ?72,"TOOTH",!,"DATES OF SERVICE   PROCEDURE  UNITS   BILLED CHGS    ALLOWABLE    MSG  NBR SURF",!,"-----------------  ---------  -----  ------------  ------------  ----  --------"
  1.  Q
  1.  ;