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