- ABMDF3D ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 4 ;
- ;;2.6;IHS 3P BILLING SYSTEM;**14**;NOV 12, 2009;Build 238
- ;Original;TMD;
- ; IHS/SD/LSL - 11/18/02 - V2.5 Patch 2 - NOIS CGA-1102-110054
- ; Resolve <UNDEF>54+2^ABMDBLK
- ; IHS/SD/SDR - v2.5 p8 - task 6
- ; Added code for modifier changes if ambulance and QL
- ; IHS/SD/SDR - v2.5 p10 - block 29
- ; Added code to check new flag for printing block 29
- ; IHS/SD/SDR - v2.5 p12 - IM24880
- ; Made change for number of line items printing per page
- ;
- ; IHS/SD/SDR - v2.6 CSV
- ;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI call to be numeric
- ;
- ; ********************************************************************
- ;
- 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 ;abm*2.6*14 updated API call
- .S ABM("DIAG")=$P($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2) ;CSV-c ;abm*2.6*14 updated API call
- .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^ABMDF3E
- 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
- .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
- ..M ABMF(ABMS("I"))=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),U)=$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),U)=$P($G(^VA(200,+$P(ABM("A"),"^",2),20)),"^",2)
- .S:$P(ABMF(52),U)="" $P(ABMF(52),U)=$P(ABM("A"),U)
- .S $P(ABMF(53),U)=ABM("PNUM")
- PDT ;
- S $P(ABMF(54),U)=$$SDTO^ABMDUTL(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
- ABMDF3D ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 4 ;
- +1 ;;2.6;IHS 3P BILLING SYSTEM;**14**;NOV 12, 2009;Build 238
- +2 ;Original;TMD;
- +3 ; IHS/SD/LSL - 11/18/02 - V2.5 Patch 2 - NOIS CGA-1102-110054
- +4 ; Resolve <UNDEF>54+2^ABMDBLK
- +5 ; IHS/SD/SDR - v2.5 p8 - task 6
- +6 ; Added code for modifier changes if ambulance and QL
- +7 ; IHS/SD/SDR - v2.5 p10 - block 29
- +8 ; Added code to check new flag for printing block 29
- +9 ; IHS/SD/SDR - v2.5 p12 - IM24880
- +10 ; Made change for number of line items printing per page
- +11 ;
- +12 ; IHS/SD/SDR - v2.6 CSV
- +13 ;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI call to be numeric
- +14 ;
- +15 ; ********************************************************************
- +16 ;
- 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 ;S ABM("DIAG")=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2) ;CSV-c ;abm*2.6*14 updated API call
- +10 ;CSV-c ;abm*2.6*14 updated API call
- SET ABM("DIAG")=$PIECE($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2)
- +11 SET $PIECE(ABMF(ABM("ID")),U,ABM("TB"))=ABM("DIAG")_" "_ABM(9)
- +12 SET ABMP("DX",ABM("DIAG"))=ABM("I")-30
- End DoDot:1
- +13 ;
- 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^ABMDF3E
- +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 FOR
- SET ABMPRT=$ORDER(ABMR(ABMLN,ABMPRT))
- IF +ABMPRT=0
- QUIT
- Begin DoDot:2
- +15 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
- +16 MERGE ABMF(ABMS("I"))=ABMR(ABMLN,ABMPRT)
- +17 SET ABMS("I")=ABMS("I")+1
- +18 KILL ABMR(ABMLN,ABMPRT)
- End DoDot:2
- End DoDot:1
- IF $GET(ABM("QUIT"))
- QUIT
- +19 ;
- +20 DO PREV^ABMDFUTL
- +21 SET ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$SELECT($PIECE(^(2),U,3):$PIECE(^(2),U,3),1:1)
- +22 IF ABM("RATIO")>1
- SET ABM("RATIO")=1
- +23 SET ABM("W")=+$FNUMBER(ABMP("WO")*ABM("RATIO"),"",2)
- +24 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,17)="DO"
- Begin DoDot:1
- +25 SET $PIECE(ABMF(49),U,8)=+$FNUMBER(ABMP("PD")*ABM("RATIO"),"",2)+ABM("W")
- End DoDot:1
- +26 SET ABM("OB")=ABMS("TOT")-$PIECE(ABMF(49),U,8)
- +27 IF ABM("OB")<0
- SET ABM("OB")=0
- +28 SET ABM("YTOT")=ABM("OB")
- +29 DO YTOT^ABMDFUTL
- +30 ; Total Charges
- SET $PIECE(ABMF(49),U,7)=ABMS("TOT")
- +31 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,17)="DO"
- Begin DoDot:1
- +32 SET $PIECE(ABMF(49),U,8)=+$FNUMBER(ABMP("PD"),"",2)
- End DoDot:1
- +33 ; Amount Due
- +34 IF $DATA(ABMP("BILL"))
- SET $PIECE(ABMF(49),U,9)=+$FNUMBER(ABMP("BILL"),"",2)
- +35 IF '$TEST
- SET $PIECE(ABMF(49),U,9)=+$FNUMBER(ABMS("TOT")-ABMP("PD"),"",2)-$GET(ABMP("PENS"))-$GET(ABMP("NONC"))
- +36 KILL ABMS
- +37 IF $DATA(ABMR)
- Begin DoDot:1
- +38 SET ABMR("TOT")=$PIECE(ABMF(49),U,7,9)
- +39 SET $PIECE(ABMF(49),U,7)=""
- SET $PIECE(ABMF(49),U,8)=""
- SET $PIECE(ABMF(49),U,9)=""
- End DoDot:1
- +40 ;
- 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),U)=$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),U)=$PIECE($GET(^VA(200,+$PIECE(ABM("A"),"^",2),20)),"^",2)
- +17 IF $PIECE(ABMF(52),U)=""
- SET $PIECE(ABMF(52),U)=$PIECE(ABM("A"),U)
- +18 SET $PIECE(ABMF(53),U)=ABM("PNUM")
- End DoDot:1
- PDT ;
- +1 SET $PIECE(ABMF(54),U)=$$SDTO^ABMDUTL(DT)
- +2 SET ABMFLAG=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,20)
- +3 IF ABMFLAG["PRO"
- IF $DATA(ABM("A"))
- Begin DoDot:1
- +4 SET ABM("PRO")=$PIECE(ABM("A"),U,2)
- +5 SET $PIECE(ABMF(54),U,3)=$PIECE($GET(^VA(200,ABM("PRO"),9999999.18,ABMP("INS"),0)),U,2)
- +6 SET $PIECE(ABMF(54),U,4)=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
- End DoDot:1
- +7 IF ABMFLAG["LOC"
- Begin DoDot:1
- +8 ; provider number from insurer file
- +9 SET $PIECE(ABMF(54),U,3)=$PIECE($GET(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
- +10 ; insurer assigned number form 3p insurer file
- +11 SET $PIECE(ABMF(54),U,4)=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
- End DoDot:1
- +12 ; default to this if the block 33 was left blank
- +13 IF $GET(ABMFLAG)=""
- DO 54^ABMDBLK
- +14 ;
- XIT KILL ABM,ABMV,ABMX,ABMPRINT
- +1 QUIT
