Routine: ACHSEOB9

ACHSEOB9; IHS/ITSC/FCJ - PROCESS EOBRS for 3 digit icd code ;   [ 09/17/2004  11:42 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22,23**;JUN 11, 2001;Build 43

 ;ACHS*3.1*22 new routine combined parts of ACHSEOBB, ACHSEOB3 AND ACHSEOB4 FOR

 ;            updating the 3 digit icd9 codes entered in error

M1 ;EP

 S ACHSDUZ2=DUZ(2) D EOB3 S ACHSYAYA=19,DUZ(2)=ACHSDUZ2 D ^ACHSUF K ACHSYAYA

 ;A= HEADING A    H=SUMMARY

 I $E(ACHSEOBR,19)'="A"!$E(ACHSEOBR,19)'="H"!$E(ACHSEOBR,1,2)'="**" G M1A

 U IO(0)

 ;IF CHAR 19 NOT EQUAL TO 'A' OR 'H' OR FIRST TWO CHARS NOT '**' THEN ERROR??????

 W *7,*7,!!,"LAST RECORD READ WAS OUT OF SEQUENCE",!!,"CONTACT YOUR SITEMANAGER - SEE ^ACHSEOBR(""SEQ-ERROR"").",!!

 S ^ACHSEOBR("SEQ-ERROR")=ACHSEOBR,ACHSTERR=5    ;CHAR 19 ERROR

M1A ;

 I $G(ACHSEOBR("A",12))'="" D

 .S ^ACHSEOBR("P",$E(ACHSEOBR("A",12),2,12),ACHSCTR(1))=ACHSZFPT

 .S ACHSOLD=$E(ACHSEOBR,1,18)

 .S X=ACHSEOBR

 K ^TMP("ACHSEOB",$J),ACHSEOBR,ACHSERRE

 S ACHSADAM=""

 S ACHSEOBR=X

EOB3 ;

 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

 ; 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

 ; 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

 ; 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

 S DFN=$P(ACHSDOCR,U,22),ACHSIPA=+$E(ACHSEOBR("E",8),1,7)_"."_$E(ACHSEOBR("E",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("E",9)

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

 ; 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

ICD ;Post ICD

 ;ACHS*3.1*22 ADDED FOR ICD LENGTH OF 3, TO FX ISSUE OF CSV LOOK UP BY IEN

 ;F ACHS=12:1:16 S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D:$L(ACHSX)<3 ICNV1 D:$L(ACHSX)>3 ICNV D I1

 ;SET UP THE TEMP GLOBAL OF ICD NODE 9

 ;ACHSFXF=FIX FLAG, ACHSFX=NODES TO BE TESTED,ACHSICDO=CURRENT POINTER,ACHSICDN=NEW POINTER

 ;ACHSFXI=CODES FR THE FI THAT WERE NOT FOUND

 N ACHSTMP S ACHSTMP=0 K ACHSFX

 F  S ACHSTMP=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP)) Q:ACHSTMP=""  D

 .Q:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0))

 .S ACHSFX(ACHSTMP)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0)),U)

 ;ACHS*3.1*23 MOD END OF LOOP

 ;F ACHS=12:1:16 S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D I1

 F ACHS=12:1 Q:'$D(ACHSEOBR("E",ACHS))  S ACHSX=$P(ACHSEOBR("E",ACHS)," ") I ACHSX]"" D I1

 D I2,PCC

 K ACHSFX,ACHSTMP,ACHSFXF,ACHSFXI,ACHSICDO,ACHSICDN

I1 ; Check DX codes first

 S Y=$P($$ICDDX^ICDCODE(ACHSX),U,1,2)

 I Y<0 D ERR^ACHSEOB4 Q

 ;ACHS*3.1*22 MODS FOR ICD9 UPDATE

 I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,9)) S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,0),U,2)=$P($G(^DD(9002080.01,95,0)),U,2)

 ;REMOVE ICD NODES IN THE TEMP ARRAY THAT ARE IN THE FI FILE

 S ACHSTMP=0,ACHSFXF=0

 F  S ACHSTMP=$O(ACHSFX(ACHSTMP)) Q:ACHSTMP=""  D

 .I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0)),U)=+Y K ACHSFX(ACHSTMP) S ACHSFXF=1

 S:ACHSFXF=0 ACHSFXI(+Y)=Y  ;CODES FROM THE FI THAT WERE NOT FOUND WILL NEED TO BE ADDED

I2 ;

 ;REMAINING CODES THAT EITHER NEED TO BE UPDATED OR DELETED

 S ACHSTMP=0,ACHSFXF=0,ACHSDX=0

 F  S ACHSTMP=$O(ACHSFX(ACHSTMP)) Q:ACHSTMP=""  D

 .S ACHSICDO=ACHSFX(ACHSTMP)

 .S ACHSICDN=0

 .I $D(^ACHSICD9("B",ACHSICDO)) S ACHSICDN=$O(^ACHSICD9("B",ACHSICDO,ACHSICDN))

 .I $D(ACHSFXI(ACHSICDN)) D

 ..S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0),U)=ACHSICDN   ;NEW POINTER

 ..;ADD NEW ICD TO REF;DELETE OLD ICD

 ..S ACHSDX=ACHSTMP I $$DOC^ACHS(2,7) D REF

 ..K ACHSFX(ACHSTMP)

 ..I '$D(^ACHSICD(DUZ(2),"D",ACHSDIEN)) S ^ACHSICD(DUZ(2),"D",ACHSDIEN,0)=^ACHSF(DUZ(2),"D",ACHSDIEN,0)

 ..S $P(^ACHSICD(DUZ(2),"D",ACHSDIEN,9,ACHSTMP,0),U,3)=ACHSICDN

 ;ACHS*3.1*22 END OF CHANGES

ICNV ; Convert E and vee codes and place decimal.

 I $E(ACHSX,1)'="E" S ACHSX=$E(ACHSX,1,3)_"."_$E(ACHSX,4,5) Q

 S ACHSX=$E(ACHSX,1,4)_"."_$E(ACHSX,5)

 I $E(ACHSX,6)="" S ACHSX=$E(ACHSX,1,5) Q

ICNV1 ;

 S X="000",X=$E(X,1,3-$L(ACHSX)),ACHSX=X_ACHSX

REF ;

 ;IF REFERRAL PTR

 D DX1^ACHSBMC        ;TRANSFER DX INFO INTO RCIS

PCC ;

 ; Post CHS data to PCC

 S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))    ;DOCUMENT 0 NODE

 ;IF Data exists in the PCC visit pointer post to PCC

 I $$DOC^ACHS(2,5) U IO(0) D ^ACHSPAP U IO

ACHSEOB9.m