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 ;
