ACHSEOBA.m

ACHSEOBA ; IHS/ITSC/TPF/PMF - SET ARRAY VARIABLES A THRU E FROM DOCUMENT FOR EOBR PRNTING ; JUL 10, 2008   

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,23,24**;JUN 11,2001;Build 43

 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES

 ;3.1*15 1.22.2009 IHS/OIT/FCJ CSV CHANGES PRINTED INVALID CODES

 ;

 ;

 S ACHSDOC=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0),"NO DOC 0 RECORD")

 S ACHSDOC3=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,3),"NO DOC 3 RECORD")

 S ACHSTRAN=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),"NO TRAN 0 RECORD")

 S ACHSFAC0=$G(^ACHSF(DUZ(2),0),"NO CHS FACILITY 0 RECORD")

 I $P(ACHSFAC0,U)'="" S ACHSLOC=$P(^AUTTLOC($P(ACHSFAC0,U),0),U,10) ;ASUFAC INDEX

 E  S ACHSLOC="UNDEFINED"

 K ^TMP("ACHSEOB",$J)

 ;

 ;THE A ARRAY

 ;A HEADING RECORD

A ;

 F %=1:1:15 S ACHSEOBR("A",%)=""         ;INITIALIZE ARRAY

 S ACHSEOBR("A",1)=$E(ACHSLOC,1,2)       ;AREA CODE

 S ACHSEOBR("A",2)=$E(ACHSLOC,3,4)       ;SERVICE UNIT CODE

 S ACHSEOBR("A",3)=$E(ACHSLOC,5,6)       ;FACILITY (CODE) NUMBER

 S ACHSEOBR("A",4)="0"_$P(ACHSDOC,U,14)           ;FISCAL YEAR

 S ACHSEOBR("A",5)=$E($P(ACHSTRAN,U,17),8,17)     ;EOBR CONTROL NUMBER

                                                  ; PATTERN 7A-9N

                                                  ;FI GENERATED   

 S ACHSEOBR("A",6)="A"                            ;RECORD TYPE

 ;S ACHEOBR("A",7)                                ;SEQ NUM ALWAYS 001?

 S ACHSEOBR("A",8)=$P(ACHSTRAN,U,14)              ;EOBR CLAIM SEQ. NO.

 S ACHSEOBR("A",9)=$P(ACHSTRAN,U,18)              ;CHECK #

 S ACHSEOBR("A",10)=$P(ACHSTRAN,U,19)             ;EOBR REMITT. #

 ;

 ; change line.  store date as yyyymmdd.  050101  pmf   S ACHSEOBR("A",11)=$P(ACHSTRAN,U,13)

 S ACHSEOBR("A",11)=$P(ACHSTRAN,U,13)+17000000    ;EOBR DATE

 ; remove line.  05/01/01   pmf   S ACHSEOBR("A",11)=$E(ACHSEOBR("A",11),2,7)

 ;

 ;

 ;BELOW IS PURCHASE ORDER # ; FISCAL YEAR-FACILITY?-ORDER NUMBER

 S ACHSEOBR("A",12)=$P(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC,U)

 S ACHSEOBR("A",13)=$E($P(ACHSTRAN,U,17),1,7) ;FIRST 7 OF CONTROL #

 ;

 ;BELOW IS FACILITY CODE     AREA CODE-SERVICE UNIT CODE-FACILITY CODE

 S ACHSEOBR("A",14)=ACHSEOBR("A",1)_ACHSEOBR("A",2)_ACHSEOBR("A",3)

 S ACHSEOBR("A",15)=$P(ACHSDOC,U,4)           ;TYPE OF SERV. (DOC. TYPE)

 S ACHSEOBR("A",15)=$S(ACHSEOBR("A",15)=1:43,ACHSEOBR("A",15)=2:57,ACHSEOBR("A",15)=3:64)     ;

 ;

 ;THE B ARRAY

 ;B HEADING RECORD

