ABMDF14D ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 4 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
; IHS/SD/LSL - 11/18/02 - V2.5 Patch 2 - NOIS CGA-1102-110054
; Modified PRV linetag to loop Provider multiple of bill file
; and and set ABM(prv typ) array before any other conditions.
; Resolves <UNDEF>54+2^ABMDBLK
; IHS/SD/SDR - v2.5 p8 - task 6
; printing of mods when ambulance and QL
; IHS/SD/SDR - v2.5 p9 - IM10625
; Correction to block 31 and site parameter
; IHS/SD/SDR - v2.5 p9 - IM19392
; Remove population of FL 29; causing problems with Medicare payments
; IHS/SD/SDR - v2.5 p10 - IM20197
; Don't allow 2-line items to print on two pages
; IHS/SD/SDR - v2.5 p10 - block 29
; Added code to check new flag for printing block 29 or not
;
; IHS/SD/SDR - v2.6 - CSV
;
; *********************************************************************
;
DX ; Diagnosis Info
K ABMP("DX")
S ABM="" F ABM("I")=31:1:34 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM)) Q:'ABM D
.S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM,""))
.S ABM(9)=$P(^AUTNPOV($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U,3),0),U)
.S ABM(9)=$S(ABM(9)["*ICD*":$P(ABM(9)," "),1:ABM(9))
.S ABM("ID")=$S(ABM("I")=32:33,ABM("I")=34:33,1:31)
.S ABM("TB")=$S(ABM("I")<33:1,1:2)
.S ABM(9)=""
.S ABM("DIAG")=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2) ;CSV-c
.S $P(ABMF(ABM("ID")),U,ABM("TB"))=ABM("DIAG")_" "_ABM(9)
.S ABMP("DX",ABM("DIAG"))=ABM("I")-30
;
ST S ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
S ABMPRINT=1 D ^ABMDESM1
I $P($G(^DIC(40.7,$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)),U,10),0)),U,2)="A3" D
.S ABMI=0
.F S ABMI=$O(ABMS(ABMI)) Q:'ABMI D
..I $P($P(ABMS(ABMI),U,4),"-",2)="QL" S ABMQLFLG=1
..S ABMODMOD=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,14)_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,16)
.S ABMI=0
.F S ABMI=$O(ABMS(ABMI)) Q:'ABMI D
..I $G(ABMQLFLG)=1,($P($P(ABMS(ABMI),U,4),"-",2)'="QL") S $P(ABMS(ABMI),U,4)=$P($P(ABMS(ABMI),U,4),"-")
..I $G(ABMQLFLG)'=1 S $P(ABMS(ABMI),U,4)=$P($P(ABMS(ABMI),U,4),"-")_$P($P(ABMS(ABMI),U,4),"-",2)_"-"_ABMODMOD
K ABMQLFLG
HCFA ;
I $P(^ABMDBILL(DUZ(2),ABMP("BDFN"),2),U)=0 S ABMS("TOT")=0
D EMG^ABMDF14E
S ABMS=0
F S ABMS=$O(ABMS(ABMS)) Q:+ABMS=0 D
.S ABMLN=2
.D PROC^ABMDF14E
.S ABMLN=ABMLN+1
S ABMLN=0,ABMPRT=0
F ABMS("I")=37:1:47 D Q:$G(ABM("QUIT"))
.S ABMLN=$O(ABMR(ABMLN))
.I 'ABMLN S ABM("QUIT")=1 Q
.S ABMPRT=0
.I (($O(ABMR(ABMLN,9),-1))+(ABMS("I")))>49 Q
.S ABMLNCT=$O(ABMR(ABMLN,0),-1)
.F S ABMPRT=$O(ABMR(ABMLN,ABMPRT)) Q:+ABMPRT=0 D
..I +$O(ABMR(ABMLN,ABMPRT))'=0,($G(ABMF(ABMS("I")-1))=""),(ABMS("I")#2=1),ABMS("I")=37 S ABMS("I")=ABMS("I")-1
..I ABMLNCT=3,(ABMPRT'=3) M ABMF(ABMS("I")-1)=ABMR(ABMLN,ABMPRT)
..E M ABMF(ABMS("I")-1)=ABMR(ABMLN,ABMPRT)
..S ABMS("I")=ABMS("I")+1
..K ABMR(ABMLN,ABMPRT)
;
D PREV^ABMDFUTL
S ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$S($P(^(2),U,3):$P(^(2),U,3),1:1)
S:ABM("RATIO")>1 ABM("RATIO")=1
S ABM("W")=+$FN(ABMP("WO")*ABM("RATIO"),"",2)
I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,17)="DO" D
.S $P(ABMF(49),U,8)=+$FN(ABMP("PD")*ABM("RATIO"),"",2)+ABM("W")
S ABM("OB")=ABMS("TOT")-$P(ABMF(49),U,8)
S:ABM("OB")<0 ABM("OB")=0
S ABM("YTOT")=ABM("OB")
D YTOT^ABMDFUTL
S $P(ABMF(49),U,7)=ABMS("TOT") ; Total Charges
I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,17)="DO" D
.S $P(ABMF(49),U,8)=+$FN(ABMP("PD"),"",2)
; Amount Due
I $D(ABMP("BILL")) S $P(ABMF(49),U,9)=+$FN(ABMP("BILL"),"",2)
E S $P(ABMF(49),U,9)=+$FN(ABMS("TOT")-ABMP("PD"),"",2)-$G(ABMP("PENS"))-$G(ABMP("NONC"))
K ABMS
I $D(ABMR) D
.S ABMR("TOT")=$P(ABMF(49),U,7,9)
.S $P(ABMF(49),U,7)="",$P(ABMF(49),U,8)="",$P(ABMF(49),U,9)=""
;
PRV ; Provider Info
I $P($G(^ABMDPARM(DUZ(2),1,0)),"^",17)=3 D G PDT
.S ABM("SIGN")=$P($G(^ABMDPARM(DUZ(2),1,3)),"^",7)
.I ABM("SIGN")="" D
..S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0)) D
...Q:'ABM("X")
...D SELBILL^ABMDE4X
...S ABM("SIGN")=$P(ABM("A"),U,2)
.E D
..S ABM("A")=$P($G(^VA(200,+ABM("SIGN"),20)),"^",2)_"^"_+ABM("SIGN")
.S $P(ABMF(53),"^",1)=$P($G(^VA(200,+ABM("SIGN"),20)),"^",2)
I $P($G(^ABMDPARM(DUZ(2),1,0)),U,17)=2 D G PDT
.S $P(ABMF(53),U)=$P($G(^VA(200,$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),1),U,4),20)),"^",2)
S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0)) D
.Q:'ABM("X")
.D SELBILL^ABMDE4X
.S $P(ABMF(52),"^",1)=$P($G(^VA(200,+$P(ABM("A"),"^",2),20)),"^",2)
.S:$P(ABMF(52),"^",1)="" $P(ABMF(52),U)=$P(ABM("A"),U)
.S $P(ABMF(53),U)=ABM("PNUM")
PDT S $P(ABMF(54),U)=DT
S ABMFLAG=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,20)
I ABMFLAG["PRO",$D(ABM("A")) D
.S ABM("PRO")=$P(ABM("A"),U,2)
.S $P(ABMF(54),U,3)=$P($G(^VA(200,ABM("PRO"),9999999.18,ABMP("INS"),0)),U,2)
.S $P(ABMF(54),U,4)=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
I ABMFLAG["LOC" D
.; provider number from insurer file
.S $P(ABMF(54),U,3)=$P($G(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
.; insurer assigned number form 3p insurer file
.S $P(ABMF(54),U,4)=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
; default to this if the block 33 was left blank
I $G(ABMFLAG)="" D 54^ABMDBLK
;
XIT K ABM,ABMV,ABMX,ABMPRINT
Q
ABMDF14D ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 4 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ; IHS/SD/LSL - 11/18/02 - V2.5 Patch 2 - NOIS CGA-1102-110054
+4 ; Modified PRV linetag to loop Provider multiple of bill file
+5 ; and and set ABM(prv typ) array before any other conditions.
+6 ; Resolves <UNDEF>54+2^ABMDBLK
+7 ; IHS/SD/SDR - v2.5 p8 - task 6
+8 ; printing of mods when ambulance and QL
+9 ; IHS/SD/SDR - v2.5 p9 - IM10625
+10 ; Correction to block 31 and site parameter
+11 ; IHS/SD/SDR - v2.5 p9 - IM19392
+12 ; Remove population of FL 29; causing problems with Medicare payments
+13 ; IHS/SD/SDR - v2.5 p10 - IM20197
+14 ; Don't allow 2-line items to print on two pages
+15 ; IHS/SD/SDR - v2.5 p10 - block 29
+16 ; Added code to check new flag for printing block 29 or not
+17 ;
+18 ; IHS/SD/SDR - v2.6 - CSV
+19 ;
+20 ; *********************************************************************
+21 ;
DX ; Diagnosis Info
+1 KILL ABMP("DX")
+2 SET ABM=""
FOR ABM("I")=31:1:34
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM))
IF 'ABM
QUIT
Begin DoDot:1
+3 SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM,""))
+4 SET ABM(9)=$PIECE(^AUTNPOV($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U,3),0),U)
+5 SET ABM(9)=$SELECT(ABM(9)["*ICD*":$PIECE(ABM(9)," "),1:ABM(9))
+6 SET ABM("ID")=$SELECT(ABM("I")=32:33,ABM("I")=34:33,1:31)
+7 SET ABM("TB")=$SELECT(ABM("I")<33:1,1:2)
+8 SET ABM(9)=""
+9 ;CSV-c
SET ABM("DIAG")=$PIECE($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2)
+10 SET $PIECE(ABMF(ABM("ID")),U,ABM("TB"))=ABM("DIAG")_" "_ABM(9)
+11 SET ABMP("DX",ABM("DIAG"))=ABM("I")-30
End DoDot:1
+12 ;
ST SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
+1 SET ABMPRINT=1
DO ^ABMDESM1
+2 IF $PIECE($GET(^DIC(40.7,$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)),U,10),0)),U,2)="A3"
Begin DoDot:1
+3 SET ABMI=0
+4 FOR
SET ABMI=$ORDER(ABMS(ABMI))
IF 'ABMI
QUIT
Begin DoDot:2
+5 IF $PIECE($PIECE(ABMS(ABMI),U,4),"-",2)="QL"
SET ABMQLFLG=1
+6 SET ABMODMOD=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,14)_$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,16)
End DoDot:2
+7 SET ABMI=0
+8 FOR
SET ABMI=$ORDER(ABMS(ABMI))
IF 'ABMI
QUIT
Begin DoDot:2
+9 IF $GET(ABMQLFLG)=1
IF ($PIECE($PIECE(ABMS(ABMI),U,4),"-",2)'="QL")
SET $PIECE(ABMS(ABMI),U,4)=$PIECE($PIECE(ABMS(ABMI),U,4),"-")
+10 IF $GET(ABMQLFLG)'=1
SET $PIECE(ABMS(ABMI),U,4)=$PIECE($PIECE(ABMS(ABMI),U,4),"-")_$PIECE($PIECE(ABMS(ABMI),U,4),"-",2)_"-"_ABMODMOD
End DoDot:2
End DoDot:1
+11 KILL ABMQLFLG
HCFA ;
+1 IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),2),U)=0
SET ABMS("TOT")=0
+2 DO EMG^ABMDF14E
+3 SET ABMS=0
+4 FOR
SET ABMS=$ORDER(ABMS(ABMS))
IF +ABMS=0
QUIT
Begin DoDot:1
+5 SET ABMLN=2
+6 DO PROC^ABMDF14E
+7 SET ABMLN=ABMLN+1
End DoDot:1
+8 SET ABMLN=0
SET ABMPRT=0
+9 FOR ABMS("I")=37:1:47
Begin DoDot:1
+10 SET ABMLN=$ORDER(ABMR(ABMLN))
+11 IF 'ABMLN
SET ABM("QUIT")=1
QUIT
+12 SET ABMPRT=0
+13 IF (($ORDER(ABMR(ABMLN,9),-1))+(ABMS("I")))>49
QUIT
+14 SET ABMLNCT=$ORDER(ABMR(ABMLN,0),-1)
+15 FOR
SET ABMPRT=$ORDER(ABMR(ABMLN,ABMPRT))
IF +ABMPRT=0
QUIT
Begin DoDot:2
+16 IF +$ORDER(ABMR(ABMLN,ABMPRT))'=0
IF ($GET(ABMF(ABMS("I")-1))="")
IF (ABMS("I")#2=1)
IF ABMS("I")=37
SET ABMS("I")=ABMS("I")-1
+17 IF ABMLNCT=3
IF (ABMPRT'=3)
MERGE ABMF(ABMS("I")-1)=ABMR(ABMLN,ABMPRT)
+18 IF '$TEST
MERGE ABMF(ABMS("I")-1)=ABMR(ABMLN,ABMPRT)
+19 SET ABMS("I")=ABMS("I")+1
+20 KILL ABMR(ABMLN,ABMPRT)
End DoDot:2
End DoDot:1
IF $GET(ABM("QUIT"))
QUIT
+21 ;
+22 DO PREV^ABMDFUTL
+23 SET ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$SELECT($PIECE(^(2),U,3):$PIECE(^(2),U,3),1:1)
+24 IF ABM("RATIO")>1
SET ABM("RATIO")=1
+25 SET ABM("W")=+$FNUMBER(ABMP("WO")*ABM("RATIO"),"",2)
+26 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,17)="DO"
Begin DoDot:1
+27 SET $PIECE(ABMF(49),U,8)=+$FNUMBER(ABMP("PD")*ABM("RATIO"),"",2)+ABM("W")
End DoDot:1
+28 SET ABM("OB")=ABMS("TOT")-$PIECE(ABMF(49),U,8)
+29 IF ABM("OB")<0
SET ABM("OB")=0
+30 SET ABM("YTOT")=ABM("OB")
+31 DO YTOT^ABMDFUTL
+32 ; Total Charges
SET $PIECE(ABMF(49),U,7)=ABMS("TOT")
+33 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,17)="DO"
Begin DoDot:1
+34 SET $PIECE(ABMF(49),U,8)=+$FNUMBER(ABMP("PD"),"",2)
End DoDot:1
+35 ; Amount Due
+36 IF $DATA(ABMP("BILL"))
SET $PIECE(ABMF(49),U,9)=+$FNUMBER(ABMP("BILL"),"",2)
+37 IF '$TEST
SET $PIECE(ABMF(49),U,9)=+$FNUMBER(ABMS("TOT")-ABMP("PD"),"",2)-$GET(ABMP("PENS"))-$GET(ABMP("NONC"))
+38 KILL ABMS
+39 IF $DATA(ABMR)
Begin DoDot:1
+40 SET ABMR("TOT")=$PIECE(ABMF(49),U,7,9)
+41 SET $PIECE(ABMF(49),U,7)=""
SET $PIECE(ABMF(49),U,8)=""
SET $PIECE(ABMF(49),U,9)=""
End DoDot:1
+42 ;
PRV ; Provider Info
+1 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,0)),"^",17)=3
Begin DoDot:1
+2 SET ABM("SIGN")=$PIECE($GET(^ABMDPARM(DUZ(2),1,3)),"^",7)
+3 IF ABM("SIGN")=""
Begin DoDot:2
+4 SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
Begin DoDot:3
+5 IF 'ABM("X")
QUIT
+6 DO SELBILL^ABMDE4X
+7 SET ABM("SIGN")=$PIECE(ABM("A"),U,2)
End DoDot:3
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 SET ABM("A")=$PIECE($GET(^VA(200,+ABM("SIGN"),20)),"^",2)_"^"_+ABM("SIGN")
End DoDot:2
+10 SET $PIECE(ABMF(53),"^",1)=$PIECE($GET(^VA(200,+ABM("SIGN"),20)),"^",2)
End DoDot:1
GOTO PDT
+11 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,17)=2
Begin DoDot:1
+12 SET $PIECE(ABMF(53),U)=$PIECE($GET(^VA(200,$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),1),U,4),20)),"^",2)
End DoDot:1
GOTO PDT
+13 SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
Begin DoDot:1
+14 IF 'ABM("X")
QUIT
+15 DO SELBILL^ABMDE4X
+16 SET $PIECE(ABMF(52),"^",1)=$PIECE($GET(^VA(200,+$PIECE(ABM("A"),"^",2),20)),"^",2)
+17 IF $PIECE(ABMF(52),"^",1)=""
SET $PIECE(ABMF(52),U)=$PIECE(ABM("A"),U)
+18 SET $PIECE(ABMF(53),U)=ABM("PNUM")
End DoDot:1
PDT SET $PIECE(ABMF(54),U)=DT
+1 SET ABMFLAG=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,20)
+2 IF ABMFLAG["PRO"
IF $DATA(ABM("A"))
Begin DoDot:1
+3 SET ABM("PRO")=$PIECE(ABM("A"),U,2)
+4 SET $PIECE(ABMF(54),U,3)=$PIECE($GET(^VA(200,ABM("PRO"),9999999.18,ABMP("INS"),0)),U,2)
+5 SET $PIECE(ABMF(54),U,4)=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
End DoDot:1
+6 IF ABMFLAG["LOC"
Begin DoDot:1
+7 ; provider number from insurer file
+8 SET $PIECE(ABMF(54),U,3)=$PIECE($GET(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
+9 ; insurer assigned number form 3p insurer file
+10 SET $PIECE(ABMF(54),U,4)=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
End DoDot:1
+11 ; default to this if the block 33 was left blank
+12 IF $GET(ABMFLAG)=""
DO 54^ABMDBLK
+13 ;
XIT KILL ABM,ABMV,ABMX,ABMPRINT
+1 QUIT
