- 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