B ;

 F %=8:1:14 S ACHSEOBR("B",%)=""      ;INITIALIZE ARRAY

 S %=$P(ACHSDOC,U,22)                      ;GET PATIENT PTR

 I % S ACHSEOBR("B",8)=$P($G(^DPT(%,0)),U) ;GET PATIENT NAME

 E  S ACHSEOBR("B",8)=$S($P(ACHSDOC,U,3)=1:"* BLANKET",$P(ACHSDOC,U,3)=2:"* SPECIAL TRANS",1:"")

 S ACHSEOBR("B",9)=$P(ACHSDOC,U,21)          ;HRN HEALTH REC #

 S ACHSEOBR("B",10)=17000000+$P(ACHSDOC,U,2) ;AUTH DATE CCYYMMDD

 S ACHSEOBR("B",11)=$P(ACHSTRAN,U,9)         ;WORKLOAD  (ACTUAL DAYS)

 ;

 S %=$$DOC^ACHS(8,1)                         ;GET DRG PTR

 I % S %="00"_%,ACHSEOBR("B",12)=$E(%,$L(%)-2,$L(%))

 S %=$$DOC^ACHS(8,4)                         ;GET DISCHARGE TYPE

 I % S ACHSEOBR("B",13)=$P($G(^DIC(42.2,%,9999999)),U) ;IHS CODE(FILLER)

 ;BELOW IS: USE OBJECT CLASSIFICATION PTR, GET OBJ CLASS CODE 

 I $P(ACHSDOC,U,7) S ACHSEOBR("B",14)=$P($G(^ACHS(3,DUZ(2),1,$P(ACHSDOC,U,7),0)),U)

 E  S ACHSEOBR("B",14)=""

 ;

 ;THE C ARRAY

 ;C HEADING RECORD

C ;

 F %=8:1:16 S ACHSEOBR("C",%)=""       ;INITIALIZE ARRAY

 I $P(ACHSDOC,U,6) S ACHSEOBR("C",8)=$P(^ACHS(2,$P(ACHSDOC,U,6),0),U)    ;CAN PTR TO CAN 

 E  S ACHSEOBR("C",8)="XXXXXXXXXXXXXXXX"

 ;S ACHSEOBR("C",9)=$P($G(^ACHSOCC($P(ACHSDOC,U,10),0)),U)  ;VENDOR CHARGE EST TO GET OBJECT CLASS CODE???????

 ;GET OBJECT CLASS PTR THEN OBJECT CLASS CODE

 I $P(ACHSDOC,U,7) S ACHSEOBR("C",9)=$P($G(^ACHSOCC($P(ACHSDOC,U,7),0)),U)

 E  S ACHSEOBR("C",9)="UNKN"

 S ACHSEOBR("C",10)=$P(ACHSTRAN,U,20)   ;EOBR SERVICES BILLED  

 S ACHSEOBR("C",11)=$P(ACHSDOC,U,3)     ;BLANKET ORDER (INDICATOR)

 S ACHSEOBR("C",11)=$S(ACHSEOBR("C",11)=1:"Y",ACHSEOBR("C",11)=0:"N",1:"")

 S ACHSEOBR("C",12)="OM"                ;(CONTRACT NUMBER) ?????

 ;

 ;IF CON. PTR AND VEND. PTR GET CON. # FROM VEND. CONTRACT FILE 

 S ACHSVEND=$P(ACHSDOC,U,8)

 I $P(ACHSDOC,U,5),ACHSVEND S ACHSEOBR("C",12)=$P(^AUTTVNDR($P(ACHSDOC,U,8),"CN",$P(ACHSDOC,U,5),0),U)

 E  S ACHSEOBR("C",12)="OM"

 ;

 ;

 ;

 S ACHSEOBR("C",13)=$P(ACHSTRAN,U,15)  ;EOBR PAY TYPE (INTERM/FINAL IND)

 ;

 S ACHSEOBR("C",14)=17000000+$P(ACHSDOC3,U)   ;AUTH BEGIN DATE (SERV START DATE

 S ACHSEOBR("C",15)=17000000+$P(ACHSDOC3,U,2) ;AUTH ENDING DATE (SERV END DATE)

 ;

 ;GET VENDOR PTR

 I ACHSVEND D

 .I $D(^AUTTVNDR(ACHSVEND,11)) D

 ..S ACHSEOBR("C",16)=$P(^AUTTVNDR(ACHSVEND,11),U)    ;'EIN NO.'

 ..;BELOW GET EIN SUFFIX AND SLAP IT ON END OF EIN NO

 ..I $P(^AUTTVNDR(ACHSVEND,11),U,2)'="" S ACHSEOBR("C",16)=ACHSEOBR("C",16)_"-"_$P(^AUTTVNDR(ACHSVEND,11),U,2)     ;

 ;

 ;D ARRAY

 ;D HEADING RECORD

 ;

D ;

 F %=8:1:11 S ACHSEOBR("D",%)=""    ;INIT ARRAY

 S ACHSEOBR("D",8)=$P($G(^AUTTVNDR(ACHSVEND,0)),U)  ;VENDOR NAME

 S ACHSEOBR("D",11)=$P(ACHSTRAN,U,8)                ;THIRD PART. PAY AMT

 S ACHSEOBR("D",9)=0                                ;BILLED BY PROV.

 S ACHSEOBR("D",10)=0                               ;ALLOWABLE AMT

 ;

 ;BELOW FORMATS OUT THE DECIMAL FOR MAINFRAME PROGRAM

 I ACHSEOBR("D",11)["." S %=ACHSEOBR("D",11),%=$P(%,".")_$E($P(%,".",2)_"00",1,2),ACHSEOBR("D",11)=%

 E  S ACHSEOBR("D",11)=ACHSEOBR("D",11)_"00"

 ;

I ; Interest info.

 S DA(2)=DUZ(2),DA(1)=ACHSDIEN,DA=ACHSTIEN

 ;BELOW SETS UP I ARRAY FROM 8 TO 14

 ;BY GETTING THE VALUES IN FIELDS 22- 28 FROM THE TRANSACTION SUBFILE OF

 ;THE CHS FACILITY  CAN WE SIMPLIFY THIS?????

 ;ACHSEOBR("I",8)=INTEREST CAN

 ;             9)=INTEREST OBJECT CLASS CODE

 ;            10)=INTEREST RATE

 ;            11)=INTEREST DAYS ELIGIBLE

 ;            12)=INTEREST PAID

 ;            13)=INTEREST ADDTNL PENALTY PAID

 ;            14)=INTEREST TOTAL PAID THIS TRANS 

 F ACHS=22:1:28 S ACHSEOBR("I",ACHS-14)=$$VAL^XBDIQ1(9002080.02,.DA,ACHS)

 ;BELOW FORMATS: INTEREST OBJECT CLASS CODE

 S ACHSEOBR("I",9)=$P(ACHSEOBR("I",9),".")_$P(ACHSEOBR("I",9),".",2)

 ;

 ;E OR J ARRAY

 ;E OR J HEADING RECORD

 ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J

