BHLX835.m

BHLX835 ; cmi/flag/maw - BHL Parse X12 835 into readable format ;  [ 10/10/2002  9:28 AM ]

 ;;3.01;BHL IHS Interfaces with GIS;**6**;OCT 15, 2002

 ;

 ;

 ;

 ;this routine will parse the incoming message into readable format

 ;

MAIN ;EP - this is the main routine driver    

 K ^BHLX835($J)

 S BHLNOST=1

 D ^XBKVAR

 I $G(FS)="" S FS="*"

 D PRS

 D FL

 D UPD

 D EOJ

 Q

 ;

PRS ;-- parse the message

 S (SCNT,CNT,LCNT)=0

 S BHLXUIF=$G(UIF)

 Q:BHLXUIF=""

 S BHLXDA=0 F  S BHLXDA=$O(^INTHU(BHLXUIF,3,BHLXDA)) Q:'BHLXDA  D

 . S DATA=$G(^INTHU(BHLXUIF,3,BHLXDA,0))

 . S SEG=$P(DATA,FS)

 . Q:SEG["|"

 . I SEG="ST" S CNT=CNT+1,SCNT=0

 . I SEG="LX" S LCNT=LCNT+1

 . S SCNT=SCNT+1

 . S SEGDATA=$P($P($G(DATA),FS,2,9999),"|")

 . S ^BHLX835($J,CNT,$S(LCNT=0:1,1:LCNT),SCNT,SEG)=$G(SEGDATA)

 K SEG,SEGDATA,CNT,SCNT,LCNT

 Q

 ;

FL ;-- loop through bhlx835 and get data

 S XCNT=0

 S BHLXSDA=0 F  S BHLXSDA=$O(^BHLX835($J,BHLXSDA)) Q:'BHLXSDA  D

 . S XCNT=XCNT+1

 . S BHLXLDA=0 F  S BHLXLDA=$O(^BHLX835($J,BHLXSDA,BHLXLDA)) Q:'BHLXLDA  D

 .. S BHLXCDA=0 F  S BHLXCDA=$O(^BHLX835($J,BHLXSDA,BHLXLDA,BHLXCDA)) Q:'BHLXCDA  D

 ... S BHLXSEG=$O(^BHLX835($J,BHLXSDA,BHLXLDA,BHLXCDA,""))

 ... Q:$G(BHLXSEG)=""

 ... S BHLXDAT=$P($G(^BHLX835($J,BHLXSDA,BHLXLDA,BHLXCDA,BHLXSEG)),"~")

 ... I BHLXSEG="TRN" D TRN(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 ... I BHLXSEG="N1" D N1(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 ... I BHLXSEG="CLP" D CLP(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 ... I BHLXSEG="DTM" D DTM(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 ... I BHLXSEG="CAS" D CAS(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 ... I BHLXSEG="NM1" D NM1(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 K XCNT

 Q

 ;

TRN(DAT,SDA,LDA,CDA) ;-- trn

 S ^BHLX835V($J,SDA,"TRACE #")=$P(DAT,FS,2)

 Q

 ;

N1(DAT,SDA,LDA,CDA) ;-- n1

 Q:$P(DAT,FS)'="PR"

 S ^BHLX835V($J,SDA,"PAYOR")=$P(DAT,FS,2)

 Q

 ;

CLP(DAT,SDA,LDA,CDA)   ;--clp

 S ^BHLX835V($J,SDA,LDA,"BILL #")=$P(DAT,FS)

 S ^BHLX835V($J,SDA,LDA,"CHARGED AMOUNT")=$P(DAT,FS,3)

 S ^BHLX835V($J,SDA,LDA,"RECORD #")=$P(DAT,FS,7)

 S ^BHLX835V($J,SDA,LDA,"PD AMT")=$P(DAT,FS,4)

 Q

 ;

DTM(DAT,SDA,LDA,CDA)   ;--dtm

 Q:$P(DAT,FS)'=472

 S ^BHLX835V($J,SDA,LDA,"DOS")=$P(DAT,FS,2)

 Q

 ;

CAS(DAT,SDA,LDA,CDA)         ;-- cas

 S ^BHLX835V($J,SDA,LDA,XCNT,"ADJ REASON CODE")=$P(DAT,FS,2)

 S ^BHLX835V($J,SDA,LDA,XCNT,"ADJUSTMENT")=$P(DAT,FS,3)

 S XCNT=XCNT+1

 I $P(DAT,FS,5)]"" D

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJ REASON CODE")=$P(DAT,FS,5)

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJUSTMENT")=$P(DAT,FS,6)

 . S XCNT=XCNT+1

 I $P(DAT,FS,8)]"" D

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJ REASON CODE")=$P(DAT,FS,8)

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJUSTMENT")=$P(DAT,FS,9)

 . S XCNT=XCNT+1

 I $P(DAT,FS,11)]"" D

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJ REASON CODE")=$P(DAT,FS,11)

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJUSTMENT")=$P(DAT,FS,12)

 . S XCNT=XCNT+1

 I $P(DAT,FS,14)]"" D

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJ REASON CODE")=$P(DAT,FS,14)

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJUSTMENT")=$P(DAT,FS,15)

 . S XCNT=XCNT+1

 I $P(DAT,FS,17)]"" D

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJ REASON CODE")=$P(DAT,FS,17)

 . S ^BHLX835V($J,SDA,LDA,XCNT,"ADJUSTMENT")=$P(DAT,FS,18)

 . S XCNT=XCNT+1

 Q

 ;

NM1(DAT,SDA,LDA,CDA)         ;-- nm1

 Q:$P(DAT,FS)'="QC"

 S BHLXLNM=$P(DAT,FS,3)

 S BHLXFNM=$P(DAT,FS,4)

 S BHLXMI=$P(DAT,FS,5)

 S ^BHLX835V($J,SDA,LDA,"PATIENT NAME")=BHLXLNM_","_BHLXFNM_" "_BHLXMI

 Q

 ;

UPD ;-- update the holding file

 S BHLXUSDA=0 F  S BHLXUSDA=$O(^BHLX835V($J,BHLXUSDA)) Q:'BHLXUSDA  D

 . D L1(BHLXUSDA)

 . S BHLXULDA=0 F  S BHLXULDA=$O(^BHLX835V($J,BHLXUSDA,BHLXULDA)) Q:BHLXULDA=""  D

 .. D L2(BHLXUSDA,BHLXULDA)

 .. S BHLXUCDA=0 F  S BHLXUCDA=$O(^BHLX835V($J,BHLXUSDA,BHLXULDA,BHLXUCDA)) Q:'BHLXUCDA  D

 ... D L3(BHLXUSDA,BHLXULDA,BHLXUCDA)

 .. D FH(BHLXUSDA,BHLXULDA,.BHLXUPD)

 .. K BHLXUPD("ADJUSTMENT"),BHLXUPD("ADJ REASON CODE")

 K UPD,XIEN

 Q

 ;

L1(USDA) ;-- setup lev 1 vars for filing

 S BHLXUPD("PAYOR")=$G(^BHLX835V($J,USDA,"PAYOR"))

 S BHLXUPD("TRACE #")=$G(^BHLX835V($J,USDA,"TRACE #"))

 Q

 ;

L2(USDA,ULDA)      ;-- setup level 2 vars for filing

 Q:ULDA'?.N

 S BHLXUPD("BILL #")=$G(^BHLX835V($J,USDA,ULDA,"BILL #"))

 S BHLXUPD("CHARGED AMOUNT")=$G(^BHLX835V($J,USDA,ULDA,"CHARGED AMOUNT"))

 S BHLXUPD("DOS")=$$HDT^INHUT1($G(^BHLX835V($J,USDA,ULDA,"DOS")))

 S BHLXUPD("RECORD #")=$G(^BHLX835V($J,USDA,ULDA,"RECORD #"))

 S BHLXUPD("PATIENT NAME")=$G(^BHLX835V($J,USDA,ULDA,"PATIENT NAME"))

 S BHLXUPD("PD AMT")=$G(^BHLX835V($J,USDA,ULDA,"PD AMT"))

 Q

 ;

L3(USDA,ULDA,UCDA) ;-- setup level 3 vars for filing

 Q:UCDA'?.N

 S BHLXUPD("ADJ REASON CODE",UCDA)=$G(^BHLX835V($J,USDA,ULDA,UCDA,"ADJ REASON CODE"))

 S BHLXUPD("ADJUSTMENT",UCDA)=$G(^BHLX835V($J,USDA,ULDA,UCDA,"ADJUSTMENT"))

 Q

 ;

FH(USDA,ULDA,UPD) ;-- file into holding

 ;look for entry in 90051.01

 K XIEN

 Q:'USDA

 Q:'ULDA

 S BHLXMT=$$LK(UPD("TRACE #"))

 I $G(BHLXMT) D

 . D FBL(UPD("BILL #"),UPD("PATIENT NAME"),UPD("DOS"))

 K DD,DO

 S DIC="^BAR835(",DIC(0)="L",X=UPD("BILL #")

 S DIC("DR")=".02///"_$S($G(BHLXBMT):1,1:0)_";.03///"_UPD("RECORD #")

 S DIC("DR")=DIC("DR")_";.04///"_UPD("PAYOR")

 S DIC("DR")=DIC("DR")_";.05///"_UPD("TRACE #")

 S DIC("DR")=DIC("DR")_";.06///"_$G(XIEN("BATCH"))

 S DIC("DR")=DIC("DR")_";.07///"_$G(XIEN("ITEM"))

 S DIC("DR")=DIC("DR")_";.08////"_$G(XIEN("BILL IEN"))

 S DIC("DR")=DIC("DR")_";.11///"_UPD("PATIENT NAME")

 S DIC("DR")=DIC("DR")_";.12////"_$G(XIEN("AR PAT"))

 S DIC("DR")=DIC("DR")_";.13////"_UPD("DOS")

 S DIC("DR")=DIC("DR")_";.14///"_$G(XIEN("AR DOS"))

 S DIC("DR")=DIC("DR")_";.15///"_UPD("CHARGED AMOUNT")

 S DIC("DR")=DIC("DR")_";.16///"_$G(XIEN("AR AMOUNT"))

 S DIC("DR")=DIC("DR")_";.17///"_$G(XIEN("AR BAL"))

 S DIC("DR")=DIC("DR")_";.18///"_UPD("PD AMT")

 D FILE^DICN

 S BHLXHIEN=+Y

 K DD,DO,DIC

 S DIC="^BAR835("_BHLXHIEN_",2,",DIC(0)="L",DA(1)=BHLXHIEN

 S DIC("P")=$P(^DD(90056.07,20,0),"^",2)

 S XHIEN=0 F  S XHIEN=$O(UPD("ADJUSTMENT",XHIEN)) Q:'XHIEN  D

 . S X=UPD("ADJUSTMENT",XHIEN)

 . S DIC("DR")=".02///"_$S(UPD("ADJ REASON CODE",XHIEN)?.N:+UPD("ADJ REASON CODE",XHIEN),1:UPD("ADJ REASON CODE",XHIEN))

 . S DIC("DR")=DIC("DR")_";.03///"_$$ARADJ(UPD("ADJ REASON CODE",XHIEN))

 . D FILE^DICN

 Q

 ;

LK(TRC) ;EP - lookup batch by trace.check #

 K XIEN,BHLXBILL

 I '$O(^BARCOL(DUZ(2),"D",TRC,0)) Q ""

 S BHLXCOL=$O(^BARCOL(DUZ(2),"D",TRC,0))

 S BHLXITM=$O(^BARCOL(DUZ(2),"D",TRC,BHLXCOL,0))

 I '$G(BHLXITM) Q ""

 S XIEN("BATCH")=$P($G(^BARCOL(DUZ(2),BHLXCOL,0)),U)

 S XIEN("ITEM")=$P($G(^BARCOL(DUZ(2),BHLXCOL,1,BHLXITM,0)),U)

 Q 1

 ;

FBL(BL,UPNM,UDOS) ;EP - find the bill number

 K BHLXBMT

 S BHLXCNT=0

 Q:'$O(^BARBL(DUZ(2),"B",BL,0))

 S XDA=0 F  S XDA=$O(^BARBL(DUZ(2),"B",BL,XDA)) Q:XDA=""  D

 . S BHLXCNT=BHLXCNT+1

 I BHLXCNT>1 D  Q

 . S XDA=0 F  S XDA=$O(^BARCB(DUZ(2),"B",BL,XDA)) Q:XDA=""  D

 .. S ADOS=$P($G(^BARBL(DUZ(2),XDA,1)),U,2)

 .. Q:ADOS'=UDOS

 .. S APNM=$$GET1^DIQ(90050.01,XDA,101)

 .. S APLK=$P(APNM,",")_$E($P(APNM,",",2),1,2)

 .. S UPLK=$P(UPNM,",")_$E($P(UPNM,",",2),1,2)

 .. Q:UPLK'=APLK

 .. S BHLXBILL=XDA

 .. S XIEN("BILL IEN")=BHLXBILL

 .. S XIEN("AR DOS")=$P($G(^BARBL(DUZ(2),BHLXBILL,1)),U,2)

 .. S XIEN("AR PAT")=$P($G(^BARBL(DUZ(2),BHLXBILL,1)),U)

 .. S XIEN("AR AMOUNT")=$P($G(^BARBL(DUZ(2),BHLXBILL,0)),U,13)

 .. S XIEN("AR BAL")=$P($G(^BARBL(DUZ(2),BHLXBILL,0)),U,15)

 I BHLXCNT=1 S BHLXBILL=$O(^BARBL(DUZ(2),"B",BL,0))

 I '$G(BHLXBILL) K ADOS,APNM

 S BHLXBMT=1

 S XIEN("BILL IEN")=BHLXBILL

 S XIEN("AR DOS")=$P($G(^BARBL(DUZ(2),BHLXBILL,1)),U,2)

 S XIEN("AR PAT")=$P($G(^BARBL(DUZ(2),BHLXBILL,1)),U)

 S XIEN("AR AMOUNT")=$P($G(^BARBL(DUZ(2),BHLXBILL,0)),U,13)

 S XIEN("AR BAL")=$P($G(^BARBL(DUZ(2),BHLXBILL,0)),U,15)

 K ADOS,APNM

 Q

 ;

ARADJ(ARC)         ;-- lookup a/r reason code

 I ARC="" Q ""

 I ARC?.N S ARC=+ARC

 S BHLXAIEN=$O(^BARADJ("B",ARC,0))

 I 'BHLXAIEN Q ""

 Q $P($G(^BARADJ(BHLXAIEN,0)),U,3)_"/"_$P($G(^BARADJ(BHLXAIEN,0)),U,4)

 ;

EOJ ;-- kill vars

 K ^BHLX835($J)

 K ^BHLX835V($J)

 D EN^XBVK("BHLX")

 Q

 ;

BHLX835   ; cmi/flag/maw - BHL Parse X12 835 into readable format ;  [ 10/10/2002  9:28 AM ]

 +1       ;;3.01;BHL IHS Interfaces with GIS;**6**;OCT 15, 2002

 +2       ;

 +3       ;

 +4       ;

 +5       ;this routine will parse the incoming message into readable format

 +6       ;

MAIN      ;EP - this is the main routine driver    

 +1        KILL ^BHLX835($JOB)

 +2        SET BHLNOST=1

 +3        DO ^XBKVAR

 +4        IF $GET(FS)=""

               SET FS="*"

 +5        DO PRS

 +6        DO FL

 +7        DO UPD

 +8        DO EOJ

 +9        QUIT 

 +10      ;

PRS       ;-- parse the message

 +1        SET (SCNT,CNT,LCNT)=0

 +2        SET BHLXUIF=$GET(UIF)

 +3        IF BHLXUIF=""

               QUIT 

 +4        SET BHLXDA=0

           FOR 

               SET BHLXDA=$ORDER(^INTHU(BHLXUIF,3,BHLXDA))

               IF 'BHLXDA

                   QUIT 

               Begin DoDot:1

 +5                SET DATA=$GET(^INTHU(BHLXUIF,3,BHLXDA,0))

 +6                SET SEG=$PIECE(DATA,FS)

 +7                IF SEG["|"

                       QUIT 

 +8                IF SEG="ST"

                       SET CNT=CNT+1

                       SET SCNT=0

 +9                IF SEG="LX"

                       SET LCNT=LCNT+1

 +10               SET SCNT=SCNT+1

 +11               SET SEGDATA=$PIECE($PIECE($GET(DATA),FS,2,9999),"|")

 +12               SET ^BHLX835($JOB,CNT,$SELECT(LCNT=0:1,1:LCNT),SCNT,SEG)=$GET(SEGDATA)

               End DoDot:1

 +13       KILL SEG,SEGDATA,CNT,SCNT,LCNT

 +14       QUIT 

 +15      ;

FL        ;-- loop through bhlx835 and get data

 +1        SET XCNT=0

 +2        SET BHLXSDA=0

           FOR 

               SET BHLXSDA=$ORDER(^BHLX835($JOB,BHLXSDA))

               IF 'BHLXSDA

                   QUIT 

               Begin DoDot:1

 +3                SET XCNT=XCNT+1

 +4                SET BHLXLDA=0

                   FOR 

                       SET BHLXLDA=$ORDER(^BHLX835($JOB,BHLXSDA,BHLXLDA))

                       IF 'BHLXLDA

                           QUIT 

                       Begin DoDot:2

 +5                        SET BHLXCDA=0

                           FOR 

                               SET BHLXCDA=$ORDER(^BHLX835($JOB,BHLXSDA,BHLXLDA,BHLXCDA))

                               IF 'BHLXCDA

                                   QUIT 

                               Begin DoDot:3

 +6                                SET BHLXSEG=$ORDER(^BHLX835($JOB,BHLXSDA,BHLXLDA,BHLXCDA,""))

 +7                                IF $GET(BHLXSEG)=""

                                       QUIT 

 +8                                SET BHLXDAT=$PIECE($GET(^BHLX835($JOB,BHLXSDA,BHLXLDA,BHLXCDA,BHLXSEG)),"~")

 +9                                IF BHLXSEG="TRN"

                                       DO TRN(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 +10                               IF BHLXSEG="N1"

                                       DO N1(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 +11                               IF BHLXSEG="CLP"

                                       DO CLP(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 +12                               IF BHLXSEG="DTM"

                                       DO DTM(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 +13                               IF BHLXSEG="CAS"

                                       DO CAS(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

 +14                               IF BHLXSEG="NM1"

                                       DO NM1(BHLXDAT,BHLXSDA,BHLXLDA,BHLXCDA)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +15       KILL XCNT

 +16       QUIT 

 +17      ;

TRN(DAT,SDA,LDA,CDA) ;-- trn

 +1        SET ^BHLX835V($JOB,SDA,"TRACE #")=$PIECE(DAT,FS,2)

 +2        QUIT 

 +3       ;

N1(DAT,SDA,LDA,CDA) ;-- n1

 +1        IF $PIECE(DAT,FS)'="PR"

               QUIT 

 +2        SET ^BHLX835V($JOB,SDA,"PAYOR")=$PIECE(DAT,FS,2)

 +3        QUIT 

 +4       ;

CLP(DAT,SDA,LDA,CDA) ;--clp

 +1        SET ^BHLX835V($JOB,SDA,LDA,"BILL #")=$PIECE(DAT,FS)

 +2        SET ^BHLX835V($JOB,SDA,LDA,"CHARGED AMOUNT")=$PIECE(DAT,FS,3)

 +3        SET ^BHLX835V($JOB,SDA,LDA,"RECORD #")=$PIECE(DAT,FS,7)

 +4        SET ^BHLX835V($JOB,SDA,LDA,"PD AMT")=$PIECE(DAT,FS,4)

 +5        QUIT 

 +6       ;

DTM(DAT,SDA,LDA,CDA) ;--dtm

 +1        IF $PIECE(DAT,FS)'=472

               QUIT 

 +2        SET ^BHLX835V($JOB,SDA,LDA,"DOS")=$PIECE(DAT,FS,2)

 +3        QUIT 

 +4       ;

CAS(DAT,SDA,LDA,CDA) ;-- cas

 +1        SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJ REASON CODE")=$PIECE(DAT,FS,2)

 +2        SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJUSTMENT")=$PIECE(DAT,FS,3)

 +3        SET XCNT=XCNT+1

 +4        IF $PIECE(DAT,FS,5)]""

               Begin DoDot:1

 +5                SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJ REASON CODE")=$PIECE(DAT,FS,5)

 +6                SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJUSTMENT")=$PIECE(DAT,FS,6)

 +7                SET XCNT=XCNT+1

               End DoDot:1

 +8        IF $PIECE(DAT,FS,8)]""

               Begin DoDot:1

 +9                SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJ REASON CODE")=$PIECE(DAT,FS,8)

 +10               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJUSTMENT")=$PIECE(DAT,FS,9)

 +11               SET XCNT=XCNT+1

               End DoDot:1

 +12       IF $PIECE(DAT,FS,11)]""

               Begin DoDot:1

 +13               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJ REASON CODE")=$PIECE(DAT,FS,11)

 +14               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJUSTMENT")=$PIECE(DAT,FS,12)

 +15               SET XCNT=XCNT+1

               End DoDot:1

 +16       IF $PIECE(DAT,FS,14)]""

               Begin DoDot:1

 +17               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJ REASON CODE")=$PIECE(DAT,FS,14)

 +18               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJUSTMENT")=$PIECE(DAT,FS,15)

 +19               SET XCNT=XCNT+1

               End DoDot:1

 +20       IF $PIECE(DAT,FS,17)]""

               Begin DoDot:1

 +21               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJ REASON CODE")=$PIECE(DAT,FS,17)

 +22               SET ^BHLX835V($JOB,SDA,LDA,XCNT,"ADJUSTMENT")=$PIECE(DAT,FS,18)

 +23               SET XCNT=XCNT+1

               End DoDot:1

 +24       QUIT 

 +25      ;

NM1(DAT,SDA,LDA,CDA) ;-- nm1

 +1        IF $PIECE(DAT,FS)'="QC"

               QUIT 

 +2        SET BHLXLNM=$PIECE(DAT,FS,3)

 +3        SET BHLXFNM=$PIECE(DAT,FS,4)

 +4        SET BHLXMI=$PIECE(DAT,FS,5)

 +5        SET ^BHLX835V($JOB,SDA,LDA,"PATIENT NAME")=BHLXLNM_","_BHLXFNM_" "_BHLXMI

 +6        QUIT 

 +7       ;

UPD       ;-- update the holding file

 +1        SET BHLXUSDA=0

           FOR 

               SET BHLXUSDA=$ORDER(^BHLX835V($JOB,BHLXUSDA))

               IF 'BHLXUSDA

                   QUIT 

               Begin DoDot:1

 +2                DO L1(BHLXUSDA)

 +3                SET BHLXULDA=0

                   FOR 

                       SET BHLXULDA=$ORDER(^BHLX835V($JOB,BHLXUSDA,BHLXULDA))

                       IF BHLXULDA=""

                           QUIT 

                       Begin DoDot:2

 +4                        DO L2(BHLXUSDA,BHLXULDA)

 +5                        SET BHLXUCDA=0

                           FOR 

                               SET BHLXUCDA=$ORDER(^BHLX835V($JOB,BHLXUSDA,BHLXULDA,BHLXUCDA))

                               IF 'BHLXUCDA

                                   QUIT 

                               Begin DoDot:3

 +6                                DO L3(BHLXUSDA,BHLXULDA,BHLXUCDA)

                               End DoDot:3

 +7                        DO FH(BHLXUSDA,BHLXULDA,.BHLXUPD)

 +8                        KILL BHLXUPD("ADJUSTMENT"),BHLXUPD("ADJ REASON CODE")

                       End DoDot:2

               End DoDot:1

 +9        KILL UPD,XIEN

 +10       QUIT 

 +11      ;

L1(USDA)  ;-- setup lev 1 vars for filing

 +1        SET BHLXUPD("PAYOR")=$GET(^BHLX835V($JOB,USDA,"PAYOR"))

 +2        SET BHLXUPD("TRACE #")=$GET(^BHLX835V($JOB,USDA,"TRACE #"))

 +3        QUIT 

 +4       ;

L2(USDA,ULDA) ;-- setup level 2 vars for filing

 +1        IF ULDA'?.N

               QUIT 

 +2        SET BHLXUPD("BILL #")=$GET(^BHLX835V($JOB,USDA,ULDA,"BILL #"))

 +3        SET BHLXUPD("CHARGED AMOUNT")=$GET(^BHLX835V($JOB,USDA,ULDA,"CHARGED AMOUNT"))

 +4        SET BHLXUPD("DOS")=$$HDT^INHUT1($GET(^BHLX835V($JOB,USDA,ULDA,"DOS")))

 +5        SET BHLXUPD("RECORD #")=$GET(^BHLX835V($JOB,USDA,ULDA,"RECORD #"))

 +6        SET BHLXUPD("PATIENT NAME")=$GET(^BHLX835V($JOB,USDA,ULDA,"PATIENT NAME"))

 +7        SET BHLXUPD("PD AMT")=$GET(^BHLX835V($JOB,USDA,ULDA,"PD AMT"))

 +8        QUIT 

 +9       ;

L3(USDA,ULDA,UCDA) ;-- setup level 3 vars for filing

 +1        IF UCDA'?.N

               QUIT 

 +2        SET BHLXUPD("ADJ REASON CODE",UCDA)=$GET(^BHLX835V($JOB,USDA,ULDA,UCDA,"ADJ REASON CODE"))

 +3        SET BHLXUPD("ADJUSTMENT",UCDA)=$GET(^BHLX835V($JOB,USDA,ULDA,UCDA,"ADJUSTMENT"))

 +4        QUIT 

 +5       ;

FH(USDA,ULDA,UPD) ;-- file into holding

 +1       ;look for entry in 90051.01

 +2        KILL XIEN

 +3        IF 'USDA

               QUIT 

 +4        IF 'ULDA

               QUIT 

 +5        SET BHLXMT=$$LK(UPD("TRACE #"))

 +6        IF $GET(BHLXMT)

               Begin DoDot:1

 +7                DO FBL(UPD("BILL #"),UPD("PATIENT NAME"),UPD("DOS"))

               End DoDot:1

 +8        KILL DD,DO

 +9        SET DIC="^BAR835("

           SET DIC(0)="L"

           SET X=UPD("BILL #")

 +10       SET DIC("DR")=".02///"_$SELECT($GET(BHLXBMT):1,1:0)_";.03///"_UPD("RECORD #")

 +11       SET DIC("DR")=DIC("DR")_";.04///"_UPD("PAYOR")

 +12       SET DIC("DR")=DIC("DR")_";.05///"_UPD("TRACE #")

 +13       SET DIC("DR")=DIC("DR")_";.06///"_$GET(XIEN("BATCH"))

 +14       SET DIC("DR")=DIC("DR")_";.07///"_$GET(XIEN("ITEM"))

 +15       SET DIC("DR")=DIC("DR")_";.08////"_$GET(XIEN("BILL IEN"))

 +16       SET DIC("DR")=DIC("DR")_";.11///"_UPD("PATIENT NAME")

 +17       SET DIC("DR")=DIC("DR")_";.12////"_$GET(XIEN("AR PAT"))

 +18       SET DIC("DR")=DIC("DR")_";.13////"_UPD("DOS")

 +19       SET DIC("DR")=DIC("DR")_";.14///"_$GET(XIEN("AR DOS"))

 +20       SET DIC("DR")=DIC("DR")_";.15///"_UPD("CHARGED AMOUNT")

 +21       SET DIC("DR")=DIC("DR")_";.16///"_$GET(XIEN("AR AMOUNT"))

 +22       SET DIC("DR")=DIC("DR")_";.17///"_$GET(XIEN("AR BAL"))

 +23       SET DIC("DR")=DIC("DR")_";.18///"_UPD("PD AMT")

 +24       DO FILE^DICN

 +25       SET BHLXHIEN=+Y

 +26       KILL DD,DO,DIC

 +27       SET DIC="^BAR835("_BHLXHIEN_",2,"

           SET DIC(0)="L"

           SET DA(1)=BHLXHIEN

 +28       SET DIC("P")=$PIECE(^DD(90056.07,20,0),"^",2)

 +29       SET XHIEN=0

           FOR 

               SET XHIEN=$ORDER(UPD("ADJUSTMENT",XHIEN))

               IF 'XHIEN

                   QUIT 

               Begin DoDot:1

 +30               SET X=UPD("ADJUSTMENT",XHIEN)

 +31               SET DIC("DR")=".02///"_$SELECT(UPD("ADJ REASON CODE",XHIEN)?.N:+UPD("ADJ REASON CODE",XHIEN),1:UPD("ADJ REASON CODE",XHIEN))

 +32               SET DIC("DR")=DIC("DR")_";.03///"_$$ARADJ(UPD("ADJ REASON CODE",XHIEN))

 +33               DO FILE^DICN

               End DoDot:1

 +34       QUIT 

 +35      ;

LK(TRC)   ;EP - lookup batch by trace.check #

 +1        KILL XIEN,BHLXBILL

 +2        IF '$ORDER(^BARCOL(DUZ(2),"D",TRC,0))

               QUIT ""

 +3        SET BHLXCOL=$ORDER(^BARCOL(DUZ(2),"D",TRC,0))

 +4        SET BHLXITM=$ORDER(^BARCOL(DUZ(2),"D",TRC,BHLXCOL,0))

 +5        IF '$GET(BHLXITM)

               QUIT ""

 +6        SET XIEN("BATCH")=$PIECE($GET(^BARCOL(DUZ(2),BHLXCOL,0)),U)

 +7        SET XIEN("ITEM")=$PIECE($GET(^BARCOL(DUZ(2),BHLXCOL,1,BHLXITM,0)),U)

 +8        QUIT 1

 +9       ;

FBL(BL,UPNM,UDOS) ;EP - find the bill number

 +1        KILL BHLXBMT

 +2        SET BHLXCNT=0

 +3        IF '$ORDER(^BARBL(DUZ(2),"B",BL,0))

               QUIT 

 +4        SET XDA=0

           FOR 

               SET XDA=$ORDER(^BARBL(DUZ(2),"B",BL,XDA))

               IF XDA=""

                   QUIT 

               Begin DoDot:1

 +5                SET BHLXCNT=BHLXCNT+1

               End DoDot:1

 +6        IF BHLXCNT>1

               Begin DoDot:1

 +7                SET XDA=0

                   FOR 

                       SET XDA=$ORDER(^BARCB(DUZ(2),"B",BL,XDA))

                       IF XDA=""

                           QUIT 

                       Begin DoDot:2

 +8                        SET ADOS=$PIECE($GET(^BARBL(DUZ(2),XDA,1)),U,2)

 +9                        IF ADOS'=UDOS

                               QUIT 

 +10                       SET APNM=$$GET1^DIQ(90050.01,XDA,101)

 +11                       SET APLK=$PIECE(APNM,",")_$EXTRACT($PIECE(APNM,",",2),1,2)

 +12                       SET UPLK=$PIECE(UPNM,",")_$EXTRACT($PIECE(UPNM,",",2),1,2)

 +13                       IF UPLK'=APLK

                               QUIT 

 +14                       SET BHLXBILL=XDA

 +15                       SET XIEN("BILL IEN")=BHLXBILL

 +16                       SET XIEN("AR DOS")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,1)),U,2)

 +17                       SET XIEN("AR PAT")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,1)),U)

 +18                       SET XIEN("AR AMOUNT")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,0)),U,13)

 +19                       SET XIEN("AR BAL")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,0)),U,15)

                       End DoDot:2

               End DoDot:1

               QUIT 

 +20       IF BHLXCNT=1

               SET BHLXBILL=$ORDER(^BARBL(DUZ(2),"B",BL,0))

 +21       IF '$GET(BHLXBILL)

               KILL ADOS,APNM

 +22       SET BHLXBMT=1

 +23       SET XIEN("BILL IEN")=BHLXBILL

 +24       SET XIEN("AR DOS")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,1)),U,2)

 +25       SET XIEN("AR PAT")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,1)),U)

 +26       SET XIEN("AR AMOUNT")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,0)),U,13)

 +27       SET XIEN("AR BAL")=$PIECE($GET(^BARBL(DUZ(2),BHLXBILL,0)),U,15)

 +28       KILL ADOS,APNM

 +29       QUIT 

 +30      ;

ARADJ(ARC) ;-- lookup a/r reason code

 +1        IF ARC=""

               QUIT ""

 +2        IF ARC?.N

               SET ARC=+ARC

 +3        SET BHLXAIEN=$ORDER(^BARADJ("B",ARC,0))

 +4        IF 'BHLXAIEN

               QUIT ""

 +5        QUIT $PIECE($GET(^BARADJ(BHLXAIEN,0)),U,3)_"/"_$PIECE($GET(^BARADJ(BHLXAIEN,0)),U,4)

 +6       ;

EOJ       ;-- kill vars

 +1        KILL ^BHLX835($JOB)

 +2        KILL ^BHLX835V($JOB)

 +3        DO EN^XBVK("BHLX")

 +4        QUIT 

 +5       ;