- IBTUBOA ;ALB/RB - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;01-JAN-01
- ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,155,276,516,608**;21-MAR-94;Build 90
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- % ; - Entry point from Taskman.
- ;
- ; IB*2.0*516 - Added ability to sort by Division, so added IBDIV as a
- ; subscript to most of the IBUNB entries.
- ;
- ;ARRAY VARIABLES:
- ; IBAVG("BILLS-I")=number of inpatient institutional claims
- ; IBAVG("BILLS-P")=number of inpatient professional claims
- ; IBAVG("EPISD-I")=number of inpt. episodes for institutional claims
- ; IBAVG("EPISD-P")=number of inpt. episodes for professional claims
- ; IBAVG("$AMNT-I")=inpatient institutional amount billed
- ; IBAVG("$AMNT-P")=inpatient professional amount billed
- ;
- ; IBUNB("UNBILTL")=total unbilled amount
- ; IBUNB("UNBILTL-MRA")=total MRA req amount
- ;
- ; IBUNB(IBDIV,"ENCNTRS")=number of outpatient encounters missing claims
- ; IBUNB(IBDIV,"EPISM-I")=number of inpatient episodes missing inst. claims
- ; IBUNB(IBDIV,"EPISM-I-MRA")=number of MRA req inpat institutional claims
- ; IBUNB(IBDIV,"EPISM-P")=number of inpatient episodes missing prof. claims
- ; IBUNB(IBDIV,"EPISM-P-MRA")=number of MRA req inpat professional claims
- ; IBUNB(IBDIV,"EPISM-A")=number of inpatient admissions missing claims
- ; (any type: Prof,Inst or both)
- ; IBUNB(IBDIV,"EPISM-A-MRA")=number inpt MRA req admissions missing claims
- ; (any type: Prof,Inst or both)
- ; IBUNB(IBDIV,"CPTMS-I")=number of CPT codes missing institutional claims
- ; IBUNB(IBDIV,"CPTMS-I-MRA")=number of MRA req CPT codes missing inst claims
- ; IBUNB(IBDIV,"CPTMS-P")=number of CPT codes missing professional claims
- ; IBUNB(IBDIV,"CPTMS-P-MRA")=number of MRA req CPT codes missing prof claims
- ; IBUNB(IBDIV,"PRESCRP")=number of unbilled prescriptions
- ; IBUNB(IBDIV,"PRESCRP-MRA")=number of MRA req prescriptions
- ; IBUNB(IBDIV,"UNBILIP")=unbilled inpatient amount
- ; IBUNB(IBDIV,"UNBILIP-MRA")=MRA req inpatient amount
- ; IBUNB(IBDIV,"UNBILOP")=unbilled outpatient amount
- ; IBUNB(IBDIV,"UNBILOP-MRA")=MRA req outpatient amount
- ; IBUNB(IBDIV,"UNBILRX")=unbilled prescription amount
- ; IBUNB(IBDIV,"UNBILRX-MRA")=MRA req prescription amount
- ;
- ;ARRAY VARIABLES FOR DM EXTRACT:
- ; IB(1)=Number of inpatient episodes missing institutional claims
- ; IB(2)=Amount of inpatient episodes missing institutional claims
- ; IB(3)=Number of inpatient episodes missing professional claims
- ; IB(4)=Amount of inpatient episodes missing professional claims
- ; IB(5)=Number of all inpatient episodes missing claims
- ; IB(6)=Amount of all inpatient episodes missing claims
- ; IB(7)=Number of unbilled outpatient encounters prior to 9/1/99
- ; IB(8)=Amount of unbilled outpatient encounters prior to 9/1/99
- ; IB(9)=Number of procedures without an institutional charge
- ; IB(10)=Amount of procedures without an institutional charge
- ; IB(11)=Number of procedures without a professional charge
- ; IB(12)=Amount of procedures without a professional charge
- ; IB(13)=Number of all procedures without a charge
- ; IB(14)=Number of encounters associated with all procedures without
- ; a charge
- ; IB(15)=Number of all encounters missing claims
- ; IB(16)=Amount of all encounters missing claims
- ; IB(17)=Number of unbilled prescriptions and refills
- ; IB(18)=Amount of unbilled prescriptions and refills
- ; IB(19)=Amount of all unbilled episodes of care
- ;
- N IB,IBAMTI,IBAMTP,IBIAV,IBIA,IBNODE,IBOE,IBPA,IBQUERY,IBRX,IBSAV,IBT
- N IBAMTIM,IBAMTPM,IBTYP,IBX,IBY,DFN,DGPM,I,J
- ;
- K ^TMP($J,"IBTUB-INPT"),^TMP($J,"IBTUB-OPT"),^TMP($J,"IBTUB-RX")
- K ^TMP($J,"IBTUB-INPT_MRA"),^TMP($J,"IBTUB-OPT_MRA"),^TMP($J,"IBTUB-RX_MRA")
- ;
- ; - Initialize DM extract variables, if necessary.
- I $G(IBXTRACT) D E^IBJDE(37,1) F IBX=1:1:19 S IB(IBX)=0
- ;
- ; - Initialize Unbilled Amounts variables.
- S (IBUNB("ENCNTRS"),IBUNB("PRESCRP"),IBUNB("PRESCRP-MRA"))=0
- F IBX="IP","OP","RX","TL" S IBUNB("UNBIL"_IBX)=0,IBUNB("UNBIL"_IBX_"-MRA")=0
- F IBX="I","P" S (IBUNB("EPISM-"_IBX),IBUNB("EPISM-"_IBX_"-MRA"),IBUNB("CPTMS-"_IBX),IBUNB("CPTMS-"_IBX_"-MRA"))=0
- S (IBUNB("EPISM-A"),IBUNB("EPISM-A-MRA"))=0
- ;
- ; - Retrieve the Rate Type code for Reimbursable Insurance
- S IBRT=$S($O(^DGCR(399.3,"B","REIMBURSABLE INS.",0)):$O(^(0)),1:8)
- ;
- ; - If Compile/Store - Checks if the Average Bill Amounts exists for
- ; IBTIMON. If it does not, calls IBTUBAV to calculate/updated it.
- I $G(IBCOMP) D
- . I $P($G(^IBE(356.19,IBTIMON,1)),"^",14)'="" Q
- . ;
- . ; - DQ^IBTUBAV will kill the variables IBTIMON and IBCOMP - That's why
- . ; they are being set again after this call.
- . S IBSAV=IBTIMON D DQ^IBTUBAV S IBTIMON=IBSAV,IBCOMP=1
- . Q
- ;
- PROC ; - Loops through all the entries in the Claims Tracking file for the
- ; period selected and calculate the Unbilled Amounts
- N NVELIG ;JRA;IB*2.0*608 Flag set to 1 if patient has non-veteran eligibility
- S IBDT=IBBDT-.1
- ;
- F S IBDT=$O(^IBT(356,"D",IBDT)) Q:'IBDT!(IBDT>IBEDT) D
- . S IBX=0 F S IBX=$O(^IBT(356,"D",IBDT,IBX)) Q:'IBX D
- . . S IBNODE=$G(^IBT(356,IBX,0)) Q:IBNODE=""
- . . I $P(IBNODE,U,12) Q ; Tort-Feasor,Workman's Comp,No-fault Auto Acc.
- . . I $P(IBNODE,U,19) Q ; Reason not billable assigned.
- . . I '$P(IBNODE,U,20) Q ; Inactive.
- . . S DFN=+$P(IBNODE,U,2)
- . . ;Non-veteran eligibility includes CHAMPVA & TRICARE which is non-MCCF so do not screen out
- . . ;I '$$PTCHK^IBTUBOU(DFN,IBNODE) Q ; Has a non-veteran eligibility. ;JRA;IB*2.0*608 ';'
- . . S NVELIG='$$PTCHK^IBTUBOU(DFN,IBNODE) ;JRA;IB*2.0*608
- . . I '$$INSURED^IBCNS1(DFN,IBDT) Q ; Not insured during care.
- . . ;JRA;IB*2.0*608 No Inpatient for Non-MCCF
- . . ;I $P(IBNODE,U,5),IBSEL[1,$$COV^IBTUBOU(DFN,IBDT,1) D Q ;Inpatient ;JRA;IB*2.0*608 ';'
- . . I 'NVELIG,$G(IBMCCF)'="N",$P(IBNODE,U,5),IBSEL[1,$$COV^IBTUBOU(DFN,IBDT,1) D Q ;Inpatient ;JRA;IB*2.0*608
- . . . S DGPM=+$P(IBNODE,U,5) D INPT^IBTUBO2(DGPM)
- . . I $P(IBNODE,U,4),IBSEL[2,$$COV^IBTUBOU(DFN,IBDT,2) D Q ;Outpatient
- . . . S IBOE=+$P(IBNODE,U,4) I $$NCCL^IBTUBOU(IBOE) Q ; Non-Count Clinic
- . . . ;JRA;IB*2.0*608 Check if Eligibility of Encounter, Appointment Type & Rate Type meet MCCF/Non-MCCF Criteria
- . . . I $G(IBMCCF)]"",(IBMCCF'="B") N OK S OK=1 D Q:'OK ;JRA;IB*2.0*608
- . . . . N CLAIM S CLAIM=+$P(IBNODE,U,11)
- . . . . ;If looking only for MCCF and there is a non-veteran eligibility, this entry is Non-MCCF so don't process
- . . . . I IBMCCF="M",'$$PTCHK^IBTUBOU(DFN,IBNODE) S OK=0 Q ;Copied condition from above & modified
- . . . . I IBOE S OK=$$MCCFCKX^IBTUBOU(409.68,IBOE,.13,"ELIG") ;Check Eligibilty of Encounter
- . . . . I IBOE,((OK'=1&(IBMCCF="N"))!(IBMCCF="M"&(OK))) S OK=$$MCCFCKX^IBTUBOU(409.68,IBOE,.1,"ATYP") ;Check Appointment Type
- . . . . I CLAIM,((OK'=1&(IBMCCF="N"))!(IBMCCF="M"&(OK))) S OK=$$MCCFCKX^IBTUBOU(399,CLAIM,.07,"RTYP") ;Check Rate Type
- . . . D OPT^IBTUBO1(IBOE,.IBQUERY)
- . . Q:($G(IBMCCF)="N"!(NVELIG)) ;JRA;IB*2.0*608 Quit if Non-MCCF since only want Outpatient or quit if patient has non-veteran eligibility
- . . I $P(IBNODE,U,8),IBSEL[3,$$COV^IBTUBOU(DFN,IBDT,3) D Q ;Prescription
- . . . N IBIFN,IBCSTAT S IBIFN=+$P(IBNODE,U,11)
- . . . I IBIFN S IBCSTAT=$$GET1^DIQ(399,IBIFN_",",.13,"I") Q:$S(IBCSTAT=0:1,IBCSTAT=1:0,IBCSTAT=2:1,IBCSTAT=3:1,IBCSTAT=4:1,IBCSTAT=5:1,IBCSTAT=7:0,1:1) ;already billed (modified in T9)
- . . . S IBRX=+$P(IBNODE,U,8) D RX^IBTUBO2(IBRX)
- . . ;
- . . ; - Check CT entry event type to get unbilled amounts, if necessary.
- . . S IBTYP=$P($G(^IBE(356.6,+$P(IBNODE,U,18),0)),U,8)
- . . I IBTYP=1,IBSEL[1,$$COV^IBTUBOU(DFN,IBDT,1) D
- . . . D INPT^IBTUBO2(+$O(^DGPM("APTT1",DFN,IBDT,0)))
- . . I IBTYP=2,IBSEL[2,$$COV^IBTUBOU(DFN,IBDT,2) D
- . . . D OPT^IBTUBO1("",.IBQUERY)
- ;
- I $G(IBXTRACT) D XTRACT^IBTUBOU ; Load extract file, if necessary.
- ;
- ; MRD;IB*2.0*516 - Moved code that was here into the new
- ; procedure TOTAL, and tally most of the values up by Division.
- ;
- D TOTAL
- ;
- ; - If Compile/Store - update Unbilled Amounts data on file #356.19
- I $G(IBCOMP) D LD^IBTUBOU(3,IBTIMON)
- ;
- PRT ; - Print report(s).
- I $G(IBQUERY) D CLOSE^IBSDU(.IBQUERY)
- D REPORT^IBTUBO3
- ;
- END K ^TMP($J,"IBTUB-INPT"),^TMP($J,"IBTUB-OPT"),^TMP($J,"IBTUB-RX")
- K IBDT,IBRT,IBUNB
- I $D(ZTQUEUED) S ZTREQ="@" Q
- D ^%ZISC K IBTEMON,IBXTRACT,D,D0,DA,DIC,DIE
- Q
- ;
- TOTAL ; Determine grand total amounts.
- ;
- ; - Calculate the Amount Inpatient INST. & PROF. Unbilled Amounts,
- ; based on average amounts of Billed Amounts
- ;
- S IBIAV=$$INPAVG^IBTUBOU(IBTIMON)
- ;
- S IBAMTI=$P(IBIAV,"^")*$G(IBUNB("EPISM-I")) ; Inst
- S IBAMTIM=$P(IBIAV,"^")*$G(IBUNB("EPISM-I-MRA")) ; Inst
- S IBAMTP=$P(IBIAV,"^",2)*$G(IBUNB("EPISM-P")) ; Prof
- S IBAMTPM=$P(IBIAV,"^",2)*$G(IBUNB("EPISM-P-MRA")) ; Prof
- ;
- S IBUNB("UNBILIP")=IBAMTI+IBAMTP
- S IBUNB("UNBILIP-MRA")=IBAMTIM+IBAMTPM
- ;
- ;S IBUNB("UNBILTL")=IBUNB("UNBILIP")
- ;S IBUNB("UNBILTL-MRA")=IBUNB("UNBILIP-MRA")
- ;
- ; - Calculate Unbilled Amounts Totals by Division
- ;
- S IBDIV=0
- F S IBDIV=$O(IBUNB(IBDIV)) Q:'IBDIV D
- . ;
- . S IBAMTI=$P(IBIAV,"^")*$G(IBUNB(IBDIV,"EPISM-I")) ; Inst
- . S IBAMTIM=$P(IBIAV,"^")*$G(IBUNB(IBDIV,"EPISM-I-MRA")) ; Inst
- . S IBAMTP=$P(IBIAV,"^",2)*$G(IBUNB(IBDIV,"EPISM-P")) ; Prof
- . S IBAMTPM=$P(IBIAV,"^",2)*$G(IBUNB(IBDIV,"EPISM-P-MRA")) ; Prof
- . ;
- . S IBUNB(IBDIV,"UNBILIP")=IBAMTI+IBAMTP
- . S IBUNB(IBDIV,"UNBILIP-MRA")=IBAMTIM+IBAMTPM
- . ;
- . S IBUNB("UNBILTL")=$G(IBUNB("UNBILTL"))+$G(IBUNB(IBDIV,"UNBILIP"))+$G(IBUNB(IBDIV,"UNBILOP"))+$G(IBUNB(IBDIV,"UNBILRX"))
- . S IBUNB("UNBILTL-MRA")=$G(IBUNB("UNBILTL-MRA"))+$G(IBUNB(IBDIV,"UNBILIP-MRA"))+$G(IBUNB(IBDIV,"UNBILOP-MRA"))+$G(IBUNB(IBDIV,"UNBILRX-MRA"))
- . ;
- . Q
- ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUBOA 9925 printed Jan 18, 2025@03:30:20 Page 2
- IBTUBOA ;ALB/RB - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;01-JAN-01
- +1 ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,155,276,516,608**;21-MAR-94;Build 90
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- % ; - Entry point from Taskman.
- +1 ;
- +2 ; IB*2.0*516 - Added ability to sort by Division, so added IBDIV as a
- +3 ; subscript to most of the IBUNB entries.
- +4 ;
- +5 ;ARRAY VARIABLES:
- +6 ; IBAVG("BILLS-I")=number of inpatient institutional claims
- +7 ; IBAVG("BILLS-P")=number of inpatient professional claims
- +8 ; IBAVG("EPISD-I")=number of inpt. episodes for institutional claims
- +9 ; IBAVG("EPISD-P")=number of inpt. episodes for professional claims
- +10 ; IBAVG("$AMNT-I")=inpatient institutional amount billed
- +11 ; IBAVG("$AMNT-P")=inpatient professional amount billed
- +12 ;
- +13 ; IBUNB("UNBILTL")=total unbilled amount
- +14 ; IBUNB("UNBILTL-MRA")=total MRA req amount
- +15 ;
- +16 ; IBUNB(IBDIV,"ENCNTRS")=number of outpatient encounters missing claims
- +17 ; IBUNB(IBDIV,"EPISM-I")=number of inpatient episodes missing inst. claims
- +18 ; IBUNB(IBDIV,"EPISM-I-MRA")=number of MRA req inpat institutional claims
- +19 ; IBUNB(IBDIV,"EPISM-P")=number of inpatient episodes missing prof. claims
- +20 ; IBUNB(IBDIV,"EPISM-P-MRA")=number of MRA req inpat professional claims
- +21 ; IBUNB(IBDIV,"EPISM-A")=number of inpatient admissions missing claims
- +22 ; (any type: Prof,Inst or both)
- +23 ; IBUNB(IBDIV,"EPISM-A-MRA")=number inpt MRA req admissions missing claims
- +24 ; (any type: Prof,Inst or both)
- +25 ; IBUNB(IBDIV,"CPTMS-I")=number of CPT codes missing institutional claims
- +26 ; IBUNB(IBDIV,"CPTMS-I-MRA")=number of MRA req CPT codes missing inst claims
- +27 ; IBUNB(IBDIV,"CPTMS-P")=number of CPT codes missing professional claims
- +28 ; IBUNB(IBDIV,"CPTMS-P-MRA")=number of MRA req CPT codes missing prof claims
- +29 ; IBUNB(IBDIV,"PRESCRP")=number of unbilled prescriptions
- +30 ; IBUNB(IBDIV,"PRESCRP-MRA")=number of MRA req prescriptions
- +31 ; IBUNB(IBDIV,"UNBILIP")=unbilled inpatient amount
- +32 ; IBUNB(IBDIV,"UNBILIP-MRA")=MRA req inpatient amount
- +33 ; IBUNB(IBDIV,"UNBILOP")=unbilled outpatient amount
- +34 ; IBUNB(IBDIV,"UNBILOP-MRA")=MRA req outpatient amount
- +35 ; IBUNB(IBDIV,"UNBILRX")=unbilled prescription amount
- +36 ; IBUNB(IBDIV,"UNBILRX-MRA")=MRA req prescription amount
- +37 ;
- +38 ;ARRAY VARIABLES FOR DM EXTRACT:
- +39 ; IB(1)=Number of inpatient episodes missing institutional claims
- +40 ; IB(2)=Amount of inpatient episodes missing institutional claims
- +41 ; IB(3)=Number of inpatient episodes missing professional claims
- +42 ; IB(4)=Amount of inpatient episodes missing professional claims
- +43 ; IB(5)=Number of all inpatient episodes missing claims
- +44 ; IB(6)=Amount of all inpatient episodes missing claims
- +45 ; IB(7)=Number of unbilled outpatient encounters prior to 9/1/99
- +46 ; IB(8)=Amount of unbilled outpatient encounters prior to 9/1/99
- +47 ; IB(9)=Number of procedures without an institutional charge
- +48 ; IB(10)=Amount of procedures without an institutional charge
- +49 ; IB(11)=Number of procedures without a professional charge
- +50 ; IB(12)=Amount of procedures without a professional charge
- +51 ; IB(13)=Number of all procedures without a charge
- +52 ; IB(14)=Number of encounters associated with all procedures without
- +53 ; a charge
- +54 ; IB(15)=Number of all encounters missing claims
- +55 ; IB(16)=Amount of all encounters missing claims
- +56 ; IB(17)=Number of unbilled prescriptions and refills
- +57 ; IB(18)=Amount of unbilled prescriptions and refills
- +58 ; IB(19)=Amount of all unbilled episodes of care
- +59 ;
- +60 NEW IB,IBAMTI,IBAMTP,IBIAV,IBIA,IBNODE,IBOE,IBPA,IBQUERY,IBRX,IBSAV,IBT
- +61 NEW IBAMTIM,IBAMTPM,IBTYP,IBX,IBY,DFN,DGPM,I,J
- +62 ;
- +63 KILL ^TMP($JOB,"IBTUB-INPT"),^TMP($JOB,"IBTUB-OPT"),^TMP($JOB,"IBTUB-RX")
- +64 KILL ^TMP($JOB,"IBTUB-INPT_MRA"),^TMP($JOB,"IBTUB-OPT_MRA"),^TMP($JOB,"IBTUB-RX_MRA")
- +65 ;
- +66 ; - Initialize DM extract variables, if necessary.
- +67 IF $GET(IBXTRACT)
- DO E^IBJDE(37,1)
- FOR IBX=1:1:19
- SET IB(IBX)=0
- +68 ;
- +69 ; - Initialize Unbilled Amounts variables.
- +70 SET (IBUNB("ENCNTRS"),IBUNB("PRESCRP"),IBUNB("PRESCRP-MRA"))=0
- +71 FOR IBX="IP","OP","RX","TL"
- SET IBUNB("UNBIL"_IBX)=0
- SET IBUNB("UNBIL"_IBX_"-MRA")=0
- +72 FOR IBX="I","P"
- SET (IBUNB("EPISM-"_IBX),IBUNB("EPISM-"_IBX_"-MRA"),IBUNB("CPTMS-"_IBX),IBUNB("CPTMS-"_IBX_"-MRA"))=0
- +73 SET (IBUNB("EPISM-A"),IBUNB("EPISM-A-MRA"))=0
- +74 ;
- +75 ; - Retrieve the Rate Type code for Reimbursable Insurance
- +76 SET IBRT=$SELECT($ORDER(^DGCR(399.3,"B","REIMBURSABLE INS.",0)):$ORDER(^(0)),1:8)
- +77 ;
- +78 ; - If Compile/Store - Checks if the Average Bill Amounts exists for
- +79 ; IBTIMON. If it does not, calls IBTUBAV to calculate/updated it.
- +80 IF $GET(IBCOMP)
- Begin DoDot:1
- +81 IF $PIECE($GET(^IBE(356.19,IBTIMON,1)),"^",14)'=""
- QUIT
- +82 ;
- +83 ; - DQ^IBTUBAV will kill the variables IBTIMON and IBCOMP - That's why
- +84 ; they are being set again after this call.
- +85 SET IBSAV=IBTIMON
- DO DQ^IBTUBAV
- SET IBTIMON=IBSAV
- SET IBCOMP=1
- +86 QUIT
- End DoDot:1
- +87 ;
- PROC ; - Loops through all the entries in the Claims Tracking file for the
- +1 ; period selected and calculate the Unbilled Amounts
- +2 ;JRA;IB*2.0*608 Flag set to 1 if patient has non-veteran eligibility
- NEW NVELIG
- +3 SET IBDT=IBBDT-.1
- +4 ;
- +5 FOR
- SET IBDT=$ORDER(^IBT(356,"D",IBDT))
- if 'IBDT!(IBDT>IBEDT)
- QUIT
- Begin DoDot:1
- +6 SET IBX=0
- FOR
- SET IBX=$ORDER(^IBT(356,"D",IBDT,IBX))
- if 'IBX
- QUIT
- Begin DoDot:2
- +7 SET IBNODE=$GET(^IBT(356,IBX,0))
- if IBNODE=""
- QUIT
- +8 ; Tort-Feasor,Workman's Comp,No-fault Auto Acc.
- IF $PIECE(IBNODE,U,12)
- QUIT
- +9 ; Reason not billable assigned.
- IF $PIECE(IBNODE,U,19)
- QUIT
- +10 ; Inactive.
- IF '$PIECE(IBNODE,U,20)
- QUIT
- +11 SET DFN=+$PIECE(IBNODE,U,2)
- +12 ;Non-veteran eligibility includes CHAMPVA & TRICARE which is non-MCCF so do not screen out
- +13 ;I '$$PTCHK^IBTUBOU(DFN,IBNODE) Q ; Has a non-veteran eligibility. ;JRA;IB*2.0*608 ';'
- +14 ;JRA;IB*2.0*608
- SET NVELIG='$$PTCHK^IBTUBOU(DFN,IBNODE)
- +15 ; Not insured during care.
- IF '$$INSURED^IBCNS1(DFN,IBDT)
- QUIT
- +16 ;JRA;IB*2.0*608 No Inpatient for Non-MCCF
- +17 ;I $P(IBNODE,U,5),IBSEL[1,$$COV^IBTUBOU(DFN,IBDT,1) D Q ;Inpatient ;JRA;IB*2.0*608 ';'
- +18 ;Inpatient ;JRA;IB*2.0*608
- IF 'NVELIG
- IF $GET(IBMCCF)'="N"
- IF $PIECE(IBNODE,U,5)
- IF IBSEL[1
- IF $$COV^IBTUBOU(DFN,IBDT,1)
- Begin DoDot:3
- +19 SET DGPM=+$PIECE(IBNODE,U,5)
- DO INPT^IBTUBO2(DGPM)
- End DoDot:3
- QUIT
- +20 ;Outpatient
- IF $PIECE(IBNODE,U,4)
- IF IBSEL[2
- IF $$COV^IBTUBOU(DFN,IBDT,2)
- Begin DoDot:3
- +21 ; Non-Count Clinic
- SET IBOE=+$PIECE(IBNODE,U,4)
- IF $$NCCL^IBTUBOU(IBOE)
- QUIT
- +22 ;JRA;IB*2.0*608 Check if Eligibility of Encounter, Appointment Type & Rate Type meet MCCF/Non-MCCF Criteria
- +23 ;JRA;IB*2.0*608
- IF $GET(IBMCCF)]""
- IF (IBMCCF'="B")
- NEW OK
- SET OK=1
- Begin DoDot:4
- +24 NEW CLAIM
- SET CLAIM=+$PIECE(IBNODE,U,11)
- +25 ;If looking only for MCCF and there is a non-veteran eligibility, this entry is Non-MCCF so don't process
- +26 ;Copied condition from above & modified
- IF IBMCCF="M"
- IF '$$PTCHK^IBTUBOU(DFN,IBNODE)
- SET OK=0
- QUIT
- +27 ;Check Eligibilty of Encounter
- IF IBOE
- SET OK=$$MCCFCKX^IBTUBOU(409.68,IBOE,.13,"ELIG")
- +28 ;Check Appointment Type
- IF IBOE
- IF ((OK'=1&(IBMCCF="N"))!(IBMCCF="M"&(OK)))
- SET OK=$$MCCFCKX^IBTUBOU(409.68,IBOE,.1,"ATYP")
- +29 ;Check Rate Type
- IF CLAIM
- IF ((OK'=1&(IBMCCF="N"))!(IBMCCF="M"&(OK)))
- SET OK=$$MCCFCKX^IBTUBOU(399,CLAIM,.07,"RTYP")
- End DoDot:4
- if 'OK
- QUIT
- +30 DO OPT^IBTUBO1(IBOE,.IBQUERY)
- End DoDot:3
- QUIT
- +31 ;JRA;IB*2.0*608 Quit if Non-MCCF since only want Outpatient or quit if patient has non-veteran eligibility
- if ($GET(IBMCCF)="N"!(NVELIG))
- QUIT
- +32 ;Prescription
- IF $PIECE(IBNODE,U,8)
- IF IBSEL[3
- IF $$COV^IBTUBOU(DFN,IBDT,3)
- Begin DoDot:3
- +33 NEW IBIFN,IBCSTAT
- SET IBIFN=+$PIECE(IBNODE,U,11)
- +34 ;already billed (modified in T9)
- IF IBIFN
- SET IBCSTAT=$$GET1^DIQ(399,IBIFN_",",.13,"I")
- if $SELECT(IBCSTAT=0
- QUIT
- +35 SET IBRX=+$PIECE(IBNODE,U,8)
- DO RX^IBTUBO2(IBRX)
- End DoDot:3
- QUIT
- +36 ;
- +37 ; - Check CT entry event type to get unbilled amounts, if necessary.
- +38 SET IBTYP=$PIECE($GET(^IBE(356.6,+$PIECE(IBNODE,U,18),0)),U,8)
- +39 IF IBTYP=1
- IF IBSEL[1
- IF $$COV^IBTUBOU(DFN,IBDT,1)
- Begin DoDot:3
- +40 DO INPT^IBTUBO2(+$ORDER(^DGPM("APTT1",DFN,IBDT,0)))
- End DoDot:3
- +41 IF IBTYP=2
- IF IBSEL[2
- IF $$COV^IBTUBOU(DFN,IBDT,2)
- Begin DoDot:3
- +42 DO OPT^IBTUBO1("",.IBQUERY)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +43 ;
- +44 ; Load extract file, if necessary.
- IF $GET(IBXTRACT)
- DO XTRACT^IBTUBOU
- +45 ;
- +46 ; MRD;IB*2.0*516 - Moved code that was here into the new
- +47 ; procedure TOTAL, and tally most of the values up by Division.
- +48 ;
- +49 DO TOTAL
- +50 ;
- +51 ; - If Compile/Store - update Unbilled Amounts data on file #356.19
- +52 IF $GET(IBCOMP)
- DO LD^IBTUBOU(3,IBTIMON)
- +53 ;
- PRT ; - Print report(s).
- +1 IF $GET(IBQUERY)
- DO CLOSE^IBSDU(.IBQUERY)
- +2 DO REPORT^IBTUBO3
- +3 ;
- END KILL ^TMP($JOB,"IBTUB-INPT"),^TMP($JOB,"IBTUB-OPT"),^TMP($JOB,"IBTUB-RX")
- +1 KILL IBDT,IBRT,IBUNB
- +2 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +3 DO ^%ZISC
- KILL IBTEMON,IBXTRACT,D,D0,DA,DIC,DIE
- +4 QUIT
- +5 ;
- TOTAL ; Determine grand total amounts.
- +1 ;
- +2 ; - Calculate the Amount Inpatient INST. & PROF. Unbilled Amounts,
- +3 ; based on average amounts of Billed Amounts
- +4 ;
- +5 SET IBIAV=$$INPAVG^IBTUBOU(IBTIMON)
- +6 ;
- +7 ; Inst
- SET IBAMTI=$PIECE(IBIAV,"^")*$GET(IBUNB("EPISM-I"))
- +8 ; Inst
- SET IBAMTIM=$PIECE(IBIAV,"^")*$GET(IBUNB("EPISM-I-MRA"))
- +9 ; Prof
- SET IBAMTP=$PIECE(IBIAV,"^",2)*$GET(IBUNB("EPISM-P"))
- +10 ; Prof
- SET IBAMTPM=$PIECE(IBIAV,"^",2)*$GET(IBUNB("EPISM-P-MRA"))
- +11 ;
- +12 SET IBUNB("UNBILIP")=IBAMTI+IBAMTP
- +13 SET IBUNB("UNBILIP-MRA")=IBAMTIM+IBAMTPM
- +14 ;
- +15 ;S IBUNB("UNBILTL")=IBUNB("UNBILIP")
- +16 ;S IBUNB("UNBILTL-MRA")=IBUNB("UNBILIP-MRA")
- +17 ;
- +18 ; - Calculate Unbilled Amounts Totals by Division
- +19 ;
- +20 SET IBDIV=0
- +21 FOR
- SET IBDIV=$ORDER(IBUNB(IBDIV))
- if 'IBDIV
- QUIT
- Begin DoDot:1
- +22 ;
- +23 ; Inst
- SET IBAMTI=$PIECE(IBIAV,"^")*$GET(IBUNB(IBDIV,"EPISM-I"))
- +24 ; Inst
- SET IBAMTIM=$PIECE(IBIAV,"^")*$GET(IBUNB(IBDIV,"EPISM-I-MRA"))
- +25 ; Prof
- SET IBAMTP=$PIECE(IBIAV,"^",2)*$GET(IBUNB(IBDIV,"EPISM-P"))
- +26 ; Prof
- SET IBAMTPM=$PIECE(IBIAV,"^",2)*$GET(IBUNB(IBDIV,"EPISM-P-MRA"))
- +27 ;
- +28 SET IBUNB(IBDIV,"UNBILIP")=IBAMTI+IBAMTP
- +29 SET IBUNB(IBDIV,"UNBILIP-MRA")=IBAMTIM+IBAMTPM
- +30 ;
- +31 SET IBUNB("UNBILTL")=$GET(IBUNB("UNBILTL"))+$GET(IBUNB(IBDIV,"UNBILIP"))+$GET(IBUNB(IBDIV,"UNBILOP"))+$GET(IBUNB(IBDIV,"UNBILRX"))
- +32 SET IBUNB("UNBILTL-MRA")=$GET(IBUNB("UNBILTL-MRA"))+$GET(IBUNB(IBDIV,"UNBILIP-MRA"))+$GET(IBUNB(IBDIV,"UNBILOP-MRA"))+$GET(IBUNB(IBDIV,"UNBILRX-MRA"))
- +33 ;
- +34 QUIT
- End DoDot:1
- +35 ;
- +36 QUIT
- +37 ;