E ;

 S:'$G(ACHSREJ) ACHSREJ="J"  ;ACHS*3.1*24

 F %=8:1:16 S ACHSEOBR(ACHSREJ,%)=""        ;INIT ARRAY

 S ACHSEOBR(ACHSREJ,8)=$P(ACHSTRAN,U,4)     ;IHS PAYMENT AMOUNT

 S ACHSEOBR(ACHSREJ,9)=$P(ACHSTRAN,U,21)    ;EOBR OBLIGATION TYPE

 ;FORMAT THE DECIMAL OUT FOR MAINFRAME

 I ACHSEOBR(ACHSREJ,8)["." S %=ACHSEOBR(ACHSREJ,8),%=$P(%,".")_$E($P(%,".",2)_"00",1,2),ACHSEOBR(ACHSREJ,8)=%

 E  S ACHSEOBR(ACHSREJ,8)=ACHSEOBR(ACHSREJ,8)_"00"

 ;

 ;

 ;BELOW: GO THRU DIAGNOSIS MULTIPLE AND PULL

 ;THIS IS A REWRITE OF A GO LOOP

 ;THERE MAY BE A PROBLEM IN THE LOGIC OF THIS I FOUND PIECE 2 

 ;RARELY POPULATED  

E1 S ACHSCNTR=11    ;INIT COUNTER FOR DIAG FIELD NUMBERS FOR MAINFRAME 

 S ACHSICD=0

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

 .Q:$G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD,0))=""

 .;GET DIAGNOSIS ZERO NODE RECORD

 .S ACHSICD0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD,0))

 .;IF WE HAVE AN ICD CODE AND A EOBR TRANSACTION NUMBER

 .I $P(ACHSICD0,U),$P(ACHSICD0,U,2) D

 ..S ACHSCNTR=ACHSCNTR+1

 ..S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P(ACHSICD0,U)

 ..;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 ..;3.1*15 1.22.2009 IHS/OIT/FCJ CSV CHANGES PRINTED INVALID CODES

 ..;S ACHSEOBR("E",ACHSCNTR)=$P($G(^ICD9($P(ACHSICD0,U),0)),U)

 ..;ACHS*3.1*23

 ..;S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P($$ICDDX^ICDCODE($P(ACHSICD0,U),0),U,2)

 ..S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P($$ICDDX^ICDEX($P(ACHSICD0,U),,,"I"),U,2)

 ;

 ;

 D ^ACHSEOBF   ; GO DO MORE ARRAY VARIABLES F AND G FOR EOBR

 Q

 ;

 ;

