ACHSEOB1.m

ACHSEOB1 ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (2/6) - READ IN, PROCESS ; 15 Feb 2016  5:00 PM

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

 ;

 K ^TMP("ACHSEOB",$J)

 D NOW^ACHS

 S ACHSTIME=$$C^XBFUNC(ACHSTIME,80)

 ;ACHS*3.1*23 ADDED ACHSEDXT TO NXT LINE

 S (ACHSEDXT,ACHSTERR,ACHSZRC,ACHSCTR,ACHSEFL9)=0,(ACHSOLD,ACHSZFLC)=""

 ;

 D ^ACHSEOBM                ;BUILD CHS EOBR ERROR MESSAGE FILE

 ;

 I $D(ACHSAEND) S ACHSTERR=1 Q

MAIN ;

 U IO

 R ACHSEOBR:300   ;SAC-FILE READ

 ;I 'ACHSISAO H 1  ;ACHS*3.1*23

 U IO(0)

 I ACHSEOBR="" S ACHSTERR=1 W !,"Unexpected End Of File!  This file is incomplete." G TERR

 ;I ACHSISAO=1 S ACHSEOBR=$E(ACHSEOBR,3,85)  ;ACHS*3.1*21

 I ACHSISAO S ACHSEOBR=$S($$OS^ACHS=2:$E(ACHSEOBR,1,82),1:$E(ACHSEOBR,3,85))   ;ACHS*3.1*21

 ;

 ;GO PRINT THE PROPER REPORT AND UPDATE DOCUMENT DEPENDING ON PARM

 ;ACHS*3.1*22;IF ICD-9 FILE FIX GO TO ACHSEOB9

 ;I ACHSEOBR=""!($E(ACHSEOBR,1,2)="**") D M1^ACHSEOBB D END Q  ;RETURNS ACHSTERR

 I ACHSEOBR=""!($E(ACHSEOBR,1,2)="**") D @($S($P(ACHSMEDA,".",2)="ICD":"M1^ACHSEOB9",1:"M1^ACHSEOBB")) D END Q  ;RETURNS ACHSTERR

 I ACHSOLD="" S ACHSOLD=$E(ACHSEOBR,1,18)

 ;ACHS*3.1*22;IF ICD-9 FILE FIX GO TO ACHSEOB9

 ;I ACHSOLD'=$E(ACHSEOBR,1,18) D M1^ACHSEOBB Q:ACHSTERR   ;QUIT IF SEQ ERROR

 I ACHSOLD'=$E(ACHSEOBR,1,18) D @($S($P(ACHSMEDA,".",2)="ICD":"M1^ACHSEOB9",1:"M1^ACHSEOBB")) Q:ACHSTERR   ;QUIT IF SEQ ERROR

 ;

 ;

 D REC^ACHSEOBB ;BEGIN PROCESS OF RECORDS INTO LOCAL ARRAYS ACHSEOBR(A-I

 G TERR:ACHSTERR

 ;

 I ACHSZFLC=$E(ACHSEOBR,1,6) S ACHSZFLC=$E(ACHSEOBR,1,6) G WRITE

 ;

 S ACHSZZ=$E(ACHSEOBR,1,6)   ;ASUFAC CODE

 ;CHECK LOCATION ASUFAC INDEX X-REF FOR IEN

 S ACHSZFPT="",ACHSZFPT=$O(^AUTTLOC("C",ACHSZZ,ACHSZFPT)) ;GET AREA IEN

 ;

 ;

 ;IF CANT FIND AREA IEN IN ASUFAC INDEX TRY ASUFAC CODE X-REF

 I +ACHSZFPT=0 S ACHSZFPT="",ACHSZFPT=$O(^AUTTLOC("CTOO",ACHSZZ,""))

 ;

 S ACHSZ3=$E(ACHSEOBR,55,57) ;GET FINANCIAL LOCATION CODE

 ;CHECK FINANCIAL LOCATION CODE X-REF FOR LOCATION IEN

 S ACHSZPT3="",ACHSZPT3=$O(^AUTTLOC("FLC",ACHSZ3,ACHSZPT3))

 ;

 ;IF FINANCIAL LOCATION IEN >0 & FINANCIAL LOC. SAME AS DOC LOC. CONT

 I +ACHSZPT3>0,ACHSZFPT=ACHSZPT3 G CONT

 ;

 ;IF FINACIAL CODE DEFINED BUT NOT SAME AS DOC USE DOC. LOCATION

 I +ACHSZPT3>0 U IO(0) W !,"FACILITY CODE PROBLEM -- USING DOCUMENT LOCATION" S ACHSZFPT=ACHSZPT3 G CONT

 ;IF DOC LOC NOT FOUND TRY USING FIANANCIAL LOC CODE LAST DITCH TRY

 I 'ACHSZFPT S ACHSZFPT=$$FLC(ACHSZ3)

 ;

 ;IF STILL CANT FIND LOCATION QUIT THIS MUST BE FIXED 

 I +ACHSZFPT=0 U IO(0) D  D TERR Q

 .W *7,!!,"Invalid Facility Code ",$E(ACHSEOBR,1,6)," in EOBR Data."

 .W !,"File ",$P(ACHSUFLS(+Y)," ")," contains a facility code that"

 .W !,"cannot be found on the system -- JOB CANCELLED" S ACHSTERR=20

CONT ;

 ;GET INSTITUTION NAME

 S ACHSZFNM=$P($G(^DIC(4,ACHSZFPT,0),"UNDEFINED"),U)

 ;

 U IO(0)

 W !!?10,"Processing EOBR Data for: ",ACHSZFNM,!!

 ;

 S ACHSZFLC=$E(ACHSEOBR,1,6)   ;RESET TO FACILITY ASUFAC

 ;

WRITE ;

 S ACHSCTR=ACHSCTR+1   ;INCREMENT COUNTER

 ;

 S ^ACHSEOBR(ACHSZFPT,ACHSCTR)=ACHSEOBR

 ;

 ;IF RECORD IS TYPE "H" SUMMARY RECORD

 ;DO SUMM IF PRINT EOBR'S PARAMETER IS Y OR PRINT SUMM OPTION USED AND

 ;PRINT CANCEL DOCUMENTS IS Y

 I $E(ACHSEOBR,19)="H" D SUMM:$S(ACHSISAO:$$AOP^ACHS(2,6)="Y",1:$$PARM^ACHS(2,14)="Y")

 ;ALL RECORD TYPES BUT "A" GO GET ANOTHER RECORD OTHERWISE KEEP COUNT

 I $E(ACHSEOBR,19)'="A" G MAIN

 ;

 ;KEEP COUNT OF FACILITIES,TOTAL RECORD COUNT, AND WRITE USER FEEDBACK

 S:'$D(ACHSZFCT(ACHSZFPT)) ACHSZFCT(ACHSZFPT)=0

 S ACHSZFCT(ACHSZFPT)=ACHSZFCT(ACHSZFPT)+1

 S ACHSCTR(1)=ACHSCTR

 S ACHSZRC=ACHSZRC+1

 I ACHSZRC#10=0 U IO(0) W $J(ACHSZRC,8)

 F X="B","C","D","E","F","G","I","J" K ACHSEOBR(X)  ;ACHS*3.1*23

 G MAIN

 ;

GBLD ;EP - Build ACHSEOBR("M") MESSAGE ARRAY from "F" records.

 S:'$D(ACHSEOBR("M","ACHSMSEQ")) ACHSEOBR("M","ACHSMSEQ")=0

 S ACHSMSG=""

 ;

 S:$D(ACHSEOBR("F",14)) ACHSMSG=ACHSEOBR("F",14) ;GET MESSAGE

 Q:ACHSMSG=""!("RM"'[$E(ACHSMSG,1,1))          ;??????

 S ACHSMSEQ=ACHSEOBR("M","ACHSMSEQ")+1  ;CAN WE COMBINE THIS AND NEXT LINE????

 S ACHSEOBR("M","ACHSMSEQ")=ACHSMSEQ

 S:'$D(ACHSEOBR("M","B",ACHSMSG)) ACHSEOBR("M",ACHSMSEQ)=ACHSMSG,ACHSEOBR("M","B",ACHSMSG)=""

 Q

 ;

SIGN ;EP - Extract the Sign of the field from the last character in

 ;     the field.

 ;S Y=$E(ACHSEOBR,$P(X,".",3))

 S Y=$E(ACHSREC,$P(X,".",3))

 I "}JKLMNOPQR"[Y S ACHSREC=$E(ACHSREC,1,$P(X,".",2)-1)_"-"_$E(ACHSREC,$P(X,".",2)+1,$P(X,".",3)-1)_$S(Y="}":0,1:$C($A(Y)-25))_$E(ACHSREC,$P(X,".",3)+1,80) Q

 I "{ABCDEFGHI"[Y S ACHSREC=$E(ACHSREC,1,$P(X,".",3)-1)_$S(Y="{":0,1:$C($A(Y)-16))_$E(ACHSREC,$P(X,".",3)+1,80)

 Q

 ;

SUMM ;THIS IS THE SUMMARY

 D REC1^ACHSEOBB

 I ACHSEOIO'=IO S IOP=ACHSEOIO D ^%ZIS   ;ACHS*3.1*21

 U ACHSEOIO

 W @IOF,!!?24,"--- SUMMARY OF EOBR PROCESSED ---",!!,$$C^XBFUNC(ACHSTIME,80),!!!

 ;

 W ?5,"INDIAN HEALTH SERVICE",?40,"CONTRACT HEALTH SERVICES",!!,"AO: ",$S($G(ACHSEOBR("H",1))'="":$P(^AUTTAREA($O(^AUTTAREA("C",ACHSEOBR("H",1),0)),0),U),1:"UNDEFINED")

 ;

 W !!,"SU: "

 I $G(ACHSEOBR("H",1))'="",($G(ACHSEOBR("H",2))'="") W $P(^AUTTSU($O(^AUTTSU("C",ACHSEOBR("H",1)_ACHSEOBR("H",2),0)),0),U)

 E  W "INCOMPLETE INFORMATION TO FIND SERVICE UNIT"

 ;

 W !!!?23,"FISCAL YEAR:  ",$G(ACHSEOBR("H",4))

 ;

 W !!!!!?15,"AUTHORIZING FACILITY:  "

 I $G(ACHSEOBR("H",8))'="" D

 .S Y=$O(^AUTTLOC("C",ACHSEOBR("H",8)))

 .I 'Y W "UNDEFINED" Q

 .S Y=$P($G(^AUTTLOC(Y,0)),U,2)

 .W $G(Y,"UNDEFINED"),!!

 ;

 W ?20,"PERIOD COVER(S):  "

 I +$G(ACHSEOBR("H",9)) D

 .W $$FMTE^XLFDT($S(+$E(ACHSEOBR("H",9),1,2)>50:2,1:3)_"000000"+ACHSEOBR("H",9))

 ;

 I +$G(ACHSEOBR("H",10)) W !?38,$$FMTE^XLFDT($S(+$E(ACHSEOBR("H",10),1,2)>50:2,1:3)_"000000"+ACHSEOBR("H",10))

 ;

 W !!?21,"TYPE 43 CLAIMS:",$J(+$G(ACHSEOBR("H",11)),13),!!?21,"TYPE 57 CLAIMS:",$J(+$G(ACHSEOBR("H",12)),13),!!?21,"TYPE 64 CLAIMS:",$J(+$G(ACHSEOBR("H",13)),13)

 ;

 W !!?18,"TOTAL OF PAYMENTS: $"

 S X=$E($G(ACHSEOBR("H",14)),1,8)_"."_$E($G(ACHSEOBR("H",14)),9,10)

 K X1,X2

 D COMMA^%DTC

 W X,!!," NET ADJ. OF PAYMENT VS. OBLIGATION: $"

 S X=$E($G(ACHSEOBR("H",15)),1,8)_"."_$E($G(ACHSEOBR("H",15)),9,10)

 D COMMA^%DTC

 W X,@IOF

 D HOME^%ZIS   ;ACHS*3.1*21

 Q

 ;

END ;

 I $G(ACHSZRC)>0 U IO(0) W !!,"Total EOBR Records Processed = ",ACHSZRC,!!

KYL ; Close device, kill vars, quit.

 I (IO(0)'=IO)!($D(IO("S"))) D ^%ZISC

 I $D(ACHSEOIO),ACHSEOIO'=IO S IO=ACHSEOIO D ^%ZISC

 D CLOSEALL^ACHS

 K ACHSEOBR,ACHSEOIO,ACHSERRA,ACHSOLD,ACHSTIME,ACHSX

 Q

 ;

ERR ;

 U IO(0)

 W *7,*7,!!,"AN ERROR HAS BEEN DETECTED IN THE",!,"FINANCE PARAMETERS OR DATA GLOBAL STRUCTURE.",!!,"PLEASE CONTACT YOUR SITEMANAGER FOR ASSISTANCE",!!

 S X=$$DIR^XBDIR("E","Press <RETURN> To Continue....")

 D KYL

 Q

 ;

TERR ;

 U IO(0)

 W *7,!!,"EOBR PROCESSING ERROR.",!!,"Notify your supervisor.",!

 I $G(ACHSTERR)=5 W !,"PROBLEM HINT AT NODE ^ACHSEOBR(""SEQ-ERROR"")=",$G(ACHSEOBR)," POSSIBLE CHAR 19 IN RECORD IMPROPER"

 I $G(ACHSTERR)=10 W !,"IMPROPER RECORD TYPE - ",$E(ACHSEOBR,19)

 I $G(ACHSTERR)=20 W !,"INVALID FACILITY CODE - ",$E(ACHSEOBR,1,6)

 ;

 ;

 S X=$$DIR^XBDIR("E","Press <RETURN> To Continue....")

 D END

 Q

 ;

END1 ;EP.

 U IO(0)

 W !!,"No CHS EOBR Data Processed"

 S X=$$DIR^XBDIR("E","Press <RETURN> To Continue....")

 D KYL

 Q

 ;

FLC(ACHSZ3) ;

 ; Attempt to find Location based on FLC of EOBR.

 ; The ASUFAC code for any given facility may have changed since

 ;  the document left the facility, and the EOBR created.

 ; Assume the ^AUTTLOC("FLC" x-ref has a bug, if you get this far,

 ;  (that's why you got this far) and use the ^AUTTLOC("FL" x-ref

 ;  and the single-character code from the AREA file.

 ; Once the "FLC" x-ref is corrected, this code not needed.

 ;

 N X,Y

 S (X,Y)=0

 F  S X=$O(^AUTTLOC("FL",X)) Q:'$L(X)!Y  S Y=0 F  S Y=$O(^AUTTLOC("FL",X,Y)) Q:'Y  I Y,$P(^AUTTAREA($P(^AUTTLOC(Y,0),U,4),0),U,3)_$E(X,2,3)=ACHSZ3 Q

 Q Y

 ;

ACHSEOB1  ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (2/6) - READ IN, PROCESS ; 15 Feb 2016  5:00 PM

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

 +2       ;

 +3        KILL ^TMP("ACHSEOB",$JOB)

 +4        DO NOW^ACHS

 +5        SET ACHSTIME=$$C^XBFUNC(ACHSTIME,80)

 +6       ;ACHS*3.1*23 ADDED ACHSEDXT TO NXT LINE

 +7        SET (ACHSEDXT,ACHSTERR,ACHSZRC,ACHSCTR,ACHSEFL9)=0

           SET (ACHSOLD,ACHSZFLC)=""

 +8       ;

 +9       ;BUILD CHS EOBR ERROR MESSAGE FILE

           DO ^ACHSEOBM

 +10      ;

 +11       IF $DATA(ACHSAEND)

               SET ACHSTERR=1

               QUIT 

MAIN      ;

 +1        USE IO

 +2       ;SAC-FILE READ

           READ ACHSEOBR:300

 +3       ;I 'ACHSISAO H 1  ;ACHS*3.1*23

 +4        USE IO(0)

 +5        IF ACHSEOBR=""

               SET ACHSTERR=1

               WRITE !,"Unexpected End Of File!  This file is incomplete."

               GOTO TERR

 +6       ;I ACHSISAO=1 S ACHSEOBR=$E(ACHSEOBR,3,85)  ;ACHS*3.1*21

 +7       ;ACHS*3.1*21

           IF ACHSISAO

               SET ACHSEOBR=$SELECT($$OS^ACHS=2:$E(ACHSEOBR,1,82),1:$EXTRACT(ACHSEOBR,3,85))

 +8       ;

 +9       ;GO PRINT THE PROPER REPORT AND UPDATE DOCUMENT DEPENDING ON PARM

 +10      ;ACHS*3.1*22;IF ICD-9 FILE FIX GO TO ACHSEOB9

 +11      ;I ACHSEOBR=""!($E(ACHSEOBR,1,2)="**") D M1^ACHSEOBB D END Q  ;RETURNS ACHSTERR

 +12      ;RETURNS ACHSTERR

           IF ACHSEOBR=""!($EXTRACT(ACHSEOBR,1,2)="**")

               DO @($SELECT($PIECE(ACHSMEDA,".",2)="ICD":"M1^ACHSEOB9",1:"M1^ACHSEOBB"))

               DO END

               QUIT 

 +13       IF ACHSOLD=""

               SET ACHSOLD=$EXTRACT(ACHSEOBR,1,18)

 +14      ;ACHS*3.1*22;IF ICD-9 FILE FIX GO TO ACHSEOB9

 +15      ;I ACHSOLD'=$E(ACHSEOBR,1,18) D M1^ACHSEOBB Q:ACHSTERR   ;QUIT IF SEQ ERROR

 +16      ;QUIT IF SEQ ERROR

           IF ACHSOLD'=$EXTRACT(ACHSEOBR,1,18)

               DO @($SELECT($PIECE(ACHSMEDA,".",2)="ICD":"M1^ACHSEOB9",1:"M1^ACHSEOBB"))

               IF ACHSTERR

                   QUIT 

 +17      ;

 +18      ;

 +19      ;BEGIN PROCESS OF RECORDS INTO LOCAL ARRAYS ACHSEOBR(A-I

           DO REC^ACHSEOBB

 +20       IF ACHSTERR

               GOTO TERR

 +21      ;

 +22       IF ACHSZFLC=$EXTRACT(ACHSEOBR,1,6)

               SET ACHSZFLC=$EXTRACT(ACHSEOBR,1,6)

               GOTO WRITE

 +23      ;

 +24      ;ASUFAC CODE

           SET ACHSZZ=$EXTRACT(ACHSEOBR,1,6)

 +25      ;CHECK LOCATION ASUFAC INDEX X-REF FOR IEN

 +26      ;GET AREA IEN

           SET ACHSZFPT=""

           SET ACHSZFPT=$ORDER(^AUTTLOC("C",ACHSZZ,ACHSZFPT))

 +27      ;

 +28      ;

 +29      ;IF CANT FIND AREA IEN IN ASUFAC INDEX TRY ASUFAC CODE X-REF

 +30       IF +ACHSZFPT=0

               SET ACHSZFPT=""

               SET ACHSZFPT=$ORDER(^AUTTLOC("CTOO",ACHSZZ,""))

 +31      ;

 +32      ;GET FINANCIAL LOCATION CODE

           SET ACHSZ3=$EXTRACT(ACHSEOBR,55,57)

 +33      ;CHECK FINANCIAL LOCATION CODE X-REF FOR LOCATION IEN

 +34       SET ACHSZPT3=""

           SET ACHSZPT3=$ORDER(^AUTTLOC("FLC",ACHSZ3,ACHSZPT3))

 +35      ;

 +36      ;IF FINANCIAL LOCATION IEN >0 & FINANCIAL LOC. SAME AS DOC LOC. CONT

 +37       IF +ACHSZPT3>0

               IF ACHSZFPT=ACHSZPT3

                   GOTO CONT

 +38      ;

 +39      ;IF FINACIAL CODE DEFINED BUT NOT SAME AS DOC USE DOC. LOCATION

 +40       IF +ACHSZPT3>0

               USE IO(0)

               WRITE !,"FACILITY CODE PROBLEM -- USING DOCUMENT LOCATION"

               SET ACHSZFPT=ACHSZPT3

               GOTO CONT

 +41      ;IF DOC LOC NOT FOUND TRY USING FIANANCIAL LOC CODE LAST DITCH TRY

 +42       IF 'ACHSZFPT

               SET ACHSZFPT=$$FLC(ACHSZ3)

 +43      ;

 +44      ;IF STILL CANT FIND LOCATION QUIT THIS MUST BE FIXED 

 +45       IF +ACHSZFPT=0

               USE IO(0)

               Begin DoDot:1

 +46               WRITE *7,!!,"Invalid Facility Code ",$EXTRACT(ACHSEOBR,1,6)," in EOBR Data."

 +47               WRITE !,"File ",$PIECE(ACHSUFLS(+Y)," ")," contains a facility code that"

 +48               WRITE !,"cannot be found on the system -- JOB CANCELLED"

                   SET ACHSTERR=20

               End DoDot:1

               DO TERR

               QUIT 

CONT      ;

 +1       ;GET INSTITUTION NAME

 +2        SET ACHSZFNM=$PIECE($GET(^DIC(4,ACHSZFPT,0),"UNDEFINED"),U)

 +3       ;

 +4        USE IO(0)

 +5        WRITE !!?10,"Processing EOBR Data for: ",ACHSZFNM,!!

 +6       ;

 +7       ;RESET TO FACILITY ASUFAC

           SET ACHSZFLC=$EXTRACT(ACHSEOBR,1,6)

 +8       ;

WRITE     ;

 +1       ;INCREMENT COUNTER

           SET ACHSCTR=ACHSCTR+1

 +2       ;

 +3        SET ^ACHSEOBR(ACHSZFPT,ACHSCTR)=ACHSEOBR

 +4       ;

 +5       ;IF RECORD IS TYPE "H" SUMMARY RECORD

 +6       ;DO SUMM IF PRINT EOBR'S PARAMETER IS Y OR PRINT SUMM OPTION USED AND

 +7       ;PRINT CANCEL DOCUMENTS IS Y

 +8        IF $EXTRACT(ACHSEOBR,19)="H"

               IF $SELECT(ACHSISAO:$$AOP^ACHS(2,6)="Y",1:$$PARM^ACHS(2,14)="Y")

                   DO SUMM

 +9       ;ALL RECORD TYPES BUT "A" GO GET ANOTHER RECORD OTHERWISE KEEP COUNT

 +10       IF $EXTRACT(ACHSEOBR,19)'="A"

               GOTO MAIN

 +11      ;

 +12      ;KEEP COUNT OF FACILITIES,TOTAL RECORD COUNT, AND WRITE USER FEEDBACK

 +13       IF '$DATA(ACHSZFCT(ACHSZFPT))

               SET ACHSZFCT(ACHSZFPT)=0

 +14       SET ACHSZFCT(ACHSZFPT)=ACHSZFCT(ACHSZFPT)+1

 +15       SET ACHSCTR(1)=ACHSCTR

 +16       SET ACHSZRC=ACHSZRC+1

 +17       IF ACHSZRC#10=0

               USE IO(0)

               WRITE $JUSTIFY(ACHSZRC,8)

 +18      ;ACHS*3.1*23

           FOR X="B","C","D","E","F","G","I","J"

               KILL ACHSEOBR(X)

 +19       GOTO MAIN

 +20      ;

GBLD      ;EP - Build ACHSEOBR("M") MESSAGE ARRAY from "F" records.

 +1        IF '$DATA(ACHSEOBR("M","ACHSMSEQ"))

               SET ACHSEOBR("M","ACHSMSEQ")=0

 +2        SET ACHSMSG=""

 +3       ;

 +4       ;GET MESSAGE

           IF $DATA(ACHSEOBR("F",14))

               SET ACHSMSG=ACHSEOBR("F",14)

 +5       ;??????

           IF ACHSMSG=""!("RM"'[$EXTRACT(ACHSMSG,1,1))

               QUIT 

 +6       ;CAN WE COMBINE THIS AND NEXT LINE????

           SET ACHSMSEQ=ACHSEOBR("M","ACHSMSEQ")+1

 +7        SET ACHSEOBR("M","ACHSMSEQ")=ACHSMSEQ

 +8        IF '$DATA(ACHSEOBR("M","B",ACHSMSG))

               SET ACHSEOBR("M",ACHSMSEQ)=ACHSMSG

               SET ACHSEOBR("M","B",ACHSMSG)=""

 +9        QUIT 

 +10      ;

SIGN      ;EP - Extract the Sign of the field from the last character in

 +1       ;     the field.

 +2       ;S Y=$E(ACHSEOBR,$P(X,".",3))

 +3        SET Y=$EXTRACT(ACHSREC,$PIECE(X,".",3))

 +4        IF "}JKLMNOPQR"[Y

               SET ACHSREC=$EXTRACT(ACHSREC,1,$PIECE(X,".",2)-1)_"-"_$EXTRACT(ACHSREC,$PIECE(X,".",2)+1,$PIECE(X,".",3)-1)_$SELECT(Y="}":0,1:$CHAR($ASCII(Y)-25))_$EXTRACT(ACHSREC,$PIECE(X,".",3)+1,80)

               QUIT 

 +5        IF "{ABCDEFGHI"[Y

               SET ACHSREC=$EXTRACT(ACHSREC,1,$PIECE(X,".",3)-1)_$SELECT(Y="{":0,1:$CHAR($ASCII(Y)-16))_$EXTRACT(ACHSREC,$PIECE(X,".",3)+1,80)

 +6        QUIT 

 +7       ;

SUMM      ;THIS IS THE SUMMARY

 +1        DO REC1^ACHSEOBB

 +2       ;ACHS*3.1*21

           IF ACHSEOIO'=IO

               SET IOP=ACHSEOIO

               DO ^%ZIS

 +3        USE ACHSEOIO

 +4        WRITE @IOF,!!?24,"--- SUMMARY OF EOBR PROCESSED ---",!!,$$C^XBFUNC(ACHSTIME,80),!!!

 +5       ;

 +6        WRITE ?5,"INDIAN HEALTH SERVICE",?40,"CONTRACT HEALTH SERVICES",!!,"AO: ",$SELECT($GET(ACHSEOBR("H",1))'="":$PIECE(^AUTTAREA($ORDER(^AUTTAREA("C",ACHSEOBR("H",1),0)),0),U),1:"UNDEFINED")

 +7       ;

 +8        WRITE !!,"SU: "

 +9        IF $GET(ACHSEOBR("H",1))'=""

               IF ($GET(ACHSEOBR("H",2))'="")

                   WRITE $PIECE(^AUTTSU($ORDER(^AUTTSU("C",ACHSEOBR("H",1)_ACHSEOBR("H",2),0)),0),U)

 +10      IF '$TEST

               WRITE "INCOMPLETE INFORMATION TO FIND SERVICE UNIT"

 +11      ;

 +12       WRITE !!!?23,"FISCAL YEAR:  ",$GET(ACHSEOBR("H",4))

 +13      ;

 +14       WRITE !!!!!?15,"AUTHORIZING FACILITY:  "

 +15       IF $GET(ACHSEOBR("H",8))'=""

               Begin DoDot:1

 +16               SET Y=$ORDER(^AUTTLOC("C",ACHSEOBR("H",8)))

 +17               IF 'Y

                       WRITE "UNDEFINED"

                       QUIT 

 +18               SET Y=$PIECE($GET(^AUTTLOC(Y,0)),U,2)

 +19               WRITE $GET(Y,"UNDEFINED"),!!

               End DoDot:1

 +20      ;

 +21       WRITE ?20,"PERIOD COVER(S):  "

 +22       IF +$GET(ACHSEOBR("H",9))

               Begin DoDot:1

 +23               WRITE $$FMTE^XLFDT($SELECT(+$EXTRACT(ACHSEOBR("H",9),1,2)>50:2,1:3)_"000000"+ACHSEOBR("H",9))

               End DoDot:1

 +24      ;

 +25       IF +$GET(ACHSEOBR("H",10))

               WRITE !?38,$$FMTE^XLFDT($SELECT(+$EXTRACT(ACHSEOBR("H",10),1,2)>50:2,1:3)_"000000"+ACHSEOBR("H",10))

 +26      ;

 +27       WRITE !!?21,"TYPE 43 CLAIMS:",$JUSTIFY(+$GET(ACHSEOBR("H",11)),13),!!?21,"TYPE 57 CLAIMS:",$JUSTIFY(+$GET(ACHSEOBR("H",12)),13),!!?21,"TYPE 64 CLAIMS:",$JUSTIFY(+$GET(ACHSEOBR("H",13)),13)

 +28      ;

 +29       WRITE !!?18,"TOTAL OF PAYMENTS: $"

 +30       SET X=$EXTRACT($GET(ACHSEOBR("H",14)),1,8)_"."_$EXTRACT($GET(ACHSEOBR("H",14)),9,10)

 +31       KILL X1,X2

 +32       DO COMMA^%DTC

 +33       WRITE X,!!," NET ADJ. OF PAYMENT VS. OBLIGATION: $"

 +34       SET X=$EXTRACT($GET(ACHSEOBR("H",15)),1,8)_"."_$EXTRACT($GET(ACHSEOBR("H",15)),9,10)

 +35       DO COMMA^%DTC

 +36       WRITE X,@IOF

 +37      ;ACHS*3.1*21

           DO HOME^%ZIS

 +38       QUIT 

 +39      ;

END       ;

 +1        IF $GET(ACHSZRC)>0

               USE IO(0)

               WRITE !!,"Total EOBR Records Processed = ",ACHSZRC,!!

KYL       ; Close device, kill vars, quit.

 +1        IF (IO(0)'=IO)!($DATA(IO("S")))

               DO ^%ZISC

 +2        IF $DATA(ACHSEOIO)

               IF ACHSEOIO'=IO

                   SET IO=ACHSEOIO

                   DO ^%ZISC

 +3        DO CLOSEALL^ACHS

 +4        KILL ACHSEOBR,ACHSEOIO,ACHSERRA,ACHSOLD,ACHSTIME,ACHSX

 +5        QUIT 

 +6       ;

ERR       ;

 +1        USE IO(0)

 +2        WRITE *7,*7,!!,"AN ERROR HAS BEEN DETECTED IN THE",!,"FINANCE PARAMETERS OR DATA GLOBAL STRUCTURE.",!!,"PLEASE CONTACT YOUR SITEMANAGER FOR ASSISTANCE",!!

 +3        SET X=$$DIR^XBDIR("E","Press <RETURN> To Continue....")

 +4        DO KYL

 +5        QUIT 

 +6       ;

TERR      ;

 +1        USE IO(0)

 +2        WRITE *7,!!,"EOBR PROCESSING ERROR.",!!,"Notify your supervisor.",!

 +3        IF $GET(ACHSTERR)=5

               WRITE !,"PROBLEM HINT AT NODE ^ACHSEOBR(""SEQ-ERROR"")=",$GET(ACHSEOBR)," POSSIBLE CHAR 19 IN RECORD IMPROPER"

 +4        IF $GET(ACHSTERR)=10

               WRITE !,"IMPROPER RECORD TYPE - ",$EXTRACT(ACHSEOBR,19)

 +5        IF $GET(ACHSTERR)=20

               WRITE !,"INVALID FACILITY CODE - ",$EXTRACT(ACHSEOBR,1,6)

 +6       ;

 +7       ;

 +8        SET X=$$DIR^XBDIR("E","Press <RETURN> To Continue....")

 +9        DO END

 +10       QUIT 

 +11      ;

END1      ;EP.

 +1        USE IO(0)

 +2        WRITE !!,"No CHS EOBR Data Processed"

 +3        SET X=$$DIR^XBDIR("E","Press <RETURN> To Continue....")

 +4        DO KYL

 +5        QUIT 

 +6       ;

FLC(ACHSZ3) ;

 +1       ; Attempt to find Location based on FLC of EOBR.

 +2       ; The ASUFAC code for any given facility may have changed since

 +3       ;  the document left the facility, and the EOBR created.

 +4       ; Assume the ^AUTTLOC("FLC" x-ref has a bug, if you get this far,

 +5       ;  (that's why you got this far) and use the ^AUTTLOC("FL" x-ref

 +6       ;  and the single-character code from the AREA file.

 +7       ; Once the "FLC" x-ref is corrected, this code not needed.

 +8       ;

 +9        NEW X,Y

 +10       SET (X,Y)=0

 +11       FOR 

               SET X=$ORDER(^AUTTLOC("FL",X))

               IF '$LENGTH(X)!Y

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(^AUTTLOC("FL",X,Y))

                   IF 'Y

                       QUIT 

                   IF Y

                       IF $PIECE(^AUTTAREA($PIECE(^AUTTLOC(Y,0),U,4),0),U,3)_$EXTRACT(X,2,3)=ACHSZ3

                           QUIT 

 +12       QUIT Y

 +13      ;