ABMAPAS1 ; IHS/ASDST/DMJ - PASS INFO TO A/R ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;
; IHS/SD/SDR - v2.5 p10 - IM20395
; Split out lines bundled by rev code
;
; IHS/SD/SDR - v2.6 CSV
;
START ;START HERE
Q:X'="A"&(X'="X")&(X'="B")
Q:'$L($T(TPB^BARUP))
K ABMA
S (ABMA("BLDA"),ABMP("BDFN"))=DA
S ABMA("ACTION")=X S:X="X" ABMA("ACTION")="C"
N I F I=1:1 S ABMA("LINE")=$T(TXT+I) Q:ABMA("LINE")["END" D
.S ABMA("DR")=$P(ABMA("LINE"),";;",2)
.S ABMA($P(ABMA("LINE"),";;",3))=$$VALI^XBDIQ1(DIC,DA,ABMA("DR"))
.I ABMA("DR")=.17,ABMA("DTBILL") S ABMA("DTBILL")=$$VALI^XBDIQ1(^DIC(9002274.6,0,"GL"),ABMA("DTBILL"),.01)
I ABMA("ACTION")="B",ABMA("DTBILL")="" S ABMA("DTBILL")=DT
D BLNM
N I,DA,K S K=0 F I=21,23,25,27,33,35,37,39,43 D
.K ABM,ABMRV
.D @(I_"^ABMERGR2")
.Q:'$D(ABMRV)
.D CONV
D ORV^ABMERGRV N I S I=.97 D CONV
N ABME D
.S ABMP("ITYPE")=$P($G(^AUTNINS(+ABMA("INS"),2)),"^",1) D ISET^ABMERUTL,CONV2 K ABMP("SET")
.S ABMP("PDFN")=ABMA("PTNM")
.S ABME("INS")=ABMA("INS") D EN^XBNEW("ISET^ABMERINS","ABME,ABMP,ABMR") S ABMA("POLH")=$G(ABME("PHNM")),ABMA("POLN")=$G(ABMR(30,70))
D PROV
S ABMA("CREDIT")=$$TCR^ABMERUTL(ABMP("BDFN"))
K ABMA("LINE"),ABMA("DR"),ABMA("DA")
I $P($G(^AUTNINS(ABMA("INS"),2)),"^",1)="N" S ABMA("INS")=""
D TPB^BARUP(.ABMA)
K ABMA,ABM,ABMR
Q
BLNM ;BILL NAME
I $P($G(^ABMDPARM(DUZ(2),1,2)),"^",4)]"" S ABMA("BLNM")=ABMA("BLNM")_"-"_$P(^(2),"^",4)
I $P($G(^ABMDPARM(DUZ(2),1,3)),"^",3) D
.S ABM("HRN")=$P($G(^AUPNPAT(ABMA("PTNM"),41,ABMA("VSLC"),0)),"^",2)
.S:ABM("HRN")]"" ABMA("BLNM")=ABMA("BLNM")_"-"_ABM("HRN")
Q
CONV ;CONVERT ABMRV ARRAY TO ABMA ARRAY
N L,J
S L=-1
F S L=$O(ABMRV(L)) Q:L="" D
.S J=-1
.F S J=$O(ABMRV(L,J)) Q:J="" D
..S M=0
..F S M=$O(ABMRV(L,J,M)) Q:M="" D
...S K=K+1
...S ABMA(K,"DOS")=""
...S ABMA(K,"BLSRV")=$P(^DD(9002274.4,I,0),U)
...S ABMA(K,"BLSRV")=$$UPC^ABMERUTL(ABMA(K,"BLSRV"))
...S ABMA(K,"ITCODE")=L
...S ABMA(K,"ITQT")=$P(ABMRV(L,J,M),U,5)
...S ABMA(K,"ITUC")=$P(ABMRV(L,J,M),U,6)
...I I=23 D
....S ABMA(K,"OTUC")=ABM(5),ABMA(K,"OTIT")="DISPENSE FEE"
....S ABMA(K,"ITUC")=ABMA(K,"ITUC")-ABM(5)
...I I=25 S ABMA(K,"ITNM")=$P($G(^AUTTREVN(L,0)),U,2)
...I J,I'=33 D
....S ABMA(K,"ITNM")=$P($$CPT^ABMCVAPI(J,$P(ABMRV(L,J,M),U,10),ABMP("VDT")),U,3) ;CSV-c
....S ABMA(K,"ITCODE")=J
...I J,I=33 D
....S ABMA(K,"ITCODE")=$P(ABMRV(L,J,M),U,2)
...S:$P(ABMRV(L,J,M),U,9)'="" ABMA(K,"ITNM")=$P(ABMRV(L,J,M),U,9)
...S:$P(ABMRV(L,J,M),U,10) ABMA(K,"DOS")=$P(ABMRV(L,J,M),U,10)
...I '$G(ABMA(K,"ITQT")) S ABMA(K,"ITUC")=0 Q
...S ABMA(K,"ITUC")=$J(ABMA(K,"ITUC")/ABMA(K,"ITQT"),1,3)
Q
CONV2 ;CONVERT INSURER ARRAY
F I=1:1:3 D
.Q:'$D(ABMP("INS",I))
.Q:ABMA("ACTION")="C"
.S:+ABMP("INS",I)=ABMA("INS") ABMA("ACTION")=I
.S:$P($G(^AUTNINS(+ABMP("INS",I),0)),"^",1)="N" ABMP("INS",I)=""
S ABMA("PRIM")=$P($G(ABMP("INS",1)),"^",1)
S ABMA("SEC")=$P($G(ABMP("INS",2)),"^",1)
S ABMA("TERT")=$P($G(ABMP("INS",3)),"^",1)
Q
PROV ;GET ATTENDING PROVIDER
S ABMA("PROV")=""
N I S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
Q:'I
N J S J=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,I,0),"^",1)
S ABMA("PROV")=J
Q
TXT ;FIELDS
;;.01;;BLNM
;;.03;;VSLC
;;.05;;PTNM
;;.07;;VSTP
;;.08;;INS
;;.1;;CLNC
;;.15;;DTAP
;;.17;;DTBILL
;;.21;;BLAMT
;;.71;;DOSB
;;.72;;DOSE
;;END
EXT ;EP - EXTERNAL CALL (NEEDS DA DEFINED)
S DIC="^ABMDBILL(DUZ(2),"
S X="A"
D START
K ABM,ABMP,ABMA,ABME
Q
ABMAPAS1 ; IHS/ASDST/DMJ - PASS INFO TO A/R ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;
+3 ; IHS/SD/SDR - v2.5 p10 - IM20395
+4 ; Split out lines bundled by rev code
+5 ;
+6 ; IHS/SD/SDR - v2.6 CSV
+7 ;
START ;START HERE
+1 IF X'="A"&(X'="X")&(X'="B")
QUIT
+2 IF '$LENGTH($TEXT(TPB^BARUP))
QUIT
+3 KILL ABMA
+4 SET (ABMA("BLDA"),ABMP("BDFN"))=DA
+5 SET ABMA("ACTION")=X
IF X="X"
SET ABMA("ACTION")="C"
+6 NEW I
FOR I=1:1
SET ABMA("LINE")=$TEXT(TXT+I)
IF ABMA("LINE")["END"
QUIT
Begin DoDot:1
+7 SET ABMA("DR")=$PIECE(ABMA("LINE"),";;",2)
+8 SET ABMA($PIECE(ABMA("LINE"),";;",3))=$$VALI^XBDIQ1(DIC,DA,ABMA("DR"))
+9 IF ABMA("DR")=.17
IF ABMA("DTBILL")
SET ABMA("DTBILL")=$$VALI^XBDIQ1(^DIC(9002274.6,0,"GL"),ABMA("DTBILL"),.01)
End DoDot:1
+10 IF ABMA("ACTION")="B"
IF ABMA("DTBILL")=""
SET ABMA("DTBILL")=DT
+11 DO BLNM
+12 NEW I,DA,K
SET K=0
FOR I=21,23,25,27,33,35,37,39,43
Begin DoDot:1
+13 KILL ABM,ABMRV
+14 DO @(I_"^ABMERGR2")
+15 IF '$DATA(ABMRV)
QUIT
+16 DO CONV
End DoDot:1
+17 DO ORV^ABMERGRV
NEW I
SET I=.97
DO CONV
+18 NEW ABME
Begin DoDot:1
+19 SET ABMP("ITYPE")=$PIECE($GET(^AUTNINS(+ABMA("INS"),2)),"^",1)
DO ISET^ABMERUTL
DO CONV2
KILL ABMP("SET")
+20 SET ABMP("PDFN")=ABMA("PTNM")
+21 SET ABME("INS")=ABMA("INS")
DO EN^XBNEW("ISET^ABMERINS","ABME,ABMP,ABMR")
SET ABMA("POLH")=$GET(ABME("PHNM"))
SET ABMA("POLN")=$GET(ABMR(30,70))
End DoDot:1
+22 DO PROV
+23 SET ABMA("CREDIT")=$$TCR^ABMERUTL(ABMP("BDFN"))
+24 KILL ABMA("LINE"),ABMA("DR"),ABMA("DA")
+25 IF $PIECE($GET(^AUTNINS(ABMA("INS"),2)),"^",1)="N"
SET ABMA("INS")=""
+26 DO TPB^BARUP(.ABMA)
+27 KILL ABMA,ABM,ABMR
+28 QUIT
BLNM ;BILL NAME
+1 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,2)),"^",4)]""
SET ABMA("BLNM")=ABMA("BLNM")_"-"_$PIECE(^(2),"^",4)
+2 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,3)),"^",3)
Begin DoDot:1
+3 SET ABM("HRN")=$PIECE($GET(^AUPNPAT(ABMA("PTNM"),41,ABMA("VSLC"),0)),"^",2)
+4 IF ABM("HRN")]""
SET ABMA("BLNM")=ABMA("BLNM")_"-"_ABM("HRN")
End DoDot:1
+5 QUIT
CONV ;CONVERT ABMRV ARRAY TO ABMA ARRAY
+1 NEW L,J
+2 SET L=-1
+3 FOR
SET L=$ORDER(ABMRV(L))
IF L=""
QUIT
Begin DoDot:1
+4 SET J=-1
+5 FOR
SET J=$ORDER(ABMRV(L,J))
IF J=""
QUIT
Begin DoDot:2
+6 SET M=0
+7 FOR
SET M=$ORDER(ABMRV(L,J,M))
IF M=""
QUIT
Begin DoDot:3
+8 SET K=K+1
+9 SET ABMA(K,"DOS")=""
+10 SET ABMA(K,"BLSRV")=$PIECE(^DD(9002274.4,I,0),U)
+11 SET ABMA(K,"BLSRV")=$$UPC^ABMERUTL(ABMA(K,"BLSRV"))
+12 SET ABMA(K,"ITCODE")=L
+13 SET ABMA(K,"ITQT")=$PIECE(ABMRV(L,J,M),U,5)
+14 SET ABMA(K,"ITUC")=$PIECE(ABMRV(L,J,M),U,6)
+15 IF I=23
Begin DoDot:4
+16 SET ABMA(K,"OTUC")=ABM(5)
SET ABMA(K,"OTIT")="DISPENSE FEE"
+17 SET ABMA(K,"ITUC")=ABMA(K,"ITUC")-ABM(5)
End DoDot:4
+18 IF I=25
SET ABMA(K,"ITNM")=$PIECE($GET(^AUTTREVN(L,0)),U,2)
+19 IF J
IF I'=33
Begin DoDot:4
+20 ;CSV-c
SET ABMA(K,"ITNM")=$PIECE($$CPT^ABMCVAPI(J,$PIECE(ABMRV(L,J,M),U,10),ABMP("VDT")),U,3)
+21 SET ABMA(K,"ITCODE")=J
End DoDot:4
+22 IF J
IF I=33
Begin DoDot:4
+23 SET ABMA(K,"ITCODE")=$PIECE(ABMRV(L,J,M),U,2)
End DoDot:4
+24 IF $PIECE(ABMRV(L,J,M),U,9)'=""
SET ABMA(K,"ITNM")=$PIECE(ABMRV(L,J,M),U,9)
+25 IF $PIECE(ABMRV(L,J,M),U,10)
SET ABMA(K,"DOS")=$PIECE(ABMRV(L,J,M),U,10)
+26 IF '$GET(ABMA(K,"ITQT"))
SET ABMA(K,"ITUC")=0
QUIT
+27 SET ABMA(K,"ITUC")=$JUSTIFY(ABMA(K,"ITUC")/ABMA(K,"ITQT"),1,3)
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
CONV2 ;CONVERT INSURER ARRAY
+1 FOR I=1:1:3
Begin DoDot:1
+2 IF '$DATA(ABMP("INS",I))
QUIT
+3 IF ABMA("ACTION")="C"
QUIT
+4 IF +ABMP("INS",I)=ABMA("INS")
SET ABMA("ACTION")=I
+5 IF $PIECE($GET(^AUTNINS(+ABMP("INS",I),0)),"^",1)="N"
SET ABMP("INS",I)=""
End DoDot:1
+6 SET ABMA("PRIM")=$PIECE($GET(ABMP("INS",1)),"^",1)
+7 SET ABMA("SEC")=$PIECE($GET(ABMP("INS",2)),"^",1)
+8 SET ABMA("TERT")=$PIECE($GET(ABMP("INS",3)),"^",1)
+9 QUIT
PROV ;GET ATTENDING PROVIDER
+1 SET ABMA("PROV")=""
+2 NEW I
SET I=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
+3 IF 'I
QUIT
+4 NEW J
SET J=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,I,0),"^",1)
+5 SET ABMA("PROV")=J
+6 QUIT
TXT ;FIELDS
+1 ;;.01;;BLNM
+2 ;;.03;;VSLC
+3 ;;.05;;PTNM
+4 ;;.07;;VSTP
+5 ;;.08;;INS
+6 ;;.1;;CLNC
+7 ;;.15;;DTAP
+8 ;;.17;;DTBILL
+9 ;;.21;;BLAMT
+10 ;;.71;;DOSB
+11 ;;.72;;DOSE
+12 ;;END
EXT ;EP - EXTERNAL CALL (NEEDS DA DEFINED)
+1 SET DIC="^ABMDBILL(DUZ(2),"
+2 SET X="A"
+3 DO START
+4 KILL ABM,ABMP,ABMA,ABME
+5 QUIT