ACHSEOBA  ; IHS/ITSC/TPF/PMF - SET ARRAY VARIABLES A THRU E FROM DOCUMENT FOR EOBR PRNTING ; JUL 10, 2008   

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,23,24**;JUN 11,2001;Build 43

 +2       ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES

 +3       ;3.1*15 1.22.2009 IHS/OIT/FCJ CSV CHANGES PRINTED INVALID CODES

 +4       ;

 +5       ;

 +6        SET ACHSDOC=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0),"NO DOC 0 RECORD")

 +7        SET ACHSDOC3=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,3),"NO DOC 3 RECORD")

 +8        SET ACHSTRAN=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),"NO TRAN 0 RECORD")

 +9        SET ACHSFAC0=$GET(^ACHSF(DUZ(2),0),"NO CHS FACILITY 0 RECORD")

 +10      ;ASUFAC INDEX

           IF $PIECE(ACHSFAC0,U)'=""

               SET ACHSLOC=$PIECE(^AUTTLOC($PIECE(ACHSFAC0,U),0),U,10)

 +11      IF '$TEST

               SET ACHSLOC="UNDEFINED"

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

 +13      ;

 +14      ;THE A ARRAY

 +15      ;A HEADING RECORD

A         ;

 +1       ;INITIALIZE ARRAY

           FOR %=1:1:15

               SET ACHSEOBR("A",%)=""

 +2       ;AREA CODE

           SET ACHSEOBR("A",1)=$EXTRACT(ACHSLOC,1,2)

 +3       ;SERVICE UNIT CODE

           SET ACHSEOBR("A",2)=$EXTRACT(ACHSLOC,3,4)

 +4       ;FACILITY (CODE) NUMBER

           SET ACHSEOBR("A",3)=$EXTRACT(ACHSLOC,5,6)

 +5       ;FISCAL YEAR

           SET ACHSEOBR("A",4)="0"_$PIECE(ACHSDOC,U,14)

 +6       ;EOBR CONTROL NUMBER

           SET ACHSEOBR("A",5)=$EXTRACT($PIECE(ACHSTRAN,U,17),8,17)

 +7       ; PATTERN 7A-9N

 +8       ;FI GENERATED   

 +9       ;RECORD TYPE

           SET ACHSEOBR("A",6)="A"

 +10      ;S ACHEOBR("A",7)                                ;SEQ NUM ALWAYS 001?

 +11      ;EOBR CLAIM SEQ. NO.

           SET ACHSEOBR("A",8)=$PIECE(ACHSTRAN,U,14)

 +12      ;CHECK #

           SET ACHSEOBR("A",9)=$PIECE(ACHSTRAN,U,18)

 +13      ;EOBR REMITT. #

           SET ACHSEOBR("A",10)=$PIECE(ACHSTRAN,U,19)

 +14      ;

 +15      ; change line.  store date as yyyymmdd.  050101  pmf   S ACHSEOBR("A",11)=$P(ACHSTRAN,U,13)

 +16      ;EOBR DATE

           SET ACHSEOBR("A",11)=$PIECE(ACHSTRAN,U,13)+17000000

 +17      ; remove line.  05/01/01   pmf   S ACHSEOBR("A",11)=$E(ACHSEOBR("A",11),2,7)

 +18      ;

 +19      ;

 +20      ;BELOW IS PURCHASE ORDER # ; FISCAL YEAR-FACILITY?-ORDER NUMBER

 +21       SET ACHSEOBR("A",12)=$PIECE(ACHSDOC,U,14)_"-"_ACHSFC_"-"_$PIECE(ACHSDOC,U)

 +22      ;FIRST 7 OF CONTROL #

           SET ACHSEOBR("A",13)=$EXTRACT($PIECE(ACHSTRAN,U,17),1,7)

 +23      ;

 +24      ;BELOW IS FACILITY CODE     AREA CODE-SERVICE UNIT CODE-FACILITY CODE

 +25       SET ACHSEOBR("A",14)=ACHSEOBR("A",1)_ACHSEOBR("A",2)_ACHSEOBR("A",3)

 +26      ;TYPE OF SERV. (DOC. TYPE)

           SET ACHSEOBR("A",15)=$PIECE(ACHSDOC,U,4)

 +27      ;

           SET ACHSEOBR("A",15)=$SELECT(ACHSEOBR("A",15)=1:43,ACHSEOBR("A",15)=2:57,ACHSEOBR("A",15)=3:64)

 +28      ;

 +29      ;THE B ARRAY

 +30      ;B HEADING RECORD

