ABMDBADD ; IHS/SD/SDR - Add Bill Manually Submitted ;
;;2.6;IHS Third Party Billing;**1,9,21**;NOV 12, 2009;Build 379
;
DOC ;
; LSL - 12/30/97 - Modified for readability. Changed ABM array to ABMD array as
; ABMAPASS and A/R routines stomp all over ABM array. Also, add the storage of
; Approved Date and Time for A/R usage. Will be date and time bill is manually created.
; LSL - 1/23/98 - Added the storage of the 13 multiple to the bill file. Many other programs
; in 3PB and A/R assume it exists.
; LSL - 2/2/98 - Allow duplicate bills if user ok. Also allow multiple clinics on same visit date.
; LSL - 3/25/98 - Lost value of %, so set approval date variable sooner
;
; IHS/ASDS/SDH - 03/09/01 - V2.4 Patch 9 - NOIS LTA-0600-160017 - Modified to check if service
; thru date is less than service from date
;
; IHS/ASDS/SDH - 10/16/01 - V2.4 Patch 9 - NOIS UOB-0701-170024 - Modified to use ABM utility to
; get claim number so manually generated claims will have unique numbers. Also made gross
; amount the same as bill amount.
;
; IHS/SD/SDR - 9/26/2002 - V2.5 P2 - UOB-0102-170068 - Modified routine to do date check for future dates of
; service/admission
;
; IHS/SD/SDR - v2.5 p8 - IM11831 - Modified to prompt for visit location
;
; IHS/SD/SDR - v2.5 p12 - UFMS - If user isn't logged into cashiering session they can't do
; this option. Also added so if they enter a bill using this option it will add to cashiering session
; IHS/SD/SDR - abm*2.6*1 - HEAT7431 - <SUBSCR>V^DIED (vars from previous FM call still defined.
;IHS/SD/SDR - 2.6*21 - VMBP RQMT_111 - fixed insurer type code
;IHS/SD/SDR - 2.6*21 - HEAT175003 - Made change for <SUBSCR>ISET+33^ABMERUTL; occurs when trying to file elig pointer into record. There was no ';' to
; separate data
;
; *********************************************************************
;
START ;EP
K ABMD
W !!?5,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")
W " This program should only be utilized when an entry in the"
W !?11,"Accounts Receivable File is needed to reflect a bill that"
W !?11,"was manually prepared and submitted.",!
S DIR(0)="Y"
S DIR("A")="Proceed"
S DIR("B")="NO"
D ^DIR
K DIR
Q:Y'=1
;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup
I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)="" D Q
.W !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!
.S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
;end new code
I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1 D Q:+$G(ABMUOPNS)=0
.S ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)
.I +$G(ABMUOPNS)=0 D Q
..W !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!
..S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
;
ASK ; ask what visit location if Parent/Satellite is set up
S ABMARPS=$P($G(^ABMDPARM(DUZ(2),1,4)),U,9) ;A/R P/S?
I ABMARPS D
.K DIC
.S DIC="^BAR(90052.05,DUZ(2),"
.S DIC(0)="AME"
.S DIC("A")="Visit Location: "
.S DIC("B")=DUZ(2)
.D ^DIC
Q:$D(DUOUT)!$D(DTOUT)
Q:+Y<0
ADD ;
I ABMARPS D
.S ABMDUZ2=DUZ(2)
.S ABMUDUZ2=+Y
.S DUZ(2)=ABMUDUZ2
S ABMD("DFN")=$$NXNM^ABMDUTL
K DINUM
S DIC="^ABMDBILL(DUZ(2),"
S DIC(0)="L"
S X=ABMD("DFN")
K DD,DO D FILE^DICN ; Add entry to 3P BILL
I +Y<1 D G XIT
.W *7
.W !!,"ERROR: BILL NOT CREATED, ensure your Fileman ACCESS CODE contains a 'V'.",!!
S ABMD("DFN")=+Y ; 3P BILL ien
;
EDIT ;
L +^ABMDBILL(DUZ(2),ABMD("DFN")):1 ; Lock entry in 3P BILL
I '$T W *7,!!,"Bill not created, Bill File in use by another user, try Later!" G XIT
E2 ;
;BYPASS LOCK
W !
K DIC,DIE,DA,DR,X,Y ;abm*2.6*1 HEAT7431
S DA=ABMD("DFN") ; 3P BILL ien
S DIE="^ABMDBILL(DUZ(2)," ; 3P BILL file
S DR=".03////"_DUZ(2) ; Facility
S DR=DR_";.05R~Patient........: " ; Patient pointer
S DR=DR_";.07R~Visit Type.....: " ; Visit type
S DR=DR_";.1R~Clinic.........: " ; clinic
D ^DIE ; add fields to 3P BILL entry
G KILL:$D(Y) ; if ^ out, kill entry
;
; If not inpatient ask Serv date from and thru and No of
; outpatient visits.
SVDTS ;
I $P(^ABMDBILL(DUZ(2),DA,0),U,7)'=111 D G KILL:$D(Y)
.S DR=".71R~Serv Date From.: "
.D ^DIE
.Q:$D(Y)
.S ABMSVFRM=X
.I X>DT D I Y=0 K Y G SVDTS
..S DIR(0)="Y"
..S DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
..S DIR("B")="N"
..D ^DIR
.S DR=".72////"_$P(^ABMDBILL(DUZ(2),DA,7),U)
.D ^DIE
.S DR=".72Serv Date Thru.: "
.D ^DIE
.Q:$D(Y)
.S ABMSVTRU=X
.I X>DT D I Y=0 K Y G SVDTS
..S DIR(0)="Y"
..S DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
..S DIR("B")="N"
..D ^DIR
.I ABMSVTRU<ABMSVFRM W !,"Service Thru Date cannot be less than Service From Date....",! G SVDTS
.S DR=".69R~No. of Visits..: //1"
.D ^DIE
.Q:$D(Y)
;
; If inpatient ask Adm and Dsch date, set Serv to and from dates
; based on Adm and Dsch dates, calc covered days, and delete
; No of outpatient visits.
ADMDTS I $P(^ABMDBILL(DUZ(2),DA,0),U,7)=111 D G KILL:$D(Y)
.S DR=".61R~Admission Date.: "
.D ^DIE
.Q:$D(Y)
.I X>DT D I Y=0 K Y G ADMDTS
..S DIR(0)="Y"
..S DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
..S DIR("B")="N"
..D ^DIR
.S DR=".63R~Discharge Date.: "
.D ^DIE
.Q:$D(Y)
.I X>DT D I Y=0 K Y G ADMDTS
..S DIR(0)="Y"
..S DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
..S DIR("B")="N"
..D ^DIR
.S X2=$P(^ABMDBILL(DUZ(2),DA,6),U)
.S X1=$P(^ABMDBILL(DUZ(2),DA,6),U,3)
.D ^%DTC
.S ABMD("DAYS")=$S(X>0:X,1:1)
.S DR=".71////"_$P(^ABMDBILL(DUZ(2),ABMD("DFN"),6),U)
.S DR=DR_";.72////"_$P(^(6),U,3)
.S DR=DR_";.73////"_ABMD("DAYS")
.S DR=DR_";.69///@"
.D ^DIE
.Q:$D(Y)
;
CHK ;
S ABMD(0)=$G(^ABMDBILL(DUZ(2),ABMD("DFN"),0))
S ABMD("DUP")=0
S ABMD("R")=""
S ABMD("P")=$P(ABMD(0),U,5) ; Patient pointer
S ABMD("L")=$P(ABMD(0),U,3) ; Facility
S ABMD("T")=$P(ABMD(0),U,7) ; Visit type
S ABMD("C")=$P(ABMD(0),U,10) ; clinic IEN
S ABMD("D")=$P(^ABMDBILL(DUZ(2),ABMD("DFN"),7),U) ; Serv date from
; Check Serv date from cross-ref for duplicate bills
F S ABMD("R")=$O(^ABMDBILL(DUZ(2),"AD",ABMD("D"),ABMD("R"))) Q:'ABMD("R") D
.Q:ABMD("R")=ABMD("DFN") ; Q if this bill number
.I '$D(^ABMDBILL(DUZ(2),ABMD("R"),0)) K ^ABMDBILL(DUZ(2),"AD",ABMD("D"),ABMD("R")) Q ;if no data, kill cross-ref,Q
.S ABMD(0)=^ABMDBILL(DUZ(2),ABMD("R"),0) ; 0 node of new bill found
.I $P(ABMD(0),U,3)=ABMD("L"),$P(ABMD(0),U,7)=ABMD("T"),$P(ABMD(0),U,5)=ABMD("P") D
..S ABMD("DUP")=1
..S ABMD("Z",$P(ABMD(0),U))=$P($G(^DIC(40.7,$P(ABMD(0),U,10),0)),U)
..I $P(ABMD(0),U,10)=ABMD("C") S $P(ABMD("Z",$P(ABMD(0),U)),U,2)="D"
I ABMD("DUP") D G KILL:ABMD("DUP")
.W !!,"This patient also has the following bills on file for this visit date:",!
.S ABMD("B")=""
.F S ABMD("B")=$O(ABMD("Z",ABMD("B"))) Q:'ABMD("B") D
..W !,"BILL: ",ABMD("B"),?18,"CLINIC: ",$P(ABMD("Z",ABMD("B")),U)
..I $P(ABMD("Z",ABMD("B")),U,2)="D" W ?50,"(**DUPLICATE**)"
.W !
.S DIR("A")="Proceed"
.S DIR("B")="NO"
.S DIR(0)="Y"
.D ^DIR
.K DIR
.S:Y=1 ABMD("DUP")=0
;
INS ;
S DR=".08R~Insurer........: "
S DR=DR_";.21R~Amount Billed..: "
D ^DIE
G KILL:$D(Y)
S ABMAMT=$P($G(^ABMDBILL(DUZ(2),ABMD("DFN"),2)),U)
S DR=".23////"_ABMAMT
D ^DIE
W !
S ABMD("INS")=$P(^ABMDBILL(DUZ(2),ABMD("DFN"),0),U,8)
I $P($G(^AUTNINS(ABMD("INS"),0)),U,11)="",($P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1) D G KILL
.W !,"Insurer ",$P($G(^AUTNINS(ABMD("INS"),0)),U)
.W !,"is missing Tax Identification Number. Please add in the Insurer file."
D ELG^ABMDLCK("",.ABML,ABMD("P"),ABMD("D")) ; Call Eligibility Checker
S Y=ABMD("D")
D DD^%DT
S ABMD("ED")=Y ; external visit date
S ABMD("PRI")=""
F S ABMD("PRI")=$O(ABML(ABMD("PRI"))) Q:'ABMD("PRI") D
.I $D(ABML(ABMD("PRI"),ABMD("INS"))) D
..S ABMD("ITYP")=$P(ABML(ABMD("PRI"),ABMD("INS")),U,3)
..S ABMD("ELG")=$P(ABML(ABMD("PRI"),ABMD("INS")),U,2)
..S ABMD("MCD")=$P(ABML(ABMD("PRI"),ABMD("INS")),U)
K ABML
I '$D(ABMD("ELG")) D
.W !,$P(^DPT($P(^AUPNPAT(ABMD("P"),0),U),0),U)
.W " has NO ELIGIBILITY for "
.W $P(^AUTNINS(ABMD("INS"),0),U)
.W " on ",ABMD("ED"),!
S DIR(0)="Y"
S DIR("A")="File Bill"
S DIR("B")="NO"
D ^DIR
K DIR
I Y'=1 G E2 ; If not file bill, ask info again.
; Insurer Type
;S ABMD("IT")=$P($G(^AUTNINS(ABMD("INS"),2)),U,1) ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_111
S ABMD("IT")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMD("INS"),".211","I"),1,"I") ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_111
S:"FHM"[ABMD("IT") ABMD("IT")="P"
D NOW^%DTC
S ABMD("APDT")=%
S DA=1
;S DIC="^ABMDBILL(DUZ(2),DA(1),13," ;abm*2.6*21 IHS/SD/SDR HEAT175003
S DA(1)=ABMD("DFN")
S DIC="^ABMDBILL(DUZ(2),"_DA(1)_",13," ;abm*2.6*21 IHS/SD/SDR HEAT175003
S X=ABMD("INS") ; Insurer
S DIC(0)="LE"
S DIC("P")=$P(^DD(9002274.4,13,0),U,2)
S DIC("DR")=".02///1" ; Priority
;S DIC("DR")=DIC("DR")_";.03///INITIATED" ; Status ;abm*2.6*21 IHS/SD/SDR HEAT175003
S DIC("DR")=DIC("DR")_";.03////I" ; Status ;abm*2.6*21 IHS/SD/SDR HEAT175003
I $D(ABMD("ELG")) D
.I ABMD("ITYP")?1(1"P",1"W",1"A") S DIC("DR")=DIC("DR")_";.08///"_ABMD("ELG")
.;start old code abm*2.6*21 IHS/SD/SDR HEAT175003
.;I ABMD("ITYP")="M" S DIC("DR")=DIC("DR")_".04///"_ABMD("ELG")
.;I ABMD("ITYP")="R" S DIC("DR")=DIC("DR")_".05///"_ABMD("ELG")
.;I ABMD("ITYP")="D" D
.;.S DIC("DR")=DIC("DR")_".07///"_ABMD("ELG")
.;.S DIC("DR")=DIC("DR")_".06////"_ABMD("MCD")
.;end old start new abm*2.6*21 IHS/SD/SDR HEAT175003
.I ABMD("ITYP")="M" S DIC("DR")=DIC("DR")_";.04///"_ABMD("ELG")
.I ABMD("ITYP")="R" S DIC("DR")=DIC("DR")_";.05///"_ABMD("ELG")
.I ABMD("ITYP")="D" D
..S DIC("DR")=DIC("DR")_";.07////"_ABMD("ELG")
..S DIC("DR")=DIC("DR")_";.06////"_ABMD("MCD")
.;end new abm*2.6*21 IHS/SD/SDR HEAT175003
.I ABMD("ITYP")="V" S DIC("DR")=DIC("DR")_";.013///"_ABMD("ELG") ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_111
K DD,DO D FILE^DICN
S DA=ABMD("DFN")
S DR=".14////"_DUZ ; Approving Official
S DR=DR_";.15////"_ABMD("APDT") ; Approval date and time
S DR=DR_";.22////"_ABMD("IT") ; Insurer Type
S DR=DR_";.04////B" ; Bill Status
S DR=DR_";.16////A" ; Export Status
S ABMAPOK=1 ; Set so .04 x-ref will call ABMAPASS
D ^DIE
I ABMARPS S DUZ(2)=ABMUDUZ2
W !,"Bill # ",$P(^ABMDBILL(DUZ(2),DA,0),"^",1)," Filed.",!
D ADDBENTR^ABMUCUTL("ABILL",ABMP("BDFN")) ;add bill to UFMS Cash. Session
;
XIT ;
L -^ABMDBILL(DUZ(2),ABMD("DFN"))
K DIR
S DIR(0)="E"
D ^DIR
K ABMD,ABMAPOK
I ABMARPS S DUZ(2)=ABMDUZ2
Q
;
KILL ;
W !!,*7,"<Data Incomplete: Entry Deleted>"
S DIK=DIE
D ^DIK
G XIT
ABMDBADD ; IHS/SD/SDR - Add Bill Manually Submitted ;
+1 ;;2.6;IHS Third Party Billing;**1,9,21**;NOV 12, 2009;Build 379
+2 ;
DOC ;
+1 ; LSL - 12/30/97 - Modified for readability. Changed ABM array to ABMD array as
+2 ; ABMAPASS and A/R routines stomp all over ABM array. Also, add the storage of
+3 ; Approved Date and Time for A/R usage. Will be date and time bill is manually created.
+4 ; LSL - 1/23/98 - Added the storage of the 13 multiple to the bill file. Many other programs
+5 ; in 3PB and A/R assume it exists.
+6 ; LSL - 2/2/98 - Allow duplicate bills if user ok. Also allow multiple clinics on same visit date.
+7 ; LSL - 3/25/98 - Lost value of %, so set approval date variable sooner
+8 ;
+9 ; IHS/ASDS/SDH - 03/09/01 - V2.4 Patch 9 - NOIS LTA-0600-160017 - Modified to check if service
+10 ; thru date is less than service from date
+11 ;
+12 ; IHS/ASDS/SDH - 10/16/01 - V2.4 Patch 9 - NOIS UOB-0701-170024 - Modified to use ABM utility to
+13 ; get claim number so manually generated claims will have unique numbers. Also made gross
+14 ; amount the same as bill amount.
+15 ;
+16 ; IHS/SD/SDR - 9/26/2002 - V2.5 P2 - UOB-0102-170068 - Modified routine to do date check for future dates of
+17 ; service/admission
+18 ;
+19 ; IHS/SD/SDR - v2.5 p8 - IM11831 - Modified to prompt for visit location
+20 ;
+21 ; IHS/SD/SDR - v2.5 p12 - UFMS - If user isn't logged into cashiering session they can't do
+22 ; this option. Also added so if they enter a bill using this option it will add to cashiering session
+23 ; IHS/SD/SDR - abm*2.6*1 - HEAT7431 - <SUBSCR>V^DIED (vars from previous FM call still defined.
+24 ;IHS/SD/SDR - 2.6*21 - VMBP RQMT_111 - fixed insurer type code
+25 ;IHS/SD/SDR - 2.6*21 - HEAT175003 - Made change for <SUBSCR>ISET+33^ABMERUTL; occurs when trying to file elig pointer into record. There was no ';' to
+26 ; separate data
+27 ;
+28 ; *********************************************************************
+29 ;
START ;EP
+1 KILL ABMD
+2 WRITE !!?5,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")
+3 WRITE " This program should only be utilized when an entry in the"
+4 WRITE !?11,"Accounts Receivable File is needed to reflect a bill that"
+5 WRITE !?11,"was manually prepared and submitted.",!
+6 SET DIR(0)="Y"
+7 SET DIR("A")="Proceed"
+8 SET DIR("B")="NO"
+9 DO ^DIR
+10 KILL DIR
+11 IF Y'=1
QUIT
+12 ;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup
+13 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=""
Begin DoDot:1
+14 WRITE !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!
+15 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+16 ;end new code
+17 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1
Begin DoDot:1
+18 SET ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)
+19 IF +$GET(ABMUOPNS)=0
Begin DoDot:2
+20 WRITE !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!
+21 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:2
QUIT
End DoDot:1
IF +$GET(ABMUOPNS)=0
QUIT
+22 ;
ASK ; ask what visit location if Parent/Satellite is set up
+1 ;A/R P/S?
SET ABMARPS=$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,9)
+2 IF ABMARPS
Begin DoDot:1
+3 KILL DIC
+4 SET DIC="^BAR(90052.05,DUZ(2),"
+5 SET DIC(0)="AME"
+6 SET DIC("A")="Visit Location: "
+7 SET DIC("B")=DUZ(2)
+8 DO ^DIC
End DoDot:1
+9 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+10 IF +Y<0
QUIT
ADD ;
+1 IF ABMARPS
Begin DoDot:1
+2 SET ABMDUZ2=DUZ(2)
+3 SET ABMUDUZ2=+Y
+4 SET DUZ(2)=ABMUDUZ2
End DoDot:1
+5 SET ABMD("DFN")=$$NXNM^ABMDUTL
+6 KILL DINUM
+7 SET DIC="^ABMDBILL(DUZ(2),"
+8 SET DIC(0)="L"
+9 SET X=ABMD("DFN")
+10 ; Add entry to 3P BILL
KILL DD,DO
DO FILE^DICN
+11 IF +Y<1
Begin DoDot:1
+12 WRITE *7
+13 WRITE !!,"ERROR: BILL NOT CREATED, ensure your Fileman ACCESS CODE contains a 'V'.",!!
End DoDot:1
GOTO XIT
+14 ; 3P BILL ien
SET ABMD("DFN")=+Y
+15 ;
EDIT ;
+1 ; Lock entry in 3P BILL
LOCK +^ABMDBILL(DUZ(2),ABMD("DFN")):1
+2 IF '$TEST
WRITE *7,!!,"Bill not created, Bill File in use by another user, try Later!"
GOTO XIT
E2 ;
+1 ;BYPASS LOCK
+2 WRITE !
+3 ;abm*2.6*1 HEAT7431
KILL DIC,DIE,DA,DR,X,Y
+4 ; 3P BILL ien
SET DA=ABMD("DFN")
+5 ; 3P BILL file
SET DIE="^ABMDBILL(DUZ(2),"
+6 ; Facility
SET DR=".03////"_DUZ(2)
+7 ; Patient pointer
SET DR=DR_";.05R~Patient........: "
+8 ; Visit type
SET DR=DR_";.07R~Visit Type.....: "
+9 ; clinic
SET DR=DR_";.1R~Clinic.........: "
+10 ; add fields to 3P BILL entry
DO ^DIE
+11 ; if ^ out, kill entry
IF $DATA(Y)
GOTO KILL
+12 ;
+13 ; If not inpatient ask Serv date from and thru and No of
+14 ; outpatient visits.
SVDTS ;
+1 IF $PIECE(^ABMDBILL(DUZ(2),DA,0),U,7)'=111
Begin DoDot:1
+2 SET DR=".71R~Serv Date From.: "
+3 DO ^DIE
+4 IF $DATA(Y)
QUIT
+5 SET ABMSVFRM=X
+6 IF X>DT
Begin DoDot:2
+7 SET DIR(0)="Y"
+8 SET DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
+9 SET DIR("B")="N"
+10 DO ^DIR
End DoDot:2
IF Y=0
KILL Y
GOTO SVDTS
+11 SET DR=".72////"_$PIECE(^ABMDBILL(DUZ(2),DA,7),U)
+12 DO ^DIE
+13 SET DR=".72Serv Date Thru.: "
+14 DO ^DIE
+15 IF $DATA(Y)
QUIT
+16 SET ABMSVTRU=X
+17 IF X>DT
Begin DoDot:2
+18 SET DIR(0)="Y"
+19 SET DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
+20 SET DIR("B")="N"
+21 DO ^DIR
End DoDot:2
IF Y=0
KILL Y
GOTO SVDTS
+22 IF ABMSVTRU<ABMSVFRM
WRITE !,"Service Thru Date cannot be less than Service From Date....",!
GOTO SVDTS
+23 SET DR=".69R~No. of Visits..: //1"
+24 DO ^DIE
+25 IF $DATA(Y)
QUIT
End DoDot:1
IF $DATA(Y)
GOTO KILL
+26 ;
+27 ; If inpatient ask Adm and Dsch date, set Serv to and from dates
+28 ; based on Adm and Dsch dates, calc covered days, and delete
+29 ; No of outpatient visits.
ADMDTS IF $PIECE(^ABMDBILL(DUZ(2),DA,0),U,7)=111
Begin DoDot:1
+1 SET DR=".61R~Admission Date.: "
+2 DO ^DIE
+3 IF $DATA(Y)
QUIT
+4 IF X>DT
Begin DoDot:2
+5 SET DIR(0)="Y"
+6 SET DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
+7 SET DIR("B")="N"
+8 DO ^DIR
End DoDot:2
IF Y=0
KILL Y
GOTO ADMDTS
+9 SET DR=".63R~Discharge Date.: "
+10 DO ^DIE
+11 IF $DATA(Y)
QUIT
+12 IF X>DT
Begin DoDot:2
+13 SET DIR(0)="Y"
+14 SET DIR("A")="Wait! You are entering a DOS in the future...Do you wish to proceed?"
+15 SET DIR("B")="N"
+16 DO ^DIR
End DoDot:2
IF Y=0
KILL Y
GOTO ADMDTS
+17 SET X2=$PIECE(^ABMDBILL(DUZ(2),DA,6),U)
+18 SET X1=$PIECE(^ABMDBILL(DUZ(2),DA,6),U,3)
+19 DO ^%DTC
+20 SET ABMD("DAYS")=$SELECT(X>0:X,1:1)
+21 SET DR=".71////"_$PIECE(^ABMDBILL(DUZ(2),ABMD("DFN"),6),U)
+22 SET DR=DR_";.72////"_$PIECE(^(6),U,3)
+23 SET DR=DR_";.73////"_ABMD("DAYS")
+24 SET DR=DR_";.69///@"
+25 DO ^DIE
+26 IF $DATA(Y)
QUIT
End DoDot:1
IF $DATA(Y)
GOTO KILL
+27 ;
CHK ;
+1 SET ABMD(0)=$GET(^ABMDBILL(DUZ(2),ABMD("DFN"),0))
+2 SET ABMD("DUP")=0
+3 SET ABMD("R")=""
+4 ; Patient pointer
SET ABMD("P")=$PIECE(ABMD(0),U,5)
+5 ; Facility
SET ABMD("L")=$PIECE(ABMD(0),U,3)
+6 ; Visit type
SET ABMD("T")=$PIECE(ABMD(0),U,7)
+7 ; clinic IEN
SET ABMD("C")=$PIECE(ABMD(0),U,10)
+8 ; Serv date from
SET ABMD("D")=$PIECE(^ABMDBILL(DUZ(2),ABMD("DFN"),7),U)
+9 ; Check Serv date from cross-ref for duplicate bills
+10 FOR
SET ABMD("R")=$ORDER(^ABMDBILL(DUZ(2),"AD",ABMD("D"),ABMD("R")))
IF 'ABMD("R")
QUIT
Begin DoDot:1
+11 ; Q if this bill number
IF ABMD("R")=ABMD("DFN")
QUIT
+12 ;if no data, kill cross-ref,Q
IF '$DATA(^ABMDBILL(DUZ(2),ABMD("R"),0))
KILL ^ABMDBILL(DUZ(2),"AD",ABMD("D"),ABMD("R"))
QUIT
+13 ; 0 node of new bill found
SET ABMD(0)=^ABMDBILL(DUZ(2),ABMD("R"),0)
+14 IF $PIECE(ABMD(0),U,3)=ABMD("L")
IF $PIECE(ABMD(0),U,7)=ABMD("T")
IF $PIECE(ABMD(0),U,5)=ABMD("P")
Begin DoDot:2
+15 SET ABMD("DUP")=1
+16 SET ABMD("Z",$PIECE(ABMD(0),U))=$PIECE($GET(^DIC(40.7,$PIECE(ABMD(0),U,10),0)),U)
+17 IF $PIECE(ABMD(0),U,10)=ABMD("C")
SET $PIECE(ABMD("Z",$PIECE(ABMD(0),U)),U,2)="D"
End DoDot:2
End DoDot:1
+18 IF ABMD("DUP")
Begin DoDot:1
+19 WRITE !!,"This patient also has the following bills on file for this visit date:",!
+20 SET ABMD("B")=""
+21 FOR
SET ABMD("B")=$ORDER(ABMD("Z",ABMD("B")))
IF 'ABMD("B")
QUIT
Begin DoDot:2
+22 WRITE !,"BILL: ",ABMD("B"),?18,"CLINIC: ",$PIECE(ABMD("Z",ABMD("B")),U)
+23 IF $PIECE(ABMD("Z",ABMD("B")),U,2)="D"
WRITE ?50,"(**DUPLICATE**)"
End DoDot:2
+24 WRITE !
+25 SET DIR("A")="Proceed"
+26 SET DIR("B")="NO"
+27 SET DIR(0)="Y"
+28 DO ^DIR
+29 KILL DIR
+30 IF Y=1
SET ABMD("DUP")=0
End DoDot:1
IF ABMD("DUP")
GOTO KILL
+31 ;
INS ;
+1 SET DR=".08R~Insurer........: "
+2 SET DR=DR_";.21R~Amount Billed..: "
+3 DO ^DIE
+4 IF $DATA(Y)
GOTO KILL
+5 SET ABMAMT=$PIECE($GET(^ABMDBILL(DUZ(2),ABMD("DFN"),2)),U)
+6 SET DR=".23////"_ABMAMT
+7 DO ^DIE
+8 WRITE !
+9 SET ABMD("INS")=$PIECE(^ABMDBILL(DUZ(2),ABMD("DFN"),0),U,8)
+10 IF $PIECE($GET(^AUTNINS(ABMD("INS"),0)),U,11)=""
IF ($PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1)
Begin DoDot:1
+11 WRITE !,"Insurer ",$PIECE($GET(^AUTNINS(ABMD("INS"),0)),U)
+12 WRITE !,"is missing Tax Identification Number. Please add in the Insurer file."
End DoDot:1
GOTO KILL
+13 ; Call Eligibility Checker
DO ELG^ABMDLCK("",.ABML,ABMD("P"),ABMD("D"))
+14 SET Y=ABMD("D")
+15 DO DD^%DT
+16 ; external visit date
SET ABMD("ED")=Y
+17 SET ABMD("PRI")=""
+18 FOR
SET ABMD("PRI")=$ORDER(ABML(ABMD("PRI")))
IF 'ABMD("PRI")
QUIT
Begin DoDot:1
+19 IF $DATA(ABML(ABMD("PRI"),ABMD("INS")))
Begin DoDot:2
+20 SET ABMD("ITYP")=$PIECE(ABML(ABMD("PRI"),ABMD("INS")),U,3)
+21 SET ABMD("ELG")=$PIECE(ABML(ABMD("PRI"),ABMD("INS")),U,2)
+22 SET ABMD("MCD")=$PIECE(ABML(ABMD("PRI"),ABMD("INS")),U)
End DoDot:2
End DoDot:1
+23 KILL ABML
+24 IF '$DATA(ABMD("ELG"))
Begin DoDot:1
+25 WRITE !,$PIECE(^DPT($PIECE(^AUPNPAT(ABMD("P"),0),U),0),U)
+26 WRITE " has NO ELIGIBILITY for "
+27 WRITE $PIECE(^AUTNINS(ABMD("INS"),0),U)
+28 WRITE " on ",ABMD("ED"),!
End DoDot:1
+29 SET DIR(0)="Y"
+30 SET DIR("A")="File Bill"
+31 SET DIR("B")="NO"
+32 DO ^DIR
+33 KILL DIR
+34 ; If not file bill, ask info again.
IF Y'=1
GOTO E2
+35 ; Insurer Type
+36 ;S ABMD("IT")=$P($G(^AUTNINS(ABMD("INS"),2)),U,1) ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_111
+37 ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_111
SET ABMD("IT")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMD("INS"),".211","I"),1,"I")
+38 IF "FHM"[ABMD("IT")
SET ABMD("IT")="P"
+39 DO NOW^%DTC
+40 SET ABMD("APDT")=%
+41 SET DA=1
+42 ;S DIC="^ABMDBILL(DUZ(2),DA(1),13," ;abm*2.6*21 IHS/SD/SDR HEAT175003
+43 SET DA(1)=ABMD("DFN")
+44 ;abm*2.6*21 IHS/SD/SDR HEAT175003
SET DIC="^ABMDBILL(DUZ(2),"_DA(1)_",13,"
+45 ; Insurer
SET X=ABMD("INS")
+46 SET DIC(0)="LE"
+47 SET DIC("P")=$PIECE(^DD(9002274.4,13,0),U,2)
+48 ; Priority
SET DIC("DR")=".02///1"
+49 ;S DIC("DR")=DIC("DR")_";.03///INITIATED" ; Status ;abm*2.6*21 IHS/SD/SDR HEAT175003
+50 ; Status ;abm*2.6*21 IHS/SD/SDR HEAT175003
SET DIC("DR")=DIC("DR")_";.03////I"
+51 IF $DATA(ABMD("ELG"))
Begin DoDot:1
+52 IF ABMD("ITYP")?1(1"P",1"W",1"A")
SET DIC("DR")=DIC("DR")_";.08///"_ABMD("ELG")
+53 ;start old code abm*2.6*21 IHS/SD/SDR HEAT175003
+54 ;I ABMD("ITYP")="M" S DIC("DR")=DIC("DR")_".04///"_ABMD("ELG")
+55 ;I ABMD("ITYP")="R" S DIC("DR")=DIC("DR")_".05///"_ABMD("ELG")
+56 ;I ABMD("ITYP")="D" D
+57 ;.S DIC("DR")=DIC("DR")_".07///"_ABMD("ELG")
+58 ;.S DIC("DR")=DIC("DR")_".06////"_ABMD("MCD")
+59 ;end old start new abm*2.6*21 IHS/SD/SDR HEAT175003
+60 IF ABMD("ITYP")="M"
SET DIC("DR")=DIC("DR")_";.04///"_ABMD("ELG")
+61 IF ABMD("ITYP")="R"
SET DIC("DR")=DIC("DR")_";.05///"_ABMD("ELG")
+62 IF ABMD("ITYP")="D"
Begin DoDot:2
+63 SET DIC("DR")=DIC("DR")_";.07////"_ABMD("ELG")
+64 SET DIC("DR")=DIC("DR")_";.06////"_ABMD("MCD")
End DoDot:2
+65 ;end new abm*2.6*21 IHS/SD/SDR HEAT175003
+66 ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_111
IF ABMD("ITYP")="V"
SET DIC("DR")=DIC("DR")_";.013///"_ABMD("ELG")
End DoDot:1
+67 KILL DD,DO
DO FILE^DICN
+68 SET DA=ABMD("DFN")
+69 ; Approving Official
SET DR=".14////"_DUZ
+70 ; Approval date and time
SET DR=DR_";.15////"_ABMD("APDT")
+71 ; Insurer Type
SET DR=DR_";.22////"_ABMD("IT")
+72 ; Bill Status
SET DR=DR_";.04////B"
+73 ; Export Status
SET DR=DR_";.16////A"
+74 ; Set so .04 x-ref will call ABMAPASS
SET ABMAPOK=1
+75 DO ^DIE
+76 IF ABMARPS
SET DUZ(2)=ABMUDUZ2
+77 WRITE !,"Bill # ",$PIECE(^ABMDBILL(DUZ(2),DA,0),"^",1)," Filed.",!
+78 ;add bill to UFMS Cash. Session
DO ADDBENTR^ABMUCUTL("ABILL",ABMP("BDFN"))
+79 ;
XIT ;
+1 LOCK -^ABMDBILL(DUZ(2),ABMD("DFN"))
+2 KILL DIR
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 KILL ABMD,ABMAPOK
+6 IF ABMARPS
SET DUZ(2)=ABMDUZ2
+7 QUIT
+8 ;
KILL ;
+1 WRITE !!,*7,"<Data Incomplete: Entry Deleted>"
+2 SET DIK=DIE
+3 DO ^DIK
+4 GOTO XIT
