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

ACHSEOB3.m

Go to the documentation of this file. 
  1. ACHSEOB3 ; IHS/ITSC/PMF - PROCESS EOBRS (4/6) - UPDATE DOCUMENT(1/2) ;   [ 09/17/2004  11:42 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,11**;JUN 11, 2001;Build 43
  1.  ;ACHS*3.1*4 if error 32 happens, quit, don't keep going
  1.  ;ACHS*3.1*11 Send vendor warning first 10 only no more suffix warnings
  1.  ;
  1.  ;
  1.  S ACHSDERR="",$P(ACHSDERR,"0",40)="",ACHSERRA=0
  1.  ;
  1.  ; Lookup LOCATION using ASUFAC.
  1.  I $D(ACHSISAO) D  I Y<1 S ACHSERRE=21,ACHSEDAT=Y D ^ACHSEOBG Q
  1.  . S DIC="^AUTTLOC(",DIC(0)="",D="C",X=ACHSEOBR("A",14)
  1.  . D IX^DIC S:Y>0 DUZ(2)=+Y
  1.  . Q
  1.  ;
  1.  ; Get financial data for LOCATION.
  1.  D ^ACHSUF
  1.  I $G(ACHSERR) S ACHSERRE=22,ACHSEDAT=$P($G(^DIC(4,DUZ(2),0)),U) D ^ACHSEOBG Q
  1.  ;
  1.  ; Attempt to match the Financial Code of the Document to one of the facilities on this machine.
  1.  I $P(ACHSEOBR("A",12),"-",2)'=ACHSFC D  I $G(ACHSERRE) D ^ACHSEOBG Q
  1.  . S ACHSERRE=7,ACHSEDAT=ACHSEOBR("A",12)
  1.  . S ACHSYAYA=3.14159,DUZ(2)=0 ; Original value maintained in calling routine, ACHSEOBB.
  1.  . F  S ACHSYAYA=99,DUZ(2)=$O(^ACHSF("B",DUZ(2))) Q:'DUZ(2)  D ^ACHSUF I '$G(ACHSERR),$P(ACHSEOBR("A",12),"-",2)=ACHSFC K ACHSERRE,ACHSEDAT Q
  1.  .Q
  1.  ;
  1.  ; Check x-ref for P.O. number.
  1.  S ACHSX="1"_$E(ACHSEOBR("A",12),2)_$E(ACHSEOBR("A",12),8,12),DA=$O(^ACHSF(DUZ(2),"D","B",ACHSX,0))
  1.  I 'DA S ACHSERRE=1,ACHSEDAT=ACHSEOBR("A",12) D ^ACHSEOBG Q
  1.  ;
  1.  ; Check existence of global node.
  1.  I '$D(^ACHSF(DUZ(2),"D",DA,0)) S ACHSERRE=2,ACHSEDAT=DA D ^ACHSEOBG Q
  1.  S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",DA,0))
  1.  S ACHSDCR=$P(ACHSDOCR,U,19)
  1.  ;
  1.  ; Check for same P.O. number.
  1.  I $E(ACHSEOBR("A",12),8,12)'=$P(ACHSDOCR,U) S ACHSERRE=3,ACHSEDAT=ACHSEOBR("A",12) D ^ACHSEOBG Q
  1.  ;
  1.  ; Check for P.O. Authorization date.
  1.  S %=+ACHSEOBR("B",10)-17000000
  1.  I '$D(^ACHSF(DUZ(2),"D",DA,3)) S ACHSERRE=35,ACHSEDAT=$$FMTE^XLFDT(%) D ^ACHSEOBG Q
  1.  ;
  1.  ; Check for P.O. Authorization date match.
  1.  I (%'>($P($G(^ACHSF(DUZ(2),"D",DA,3)),U)-1)&%'<($P($G(^(3)),U,2)+1)) S ACHSERRE=4,ACHSEDAT=$$FMTE^XLFDT(%) D ^ACHSEOBG
  1.  ;
  1.  ; Check for Blanket Indicator match.
  1.  I (ACHSEOBR("C",11)="Y"&($P(ACHSDOCR,U,3)'=1))!(ACHSEOBR("C",11)="N"&($P(ACHSDOCR,U,3)=1)) S ACHSERRE=5,ACHSEDAT=ACHSEOBR("C",11) D ^ACHSEOBG Q
  1.  ;
  1.  ; Check for P.O. type match.
  1.  S X=+ACHSEOBR("A",15),X=$S(X=43:1,X=57:2,X=64:3,1:0)
  1.  I X'=$P(ACHSDOCR,U,4) S ACHSERRE=6,ACHSEDAT=ACHSEOBR("A",15) D ^ACHSEOBG Q
  1.  ;
  1.  ; Check for HRN match.
  1.  I +ACHSEOBR("B",9)'=+$P(ACHSDOCR,U,21) S ACHSERRE=30,ACHSEDAT=ACHSEOBR("B",9) D ^ACHSEOBG
  1.  ;
  1.  S ACHSPSQN=+ACHSEOBR("A",8)
  1.  S ACHSPIND=ACHSEOBR("C",13)
  1.  S ACHSPDAT=ACHSEOBR("A",11)-17000000 ;EOBR DATE FROM TRANSACTION RECORD
  1.  ;
  1.  ; Quit if duplicate transaction.
  1.  I $D(^ACHSF(DUZ(2),"D",DA,"EB1",ACHSPDAT,ACHSPSQN)) S ACHSERRE=8,ACHSEDAT=$$FMTE^XLFDT(ACHSPDAT) D ^ACHSEOBG Q
  1.  ;
  1. CKCK ; Look for previous check number and compare, if same, error 3*15
  1.  ; If match, checks for paid dates and sequence numbers
  1.  ; Checks CHS check number as well as EOBR check numbers first
  1.  D AINFO S ACHSDIEN=DA N ACHSOCHK S ACHSOCHK=""
  1.  I ACHSCHK]"",$D(^ACHSF(DUZ(2),"D",DA,"PA")),+($$DOC^ACHS(2,2))=ACHSCHK S ACHSERRE=41,ACHSEDAT=ACHSCHK D ^ACHSEOBG Q
  1.  I ACHSCHK]"",$D(^ACHSF(DUZ(2),"D",DA,"T")) D  Q:ACHSOCHK=ACHSCHK
  1.  .N ACHSTMP,ACHSTMP2,ACHSOSQN,ACHSOPDT S ACHSTMP=0
  1.  .F  S ACHSTMP=$O(^ACHSF(DUZ(2),"D",DA,"T",ACHSTMP)) Q:'ACHSTMP  D  Q:ACHSOCHK=ACHSCHK
  1.  ..S ACHSTMP2=$G(^ACHSF(DUZ(2),"D",DA,"T",ACHSTMP,0))
  1.  ..S ACHSOCHK=+$P(ACHSTMP2,U,18) ; Strip zeros
  1.  ..Q:ACHSOCHK'=ACHSCHK  ; No match, includes achsochk=""
  1.  ..S ACHSOSQN=$P(ACHSTMP2,U,14),ACHSOPDT=$P(ACHSTMP2,U,13)
  1.  ..I ACHSOPDT'=ACHSPDAT S ACHSOCHK="" Q  ; Different paid dates
  1.  ..I ACHSOSQN'=ACHSPSQN S ACHSOCHK="" Q  ; Different sequence numbers
  1.  ..S ACHSERRE=42,ACHSEDAT=ACHSCHK D ^ACHSEOBG ; Must be duplicate
  1.  ;
  1.  ; If document Cancelled, quit.
  1.  I +$P(ACHSDOCR,U,12)=4 S ACHSERRE=9,ACHSEDAT=$P(ACHSDOCR,U,12) D ^ACHSEOBG Q
  1.  ;
  1.  ; Object Class match.
  1.  D CHKOCC^ACHSEOBN
  1.  ;
  1.  ; CAN match.
  1.  I $E(ACHSEOBR("C",8),1,7)'=$P($G(^ACHS(2,$P(ACHSDOCR,U,6),0)),U) S ACHSERRE=11,ACHSEDAT=ACHSEOBR("C",8) D ^ACHSEOBG
  1.  ;
  1.  ;
  1.  ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1.  S DFN=$P(ACHSDOCR,U,22),ACHSIPA=+$E(ACHSEOBR(ACHSREJ,8),1,7)_"."_$E(ACHSEOBR(ACHSREJ,8),8,9),ACHSFULP=$S(+ACHSEOBR("D",11):"P",1:"F")
  1.  S ACHS3RDP=$S(+ACHSEOBR("D",11):+$E(ACHSEOBR("D",11),1,7)_"."_$E(ACHSEOBR("D",11),8,9),1:""),ACHS3RDS="",ACHSOB=ACHSEOBR(ACHSREJ,9)
  1.  ;
  1.  ;
  1.  ; Check for Interim Denial.
  1.  I +ACHSIPA=0,ACHSPIND="I" S ACHSERRE=31,ACHSEDAT=ACHSPIND D ^ACHSEOBG Q
  1.  ;
  1.  ; Is final pay a 0 amount.
  1.  I +ACHSIPA=0,+ACHS3RDP=0,ACHSPIND'="F" S ACHSERRE=12,ACHSEDAT=ACHSPIND D ^ACHSEOBG Q
  1.  ;
  1. NOERR ;Most of the error checking is done by this time
  1.  S ACHSWKLD=+ACHSEOBR("B",11)
  1.  S:'ACHSWKLD ACHSWKLD=1
  1.  ;BEGIN Y2K BLOCK
  1.  S (ACHS,ACHSWKLD(1),ACHSWKLD(2))=0,ACHSSVDT="99999999"
  1.  K %DT
  1. P1 ;
  1.  S ACHS=$O(^TMP("ACHSEOB",$J,"F",ACHS)) G P2:'ACHS S ACHSX=$G(^TMP("ACHSEOB",$J,"F",ACHS))
  1.  K ACHSTEMP D REC2^ACHSEOBB(ACHSX,.ACHSTEMP)
  1.  I ACHSTEMP("F",8)<+ACHSSVDT S ACHSSVDT=ACHSTEMP("F",8)
  1.  S X=$E(ACHSTEMP("F",8),5,8)_$E(ACHSTEMP("F",8),1,4)
  1.  D ^%DT
  1.  S ACHS("FM")=Y,X=$E(ACHSTEMP("F",9),5,8)_$E(ACHSTEMP("F",9),1,4)
  1.  D ^%DT
  1.  S ACHS("TO")=Y
  1.  F ACHS("X2")=0:1 S X1=ACHS("FM"),X2=ACHS("X2") D C^%DTC I X=ACHS("TO") S ACHSWKLD(1)=ACHSWKLD(1)+ACHS("X2")+1 Q
  1.  S ACHSWKLD(2)=ACHSWKLD(2)+ACHSTEMP("F",11)
  1.  G P1
  1.  ;
  1. P2 ;
  1.  S X=ACHSSVDT,ACHSSVDT=$S(X=99999999:"",1:X-17000000)
  1.  S:ACHSWKLD(1)>ACHSWKLD ACHSWKLD=ACHSWKLD(1)
  1.  S:ACHSWKLD(2)>ACHSWKLD ACHSWKLD=ACHSWKLD(2)
  1.  S ACHSDIEN=DA
  1.  ;END Y2K BLOCK
  1.  ;
  1.  ; If there is a 3P pay amount, and the patient has no insurance on
  1.  ; the local machine in Patient Registration, send a bulletin.
  1.  I ACHS3RDP,ACHSSVDT,'$$INSURED^ACHS(DFN,ACHSSVDT) D SENDMSG^ACHSEOBN
  1.  ;
  1.  ; Vendor missing or no-match.
  1.  D VNDR^ACHSEOBN
  1.  I 'ACHSPROV S ACHSERRE=15,ACHSEDAT=ACHSEOBR("C",16) D ^ACHSEOBG Q
  1.  ;ITSC/SET/JVK ACHS*3.1*11 -Check Base EIN only no warning for suffix mismatch
  1.  ;I ACHSPROV'=$P(ACHSDOCR,U,8) S ACHSERRE=36,ACHSEDAT=ACHSEOBR("C",16) D ^ACHSEOBG
  1.  I $E(ACHSPROV,1,10)'=$E($P(ACHSDOCR,U,8),1,10) S ACHSERRE=36,ACHSEDAT=ACHSEOBR("C",16) D ^ACHSEOBG
  1.  ;
  1.  K ACHSBLKF
  1.  I ACHSEOBR("C",11)="Y",ACHSEOBR("C",13)="I" S ACHSBLKF=""
  1.  S ACHSTYP=+ACHSEOBR("A",15),ACHSTYP=$S(ACHSTYP=43:1,ACHSTYP=57:2,ACHSTYP=64:3,1:0),ACHSDRG=""
  1.  ;
  1.  ; DRG exist on local machine.
  1.  I +ACHSEOBR("B",12) S ACHSDRG=+ACHSEOBR("B",12) I '$D(^ICD(ACHSDRG)) S ACHSDRG="" S ACHSERRE=20,ACHSEDAT=ACHSEOBR("B",12) D ^ACHSEOBG
  1.  ;
  1. PROCESS ; Process the adjustment or payment.
  1.  K ACHSERRE,ACHSEDAT
  1.  S (ACHSADDT,ACHSDIDT,ACHSDITY)=""
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) D  Q:ACHSERRA>0  G INTEREST
  1.  . ;
  1.  . ; If there is an Adjustment amount, do the Adjustment first.
  1.  .D A4A^ACHSAJ        ;AUTOMATIC ADJUSTMENT
  1.  .Q:ACHSERRA>0        ;
  1.  .D AINFO             ;
  1.  .S ACHSOB=ACHSEOBR(ACHSREJ,9) ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J 
  1.  . ;
  1.  . ; If any interest amount, treat as an adjustment.
  1.  .;'INTEREST PAID' AND 'INTEREST ADDTNL PENALTY PAID' FROM TRANSACTION
  1.  . I '$G(ACHSEOBR("I",12)),'$G(ACHSEOBR("I",13)) Q
  1.  . S ACHSIPA=ACHSEOBR("I",12)+ACHSEOBR("I",13)
  1.  . S ACHSIPA=$E(ACHSIPA,1,$L(ACHSIPA)-2)_"."_$E(ACHSIPA,$L(ACHSIPA)-1,$L(ACHSIPA))
  1.  . D A4A^ACHSAJ
  1.  ;
  1.  ;
  1.  ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1.  I +ACHSEOBR(ACHSREJ,8)=0,+ACHS3RDP=0,ACHSPIND="F" D  G INTEREST
  1.  .S X=0
  1.  .S X1=0
  1.  .D TRAN                     ;
  1.  .D A3^ACHSPA:X1'=ACHSPDAT   ;AUTOMATIC EOBR PROCESSING IF EOBR DATE
  1.  .                           ;AND PAID DATE NOT THE SAME ;THESE SEEM TO
  1.  .                           ;BE GOTTEN FROM THE SAME FIELD?????
  1.  .S ACHSERRE=32              ;WHY AUTO SET ERROR?????DOC CANCELLED BY FI
  1.  .;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1.  .S ACHSEDAT=ACHSEOBR(ACHSREJ,8)_"  "_ACHSPIND  ;'IHS PAYMENT AMOUNT' 'TRANSACTION TYPE'
  1.  .D ^ACHSEOBG                ;SET ERROR INTO ERROR GLOBAL ^ACHSEOBR("ER"
  1.  .Q
  1.  ;
  1.  D A3^ACHSPA      ;AUTOMATIC EOBR PROCESSING
  1.  Q:ACHSERRA>0
  1.  ;
  1.  ; Process Interest as Adjustment if any interest amounts were
  1.  ; included with a final pay.
  1.  ;IF 'INTEREST PAID' AND 'INTEREST ADDTNL PENALTY PAID' 
  1. V I $G(ACHSEOBR("I",12))!$G(ACHSEOBR("I",13)) D  Q:ACHSERRA>0
  1.  . S ACHSIPA=ACHSEOBR("I",12)+ACHSEOBR("I",13)
  1.  .;THIS IS A PROBLEM IT DROPS DIGITS IF ACHSIPA ["."
  1.  . S ACHSIPA=$E(ACHSIPA,1,$L(ACHSIPA)-2)_"."_$E(ACHSIPA,$L(ACHSIPA)-1,$L(ACHSIPA))
  1.  . D A4A^ACHSAJ        ;AUTOMATIC ADJUSTMENT
  1.  ;
  1.  ;
  1. INTEREST ; Post Interest data.
  1.  ;
  1.  ;ACHS*3.1*4  if an error has occurred, don't continue
  1.  I $D(ACHSERRE) Q  ;  ACHS*3.1*4
  1.  ;
  1.  ;IF INTEREST DATA DO AUTOMATIC EOBR PROCESSING OF INTEREST DATA
  1.  I $D(ACHSEOBR("I")) D AUTO^ACHSPAI
  1.  ;
  1.  ; Check/post ICD/CPT/Revenue codes(s), Procedure codes
  1.  D ICD^ACHSEOB4,CPTREV^ACHSEOB4,PROC^ACHSEOB4
  1.  ;
  1.  ;IF REFERRAL PTR
  1.  I $$DOC^ACHS(2,7) D
  1.  .D DX^ACHSBMC        ;TRANSFER DX INFO INTO RCIS
  1.  .D PX^ACHSBMC        ;TRANSFER PX INFO INTO RCIS
  1.  ;
  1.  ;IF 'DRG' IS NOT PRESENT SET DRG AND REFERRAL DRG AND REFERRED EST.COST
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),'$P(^ACHSF(DUZ(2),"D",ACHSDIEN,8),U) D
  1.  .S ACHS("DX")=9,ACHS("PX")=10
  1.  .D CDRG^ACHSPAM                ;THIS EXITS RIGHT AWAY
  1.  ;
  1.  ; Post CHS data to PCC
  1.  S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))    ;DOCUMENT 0 NODE
  1.  ;
  1.  ;IF 'POST EOBR TO PAT CARE CMPNT' AND LINK TO PCC IS ON
  1.  ;TRANSFER DATA TO PATIENT CARE COMPONENT
  1.  I $$PARM^ACHS(2,22)="Y",$$LINK^ACHSPAP1 U IO(0) D ^ACHSPAP U IO
  1.  Q
  1.  ;
  1. TRAN ;
  1.  ;GET LAST TRANSACTION ENTRY ????
  1.  ;REPLACE WITH $D(,-1)
  1.  S X=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X))
  1.  Q:X=""
  1.  G TRAN:X=0
  1.  S X1=$S($P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X,0),U,13):$P(^(0),U,13),1:0)
  1.  G TRAN
  1.  ;
  1. AINFO ;Set basic info from A record.  IF THIS IS A STUFF WHY "C" IN HERE?????
  1.  S ACHSCTL=ACHSEOBR("A",13)_ACHSEOBR("A",5)  ;FIRST 7 OF CONTROL #_ EOBR CONTROL #  ????
  1.  S ACHSCHK=ACHSEOBR("A",9)     ;CHECK #
  1.  S ACHSREM=ACHSEOBR("A",10)    ;EOBR REMIT. #
  1.  S ACHSSV=ACHSEOBR("C",10)     ;EOBR SERVICES BILLED
  1.  Q
  1.  ;