B         ;

 +1       ;INITIALIZE ARRAY

           FOR %=8:1:14

               SET ACHSEOBR("B",%)=""

 +2       ;GET PATIENT PTR

           SET %=$PIECE(ACHSDOC,U,22)

 +3       ;GET PATIENT NAME

           IF %

               SET ACHSEOBR("B",8)=$PIECE($GET(^DPT(%,0)),U)

 +4       IF '$TEST

               SET ACHSEOBR("B",8)=$SELECT($PIECE(ACHSDOC,U,3)=1:"* BLANKET",$PIECE(ACHSDOC,U,3)=2:"* SPECIAL TRANS",1:"")

 +5       ;HRN HEALTH REC #

           SET ACHSEOBR("B",9)=$PIECE(ACHSDOC,U,21)

 +6       ;AUTH DATE CCYYMMDD

           SET ACHSEOBR("B",10)=17000000+$PIECE(ACHSDOC,U,2)

 +7       ;WORKLOAD  (ACTUAL DAYS)

           SET ACHSEOBR("B",11)=$PIECE(ACHSTRAN,U,9)

 +8       ;

 +9       ;GET DRG PTR

           SET %=$$DOC^ACHS(8,1)

 +10       IF %

               SET %="00"_%

               SET ACHSEOBR("B",12)=$EXTRACT(%,$LENGTH(%)-2,$LENGTH(%))

 +11      ;GET DISCHARGE TYPE

           SET %=$$DOC^ACHS(8,4)

 +12      ;IHS CODE(FILLER)

           IF %

               SET ACHSEOBR("B",13)=$PIECE($GET(^DIC(42.2,%,9999999)),U)

 +13      ;BELOW IS: USE OBJECT CLASSIFICATION PTR, GET OBJ CLASS CODE 

 +14       IF $PIECE(ACHSDOC,U,7)

               SET ACHSEOBR("B",14)=$PIECE($GET(^ACHS(3,DUZ(2),1,$PIECE(ACHSDOC,U,7),0)),U)

 +15      IF '$TEST

               SET ACHSEOBR("B",14)=""

 +16      ;

 +17      ;THE C ARRAY

 +18      ;C HEADING RECORD

C         ;

 +1       ;INITIALIZE ARRAY

           FOR %=8:1:16

               SET ACHSEOBR("C",%)=""

 +2       ;CAN PTR TO CAN 

           IF $PIECE(ACHSDOC,U,6)

               SET ACHSEOBR("C",8)=$PIECE(^ACHS(2,$PIECE(ACHSDOC,U,6),0),U)

 +3       IF '$TEST

               SET ACHSEOBR("C",8)="XXXXXXXXXXXXXXXX"

 +4       ;S ACHSEOBR("C",9)=$P($G(^ACHSOCC($P(ACHSDOC,U,10),0)),U)  ;VENDOR CHARGE EST TO GET OBJECT CLASS CODE???????

 +5       ;GET OBJECT CLASS PTR THEN OBJECT CLASS CODE

 +6        IF $PIECE(ACHSDOC,U,7)

               SET ACHSEOBR("C",9)=$PIECE($GET(^ACHSOCC($PIECE(ACHSDOC,U,7),0)),U)

 +7       IF '$TEST

               SET ACHSEOBR("C",9)="UNKN"

 +8       ;EOBR SERVICES BILLED  

           SET ACHSEOBR("C",10)=$PIECE(ACHSTRAN,U,20)

 +9       ;BLANKET ORDER (INDICATOR)

           SET ACHSEOBR("C",11)=$PIECE(ACHSDOC,U,3)

 +10       SET ACHSEOBR("C",11)=$SELECT(ACHSEOBR("C",11)=1:"Y",ACHSEOBR("C",11)=0:"N",1:"")

 +11      ;(CONTRACT NUMBER) ?????

           SET ACHSEOBR("C",12)="OM"

 +12      ;

 +13      ;IF CON. PTR AND VEND. PTR GET CON. # FROM VEND. CONTRACT FILE 

 +14       SET ACHSVEND=$PIECE(ACHSDOC,U,8)

 +15       IF $PIECE(ACHSDOC,U,5)

               IF ACHSVEND

                   SET ACHSEOBR("C",12)=$PIECE(^AUTTVNDR($PIECE(ACHSDOC,U,8),"CN",$PIECE(ACHSDOC,U,5),0),U)

 +16      IF '$TEST

               SET ACHSEOBR("C",12)="OM"

 +17      ;

 +18      ;

 +19      ;

 +20      ;EOBR PAY TYPE (INTERM/FINAL IND)

           SET ACHSEOBR("C",13)=$PIECE(ACHSTRAN,U,15)

 +21      ;

 +22      ;AUTH BEGIN DATE (SERV START DATE

           SET ACHSEOBR("C",14)=17000000+$PIECE(ACHSDOC3,U)

 +23      ;AUTH ENDING DATE (SERV END DATE)

           SET ACHSEOBR("C",15)=17000000+$PIECE(ACHSDOC3,U,2)

 +24      ;

 +25      ;GET VENDOR PTR

 +26       IF ACHSVEND

               Begin DoDot:1

 +27               IF $DATA(^AUTTVNDR(ACHSVEND,11))

                       Begin DoDot:2

 +28      ;'EIN NO.'

                           SET ACHSEOBR("C",16)=$PIECE(^AUTTVNDR(ACHSVEND,11),U)

 +29      ;BELOW GET EIN SUFFIX AND SLAP IT ON END OF EIN NO

 +30      ;

                           IF $PIECE(^AUTTVNDR(ACHSVEND,11),U,2)'=""

                               SET ACHSEOBR("C",16)=ACHSEOBR("C",16)_"-"_$PIECE(^AUTTVNDR(ACHSVEND,11),U,2)

                       End DoDot:2

               End DoDot:1

 +31      ;

 +32      ;D ARRAY

 +33      ;D HEADING RECORD

 +34      ;

D         ;

 +1       ;INIT ARRAY

           FOR %=8:1:11

               SET ACHSEOBR("D",%)=""

 +2       ;VENDOR NAME

           SET ACHSEOBR("D",8)=$PIECE($GET(^AUTTVNDR(ACHSVEND,0)),U)

 +3       ;THIRD PART. PAY AMT

           SET ACHSEOBR("D",11)=$PIECE(ACHSTRAN,U,8)

 +4       ;BILLED BY PROV.

           SET ACHSEOBR("D",9)=0

 +5       ;ALLOWABLE AMT

           SET ACHSEOBR("D",10)=0

 +6       ;

 +7       ;BELOW FORMATS OUT THE DECIMAL FOR MAINFRAME PROGRAM

 +8        IF ACHSEOBR("D",11)["."

               SET %=ACHSEOBR("D",11)

               SET %=$PIECE(%,".")_$EXTRACT($PIECE(%,".",2)_"00",1,2)

               SET ACHSEOBR("D",11)=%

 +9       IF '$TEST

               SET ACHSEOBR("D",11)=ACHSEOBR("D",11)_"00"

 +10      ;

I         ; Interest info.

 +1        SET DA(2)=DUZ(2)

           SET DA(1)=ACHSDIEN

           SET DA=ACHSTIEN

 +2       ;BELOW SETS UP I ARRAY FROM 8 TO 14

 +3       ;BY GETTING THE VALUES IN FIELDS 22- 28 FROM THE TRANSACTION SUBFILE OF

 +4       ;THE CHS FACILITY  CAN WE SIMPLIFY THIS?????

 +5       ;ACHSEOBR("I",8)=INTEREST CAN

 +6       ;             9)=INTEREST OBJECT CLASS CODE

 +7       ;            10)=INTEREST RATE

 +8       ;            11)=INTEREST DAYS ELIGIBLE

 +9       ;            12)=INTEREST PAID

 +10      ;            13)=INTEREST ADDTNL PENALTY PAID

 +11      ;            14)=INTEREST TOTAL PAID THIS TRANS 

 +12       FOR ACHS=22:1:28

               SET ACHSEOBR("I",ACHS-14)=$$VAL^XBDIQ1(9002080.02,.DA,ACHS)

 +13      ;BELOW FORMATS: INTEREST OBJECT CLASS CODE

 +14       SET ACHSEOBR("I",9)=$PIECE(ACHSEOBR("I",9),".")_$PIECE(ACHSEOBR("I",9),".",2)

 +15      ;

 +16      ;E OR J ARRAY

 +17      ;E OR J HEADING RECORD

 +18      ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J

E         ;

 +1       ;ACHS*3.1*24

           IF '$GET(ACHSREJ)

               SET ACHSREJ="J"

 +2       ;INIT ARRAY

           FOR %=8:1:16

               SET ACHSEOBR(ACHSREJ,%)=""

 +3       ;IHS PAYMENT AMOUNT

           SET ACHSEOBR(ACHSREJ,8)=$PIECE(ACHSTRAN,U,4)

 +4       ;EOBR OBLIGATION TYPE

           SET ACHSEOBR(ACHSREJ,9)=$PIECE(ACHSTRAN,U,21)

 +5       ;FORMAT THE DECIMAL OUT FOR MAINFRAME

 +6        IF ACHSEOBR(ACHSREJ,8)["."

               SET %=ACHSEOBR(ACHSREJ,8)

               SET %=$PIECE(%,".")_$EXTRACT($PIECE(%,".",2)_"00",1,2)

               SET ACHSEOBR(ACHSREJ,8)=%

 +7       IF '$TEST

               SET ACHSEOBR(ACHSREJ,8)=ACHSEOBR(ACHSREJ,8)_"00"

 +8       ;

 +9       ;

 +10      ;BELOW: GO THRU DIAGNOSIS MULTIPLE AND PULL

 +11      ;THIS IS A REWRITE OF A GO LOOP

 +12      ;THERE MAY BE A PROBLEM IN THE LOGIC OF THIS I FOUND PIECE 2 

 +13      ;RARELY POPULATED  

E1        ;INIT COUNTER FOR DIAG FIELD NUMBERS FOR MAINFRAME 

           SET ACHSCNTR=11

 +1        SET ACHSICD=0

 +2        FOR 

               SET ACHSICD=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD))

               IF +ACHSICD=0

                   QUIT 

               Begin DoDot:1

 +3                IF $GET(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD,0))=""

                       QUIT 

 +4       ;GET DIAGNOSIS ZERO NODE RECORD

 +5                SET ACHSICD0=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSICD,0))

 +6       ;IF WE HAVE AN ICD CODE AND A EOBR TRANSACTION NUMBER

 +7                IF $PIECE(ACHSICD0,U)

                       IF $PIECE(ACHSICD0,U,2)

                           Begin DoDot:2

 +8                            SET ACHSCNTR=ACHSCNTR+1

 +9                            SET ACHSEOBR(ACHSREJ,ACHSCNTR)=$PIECE(ACHSICD0,U)

 +10      ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES

 +11      ;3.1*15 1.22.2009 IHS/OIT/FCJ CSV CHANGES PRINTED INVALID CODES

 +12      ;S ACHSEOBR("E",ACHSCNTR)=$P($G(^ICD9($P(ACHSICD0,U),0)),U)

 +13      ;ACHS*3.1*23

 +14      ;S ACHSEOBR(ACHSREJ,ACHSCNTR)=$P($$ICDDX^ICDCODE($P(ACHSICD0,U),0),U,2)

 +15                           SET ACHSEOBR(ACHSREJ,ACHSCNTR)=$PIECE($$ICDDX^ICDEX($PIECE(ACHSICD0,U),,,"I"),U,2)

                           End DoDot:2

               End DoDot:1

 +16      ;

 +17      ;

 +18      ; GO DO MORE ARRAY VARIABLES F AND G FOR EOBR

           DO ^ACHSEOBF

 +19       QUIT 

 +20      ;

 +21      ;